/[cmucl]/src/code/unix-glibc2.lisp
ViewVC logotype

Contents of /src/code/unix-glibc2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Fri Aug 25 09:59:06 2000 UTC (13 years, 7 months ago) by pw
Branch: MAIN
Changes since 1.11: +2 -2 lines
In fcntl, make arg types to syscall agree with function arg declarations.
1 dtc 1.1 ;;; -*- Package: UNIX -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 pw 1.12 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/unix-glibc2.lisp,v 1.12 2000/08/25 09:59:06 pw Exp $")
9 dtc 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the UNIX low-level support for glibc2. Based
13 dtc 1.5 ;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998).
14     ;;; Alpha support by Julian Dolby, 1999.
15 dtc 1.1 ;;;
16 dtc 1.2 ;;; All the functions with #+nil in front are work in progress,
17     ;;; and mostly don't work.
18     ;;;
19     ;; Todo: #+nil'ed stuff and ioctl's
20     ;;
21 dtc 1.1 (in-package "UNIX")
22     (use-package "ALIEN")
23     (use-package "C-CALL")
24     (use-package "SYSTEM")
25     (use-package "EXT")
26    
27     (export '(
28     daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t
29     timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime
30     itimerval it-interval it-value tchars t-intrc t-quitc t-startc
31     t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc
32     t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill
33     sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel
34     direct d-off d-ino d-reclen d-name
35     stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size
36     st-atime st-mtime st-ctime st-blksize st-blocks
37     s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock
38     s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec
39     ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss
40     ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock
41     ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw
42     rlimit rlim-cur rlim-max sc-onstack sc-mask sc-pc
43     unix-errno get-unix-error-msg
44     unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
45     unix-setitimer unix-getitimer
46     unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
47     setgidexec savetext readown writeown execown readgrp writegrp
48     execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown
49     unix-getdtablesize unix-close unix-creat unix-dup unix-dup2
50     unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown
51     fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek
52     l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr
53     o_ndelay
54     o_noctty
55     o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink
56     unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr
57     fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate
58     unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl
59     tcsetpgrp tcgetpgrp tty-process-group
60     terminal-speeds tty-raw tty-crmod tty-echo tty-lcase
61     tty-cbreak
62     termios
63     c-lflag
64     c-iflag
65     c-oflag
66     tty-icrnl
67     tty-ocrnl
68     veof
69     vintr
70     vquit
71     vstart
72     vstop
73     vsusp
74     c-cflag
75     c-cc
76     tty-icanon
77     vmin
78     vtime
79     tty-ixon
80     tcsanow
81     tcsadrain
82     tciflush
83     tcoflush
84     tcioflush
85     tcsaflush
86     unix-tcgetattr
87     unix-tcsetattr
88     tty-ignbrk
89     tty-brkint
90     tty-ignpar
91     tty-parmrk
92     tty-inpck
93     tty-istrip
94     tty-inlcr
95     tty-igncr
96     tty-iuclc
97     tty-ixany
98     tty-ixoff
99     tty-imaxbel
100     tty-opost
101     tty-olcuc
102     tty-onlcr
103     tty-onocr
104     tty-onlret
105     tty-ofill
106     tty-ofdel
107     tty-isig
108     tty-xcase
109     tty-echoe
110     tty-echok
111     tty-echonl
112     tty-noflsh
113     tty-iexten
114     tty-tostop
115     tty-echoctl
116     tty-echoprt
117     tty-echoke
118     tty-pendin
119     tty-cstopb
120     tty-cread
121     tty-parenb
122     tty-parodd
123     tty-hupcl
124     tty-clocal
125     vintr
126     verase
127     vkill
128     veol
129     veol2
130     TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC
131     TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ
132     TIOCSIGSEND
133    
134     KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK
135     KBDSCLICK FIONREAD unix-exit unix-stat unix-lstat unix-fstat
136     unix-getrusage unix-fast-getrusage rusage_self rusage_children
137     unix-gettimeofday
138 dtc 1.8 unix-utimes unix-sched-yield unix-setreuid
139 dtc 1.1 unix-setregid
140     unix-getpid unix-getppid
141     unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid
142     unix-getpagesize unix-gethostname unix-gethostid unix-fork
143     unix-current-directory unix-isatty unix-ttyname unix-execve
144     unix-socket unix-connect unix-bind unix-listen unix-accept
145 dtc 1.9 unix-recv unix-send unix-getpeername unix-getsockname
146     unix-getsockopt unix-setsockopt))
147 dtc 1.1
148     (pushnew :unix *features*)
149 dtc 1.2 (pushnew :glibc2 *features*)
150 dtc 1.1
151     ;;;; Common machine independent structures.
152    
153 dtc 1.2 (eval-when (compile eval)
154 dtc 1.1
155 dtc 1.2 (defparameter *compiler-unix-errors* nil)
156 dtc 1.1
157 dtc 1.2 (defmacro def-unix-error (name number description)
158     `(progn
159     (eval-when (compile eval)
160     (push (cons ,number ,description) *compiler-unix-errors*))
161     (defconstant ,name ,number ,description)
162     (export ',name)))
163 dtc 1.1
164 dtc 1.2 (defmacro emit-unix-errors ()
165     (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
166     (array (make-array (1+ max) :initial-element nil)))
167     (dolist (error *compiler-unix-errors*)
168     (setf (svref array (car error)) (cdr error)))
169     `(progn
170     (defvar *unix-errors* ',array)
171     (proclaim '(simple-vector *unix-errors*)))))
172 dtc 1.1
173 dtc 1.2 )
174 dtc 1.1
175 dtc 1.2 (defmacro def-enum (inc cur &rest names)
176     (flet ((defform (name)
177     (prog1 (when name `(defconstant ,name ,cur))
178     (setf cur (funcall inc cur 1)))))
179     `(progn ,@(mapcar #'defform names))))
180 dtc 1.1
181 dtc 1.2 ;;;; Lisp types used by syscalls.
182 dtc 1.1
183 dtc 1.2 (deftype unix-pathname () 'simple-string)
184     (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
185 dtc 1.1
186 dtc 1.2 (deftype unix-file-mode () '(unsigned-byte 32))
187     (deftype unix-pid () '(unsigned-byte 32))
188     (deftype unix-uid () '(unsigned-byte 32))
189     (deftype unix-gid () '(unsigned-byte 32))
190 dtc 1.1
191 dtc 1.2 ;;;; System calls.
192     (def-alien-variable ("errno" unix-errno) int)
193 dtc 1.1
194 dtc 1.2 ;;; later...
195     (defun unix-get-errno ())
196 dtc 1.1
197 dtc 1.2 ;;; GET-UNIX-ERROR-MSG -- public.
198     ;;;
199     (defun get-unix-error-msg (&optional (error-number unix-errno))
200     "Returns a string describing the error number which was returned by a
201     UNIX system call."
202     (declare (type integer error-number))
203    
204     (unix-get-errno)
205     (if (array-in-bounds-p *unix-errors* error-number)
206     (svref *unix-errors* error-number)
207     (format nil "Unknown error [~d]" error-number)))
208 dtc 1.1
209 dtc 1.2 (defmacro syscall ((name &rest arg-types) success-form &rest args)
210     `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
211     ,@args)))
212     (if (minusp result)
213     (progn
214     (unix-get-errno)
215     (values nil unix-errno))
216     ,success-form)))
217 dtc 1.1
218 dtc 1.2 ;;; Like syscall, but if it fails, signal an error instead of returing error
219     ;;; codes. Should only be used for syscalls that will never really get an
220     ;;; error.
221     ;;;
222     (defmacro syscall* ((name &rest arg-types) success-form &rest args)
223     `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
224     ,@args)))
225     (if (minusp result)
226     (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
227     ,success-form)))
228 dtc 1.1
229 dtc 1.2 (defmacro void-syscall ((name &rest arg-types) &rest args)
230     `(syscall (,name ,@arg-types) (values t 0) ,@args))
231 dtc 1.1
232 dtc 1.2 (defmacro int-syscall ((name &rest arg-types) &rest args)
233     `(syscall (,name ,@arg-types) (values result 0) ,@args))
234 dtc 1.1
235 dtc 1.2 (defun unix-get-errno ()
236     "Get the unix errno value in errno..."
237     (void-syscall ("update_errno")))
238     ;;; From stdio.h
239 dtc 1.1
240 dtc 1.2 ;;; Unix-rename accepts two files names and renames the first to the second.
241 dtc 1.1
242 dtc 1.2 (defun unix-rename (name1 name2)
243     "Unix-rename renames the file with string name1 to the string
244     name2. NIL and an error code is returned if an error occured."
245     (declare (type unix-pathname name1 name2))
246     (void-syscall ("rename" c-string c-string) name1 name2))
247 dtc 1.1
248 dtc 1.2 ;;; From sys/types.h
249     ;;; and
250     ;;; gnu/types.h
251 dtc 1.1
252 dtc 1.2 (defconstant +max-s-long+ 2147483647)
253     (defconstant +max-u-long+ 4294967295)
254 dtc 1.1
255 dtc 1.2 (def-alien-type quad-t #+nil long-long #-nil (array long 2))
256     (def-alien-type uquad-t #+nil unsigned-long-long
257     #-nil (array unsigned-long 2))
258     (def-alien-type qaddr-t (* quad-t))
259     (def-alien-type daddr-t int)
260     (def-alien-type caddr-t (* char))
261     (def-alien-type swblk-t long)
262 pw 1.4 (def-alien-type size-t #-alpha unsigned-int #+alpha long)
263 dtc 1.2 (def-alien-type time-t long)
264     (def-alien-type clock-t long)
265     (def-alien-type uid-t unsigned-int)
266 pw 1.4 (def-alien-type ssize-t #-alpha int #+alpha long)
267 dtc 1.2 (def-alien-type key-t int)
268     (def-alien-type int8-t char)
269     (def-alien-type u-int8-t unsigned-char)
270     (def-alien-type int16-t short)
271     (def-alien-type u-int16-t unsigned-short)
272     (def-alien-type int32-t int)
273     (def-alien-type u-int32-t unsigned-int)
274     (def-alien-type int64-t #+nil long-long #-nil (array long 2))
275     (def-alien-type u-int64-t #+nil unsigned-long-long #-nil (array unsigned-long 2))
276 pw 1.4 (def-alien-type register-t #-alpha int #+alpha long)
277 dtc 1.1
278    
279 pw 1.4 (def-alien-type dev-t #-alpha uquad-t #+alpha unsigned-long)
280 dtc 1.2 (def-alien-type uid-t unsigned-int)
281     (def-alien-type gid-t unsigned-int)
282 pw 1.4 (def-alien-type ino-t #-alpha unsigned-long #+alpha unsigned-int)
283 dtc 1.2 (def-alien-type mode-t unsigned-int)
284     (def-alien-type nlink-t unsigned-int)
285     (def-alien-type off-t long)
286     (def-alien-type loff-t quad-t)
287     (def-alien-type pid-t int)
288 pw 1.4 (def-alien-type ssize-t #-alpha int #+alpha long)
289 dtc 1.1
290 dtc 1.2 (def-alien-type fsid-t (array int 2))
291 dtc 1.1
292 pw 1.4 (def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int)
293    
294 dtc 1.2 (defconstant fd-setsize 1024)
295 pw 1.4 (defconstant nfdbits 32)
296    
297 dtc 1.2 (def-alien-type nil
298     (struct fd-set
299 pw 1.4 (fds-bits (array fd-mask #.(/ fd-setsize nfdbits)))))
300 dtc 1.1
301 dtc 1.2 (def-alien-type key-t int)
302 dtc 1.1
303 dtc 1.2 (def-alien-type ipc-pid-t unsigned-short)
304 dtc 1.1
305 dtc 1.2 ;;; direntry.h
306 dtc 1.1
307     (def-alien-type nil
308     (struct direct
309 dtc 1.2 (d-ino long); inode number of entry
310     (d-off off-t) ; offset of next disk directory entry
311 dtc 1.1 (d-reclen unsigned-short) ; length of this record
312 dtc 1.2 (d_type unsigned-char)
313 dtc 1.1 (d-name (array char 256)))) ; name must be no longer than this
314 dtc 1.2 ;;; dirent.h
315 dtc 1.1
316 dtc 1.2 ;;; Operations on Unix Directories.
317 dtc 1.1
318 dtc 1.2 (export '(open-dir read-dir close-dir))
319 dtc 1.1
320 dtc 1.2 (defstruct (directory
321     (:print-function %print-directory))
322     name
323     (dir-struct (required-argument) :type system-area-pointer))
324 dtc 1.1
325 dtc 1.2 (defun %print-directory (dir stream depth)
326     (declare (ignore depth))
327     (format stream "#<Directory ~S>" (directory-name dir)))
328 dtc 1.1
329 dtc 1.2 (defun open-dir (pathname)
330     (declare (type unix-pathname pathname))
331     (when (string= pathname "")
332     (setf pathname "."))
333     (let ((kind (unix-file-kind pathname)))
334     (case kind
335     (:directory
336     (let ((dir-struct
337     (alien-funcall (extern-alien "opendir"
338     (function system-area-pointer
339     c-string))
340     pathname)))
341     (if (zerop (sap-int dir-struct))
342     (progn (unix-get-errno)
343     (values nil unix-errno))
344     (make-directory :name pathname :dir-struct dir-struct))))
345     ((nil)
346     (values nil enoent))
347     (t
348     (values nil enotdir)))))
349 dtc 1.1
350 dtc 1.2 (defun read-dir (dir)
351     (declare (type directory dir))
352     (let ((daddr (alien-funcall (extern-alien "readdir"
353     (function system-area-pointer
354     system-area-pointer))
355     (directory-dir-struct dir))))
356     (declare (type system-area-pointer daddr))
357     (if (zerop (sap-int daddr))
358     nil
359     (with-alien ((direct (* (struct direct)) daddr))
360     (values (cast (slot direct 'd-name) c-string)
361     (slot direct 'd-ino))))))
362 dtc 1.1
363 dtc 1.2 (defun close-dir (dir)
364     (declare (type directory dir))
365     (alien-funcall (extern-alien "closedir"
366     (function void system-area-pointer))
367     (directory-dir-struct dir))
368     nil)
369 dtc 1.1
370 dtc 1.2 ;;; dlfcn.h -> in foreign.lisp
371 dtc 1.1
372 dtc 1.2 ;;; fcntl.h
373     ;;;
374     ;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
375 dtc 1.1
376 dtc 1.2 (defconstant r_ok 4 "Test for read permission")
377     (defconstant w_ok 2 "Test for write permission")
378     (defconstant x_ok 1 "Test for execute permission")
379     (defconstant f_ok 0 "Test for presence of file")
380 dtc 1.1
381 dtc 1.2 (defun unix-fcntl (fd cmd arg)
382     "Unix-fcntl manipulates file descriptors accoridng to the
383     argument CMD which can be one of the following:
384 dtc 1.1
385 dtc 1.2 F-DUPFD Duplicate a file descriptor.
386     F-GETFD Get file descriptor flags.
387     F-SETFD Set file descriptor flags.
388     F-GETFL Get file flags.
389     F-SETFL Set file flags.
390     F-GETOWN Get owner.
391     F-SETOWN Set owner.
392 dtc 1.1
393 dtc 1.2 The flags that can be specified for F-SETFL are:
394 dtc 1.1
395 dtc 1.2 FNDELAY Non-blocking reads.
396     FAPPEND Append on each write.
397     FASYNC Signal pgrp when data ready.
398     FCREAT Create if nonexistant.
399     FTRUNC Truncate to zero length.
400     FEXCL Error if already created.
401     "
402     (declare (type unix-fd fd)
403 pw 1.11 (type (unsigned-byte 32) cmd)
404     (type (unsigned-byte 32) arg))
405 pw 1.12 (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg))
406 dtc 1.1
407 dtc 1.2 (defun unix-open (path flags mode)
408     "Unix-open opens the file whose pathname is specified by path
409     for reading and/or writing as specified by the flags argument.
410     The flags argument can be:
411 dtc 1.1
412 dtc 1.2 o_rdonly Read-only flag.
413     o_wronly Write-only flag.
414     o_rdwr Read-and-write flag.
415     o_append Append flag.
416     o_creat Create-if-nonexistant flag.
417     o_trunc Truncate-to-size-0 flag.
418     o_excl Error if the file allready exists
419     o_noctty Don't assign controlling tty
420     o_ndelay Non-blocking I/O
421     o_sync Synchronous I/O
422     o_async Asynchronous I/O
423 dtc 1.1
424 dtc 1.2 If the o_creat flag is specified, then the file is created with
425     a permission of argument mode if the file doesn't exist. An
426     integer file descriptor is returned by unix-open."
427     (declare (type unix-pathname path)
428     (type fixnum flags)
429     (type unix-file-mode mode))
430     (int-syscall ("open" c-string int int) path flags mode))
431 dtc 1.1
432 dtc 1.2 (defun unix-getdtablesize ()
433     "Unix-getdtablesize returns the maximum size of the file descriptor
434     table. (i.e. the maximum number of descriptors that can exist at
435     one time.)"
436     (int-syscall ("getdtablesize")))
437 dtc 1.1
438 dtc 1.2 ;;; Unix-close accepts a file descriptor and attempts to close the file
439     ;;; associated with it.
440 dtc 1.1
441 dtc 1.2 (defun unix-close (fd)
442     "Unix-close takes an integer file descriptor as an argument and
443     closes the file associated with it. T is returned upon successful
444     completion, otherwise NIL and an error number."
445     (declare (type unix-fd fd))
446     (void-syscall ("close" int) fd))
447 dtc 1.1
448 dtc 1.2 ;;; Unix-creat accepts a file name and a mode. It creates a new file
449     ;;; with name and sets it mode to mode (as for chmod).
450 dtc 1.1
451 dtc 1.2 (defun unix-creat (name mode)
452     "Unix-creat accepts a file name and a mode (same as those for
453     unix-chmod) and creates a file by that name with the specified
454     permission mode. It returns a file descriptor on success,
455     or NIL and an error number otherwise.
456 dtc 1.1
457 dtc 1.2 This interface is made obsolete by UNIX-OPEN."
458 dtc 1.1
459 dtc 1.2 (declare (type unix-pathname name)
460     (type unix-file-mode mode))
461     (int-syscall ("creat" c-string int) name mode))
462    
463     ;;; fcntlbits.h
464 dtc 1.1
465 dtc 1.2 (defconstant o_read o_rdonly "Open for reading")
466     (defconstant o_write o_wronly "Open for writing")
467 dtc 1.1
468 dtc 1.2 (defconstant o_rdonly 0 "Read-only flag.")
469     (defconstant o_wronly 1 "Write-only flag.")
470     (defconstant o_rdwr 2 "Read-write flag.")
471     (defconstant o_accmode 3 "Access mode mask.")
472 pw 1.4
473     #-alpha
474     (progn
475     (defconstant o_creat #o100 "Create if nonexistant flag. (not fcntl)")
476     (defconstant o_excl #o200 "Error if already exists. (not fcntl)")
477     (defconstant o_noctty #o400 "Don't assign controlling tty. (not fcntl)")
478     (defconstant o_trunc #o1000 "Truncate flag. (not fcntl)")
479     (defconstant o_append #o2000 "Append flag.")
480     (defconstant o_ndelay #o4000 "Non-blocking I/O")
481     (defconstant o_nonblock #o4000 "Non-blocking I/O")
482     (defconstant o_ndelay o_nonblock)
483     (defconstant o_sync #o10000 "Synchronous writes (on ext2)")
484     (defconstant o_fsync o_sync)
485     (defconstant o_async #o20000 "Asynchronous I/O"))
486     #+alpha
487     (progn
488     (defconstant o_creat #o1000 "Create if nonexistant flag. (not fcntl)")
489     (defconstant o_trunc #o2000 "Truncate flag. (not fcntl)")
490     (defconstant o_excl #o4000 "Error if already exists. (not fcntl)")
491     (defconstant o_noctty #o10000 "Don't assign controlling tty. (not fcntl)")
492     (defconstant o_nonblock #o4 "Non-blocking I/O")
493     (defconstant o_append #o10 "Append flag.")
494     (defconstant o_ndelay o_nonblock)
495     (defconstant o_sync #o40000 "Synchronous writes (on ext2)")
496     (defconstant o_fsync o_sync)
497     (defconstant o_async #o20000 "Asynchronous I/O"))
498 dtc 1.1
499 dtc 1.2 (defconstant f-dupfd 0 "Duplicate a file descriptor")
500     (defconstant f-getfd 1 "Get file desc. flags")
501     (defconstant f-setfd 2 "Set file desc. flags")
502     (defconstant f-getfl 3 "Get file flags")
503     (defconstant f-setfl 4 "Set file flags")
504 pw 1.4
505     #-alpha
506     (progn
507     (defconstant f-getlk 5 "Get lock")
508     (defconstant f-setlk 6 "Set lock")
509     (defconstant f-setlkw 7 "Set lock, wait for release")
510     (defconstant f-setown 8 "Set owner (for sockets)")
511     (defconstant f-getown 9 "Get owner (for sockets)"))
512     #+alpha
513     (progn
514     (defconstant f-getlk 7 "Get lock")
515     (defconstant f-setlk 8 "Set lock")
516     (defconstant f-setlkw 9 "Set lock, wait for release")
517     (defconstant f-setown 5 "Set owner (for sockets)")
518     (defconstant f-getown 6 "Get owner (for sockets)"))
519    
520    
521 dtc 1.2
522     (defconstant F-CLOEXEC 1 "for f-getfl and f-setfl")
523    
524 pw 1.4 #-alpha
525     (progn
526     (defconstant F-RDLCK 0 "for fcntl and lockf")
527     (defconstant F-WDLCK 1 "for fcntl and lockf")
528     (defconstant F-UNLCK 2 "for fcntl and lockf")
529     (defconstant F-EXLCK 4 "old bsd flock (depricated)")
530     (defconstant F-SHLCK 8 "old bsd flock (depricated)"))
531     #+alpha
532     (progn
533     (defconstant F-RDLCK 1 "for fcntl and lockf")
534     (defconstant F-WDLCK 2 "for fcntl and lockf")
535     (defconstant F-UNLCK 8 "for fcntl and lockf")
536     (defconstant F-EXLCK 16 "old bsd flock (depricated)")
537     (defconstant F-SHLCK 32 "old bsd flock (depricated)"))
538 dtc 1.1
539 dtc 1.2 (defconstant F-LOCK-SH 1 "Shared lock for bsd flock")
540     (defconstant F-LOCK-EX 2 "Exclusive lock for bsd flock")
541     (defconstant F-LOCK-NB 4 "Don't block. Combine with F-LOCK-SH or F-LOCK-EX")
542     (defconstant F-LOCK-UN 8 "Remove lock for bsd flock")
543 dtc 1.1
544 dtc 1.2 (def-alien-type nil
545     (struct flock
546     (l-type short)
547     (l-whence short)
548     (l-start off-t)
549     (l-len off-t)
550     (l-pid pid-t)))
551 dtc 1.1
552 dtc 1.2 ;;; Define some more compatibility macros to be backward compatible with
553     ;;; BSD systems which did not managed to hide these kernel macros.
554 dtc 1.1
555 dtc 1.2 (defconstant FAPPEND o_append "depricated stuff")
556     (defconstant FFSYNC o_fsync "depricated stuff")
557     (defconstant FASYNC o_async "depricated stuff")
558     (defconstant FNONBLOCK o_nonblock "depricated stuff")
559     (defconstant FNDELAY o_ndelay "depricated stuff")
560 dtc 1.1
561    
562 dtc 1.2 ;;; grp.h
563 dtc 1.1
564 dtc 1.2 ;;; POSIX Standard: 9.2.1 Group Database Access <grp.h>
565 dtc 1.1
566 dtc 1.2 (def-alien-type nil
567     (struct group
568     (gr-name c-string) ;; group name
569     (gr-passwd c-string) ;; password
570     (gr-gid gid-t) ;; group ID
571     (gr-mem (* c-string))))
572 dtc 1.1
573 dtc 1.2 #+nil
574     (defun unix-setgrend ()
575     "Rewind the group-file stream."
576     (void-syscall ("setgrend")))
577 dtc 1.1
578 dtc 1.2 #+nil
579     (defun unix-endgrent ()
580     "Close the group-file stream."
581     (void-syscall ("endgrent")))
582 dtc 1.1
583 dtc 1.2 #+nil
584     (defun unix-getgrent ()
585     "Read an entry from the group-file stream, opening it if necessary."
586    
587     (let ((result (alien-funcall (extern-alien "getgrent"
588     (function (* (struct group)))))))
589     (declare (type system-area-pointer result))
590     (if (zerop (sap-int result))
591     nil
592     result)))
593 dtc 1.1
594 dtc 1.2 #+nil
595     (defun unix-getgrgid (id)
596     "Search for an entry with a matching group ID."
597     (declare (type gid-t id))
598 dtc 1.1
599 dtc 1.2 (let ((result (alien-funcall (extern-alien "getgrgid"
600     (function (* (struct group))
601     gid-t))
602     id)))
603     (declare (type system-area-pointer result))
604     (if (zerop (sap-int result))
605     nil
606     result)))
607 dtc 1.1
608 dtc 1.2 #+nil
609     (defun unix-getgrnam (name)
610     "Search for an entry with a matching group ID."
611     (declare (type simple-string name))
612    
613     (let ((result (alien-funcall (extern-alien "getgrnam"
614     (function (* (struct group))
615     c-string))
616     name)))
617     (declare (type system-area-pointer result))
618     (if (zerop (sap-int result))
619     nil
620     result)))
621 dtc 1.1
622    
623 dtc 1.2 ;;; ioctl-types.h
624 dtc 1.1
625 dtc 1.2 (def-alien-type nil
626     (struct winsize
627     (ws-row unsigned-short) ; rows, in characters
628     (ws-col unsigned-short) ; columns, in characters
629     (ws-xpixel unsigned-short) ; horizontal size, pixels
630     (ws-ypixel unsigned-short))) ; veritical size, pixels
631 dtc 1.1
632 dtc 1.2 (defconstant +NCC+ 8
633     "Size of control character vector.")
634 dtc 1.1
635 dtc 1.2 (def-alien-type nil
636     (struct termio
637     (c-iflag unsigned-int) ; input mode flags
638     (c-oflag unsigned-int) ; output mode flags
639     (c-cflag unsigned-int) ; control mode flags
640     (c-lflag unsigned-int) ; local mode flags
641     (c-line unsigned-char) ; line discipline
642     (c-cc (array unsigned-char #.+NCC+)))) ; control characters
643 dtc 1.1
644 dtc 1.2 ;;; modem lines
645     (defconstant tiocm-le 1)
646     (defconstant tiocm-dtr 2)
647     (defconstant tiocm-rts 4)
648     (defconstant tiocm-st 8)
649     (defconstant tiocm-sr #x10)
650     (defconstant tiocm-cts #x20)
651     (defconstant tiocm-car #x40)
652     (defconstant tiocm-rng #x80)
653     (defconstant tiocm-dsr #x100)
654     (defconstant tiocm-cd tiocm-car)
655     (defconstant tiocm-ri #x80)
656 dtc 1.1
657 dtc 1.2 ;;; ioctl (fd, TIOCSERGETLSR, &result) where result may be as below
658 dtc 1.1
659 dtc 1.2 ;;; line disciplines
660     (defconstant N-TTY 0)
661     (defconstant N-SLIP 1)
662     (defconstant N-MOUSE 2)
663     (defconstant N-PPP 3)
664     (defconstant N-STRIP 4)
665     (defconstant N-AX25 5)
666    
667    
668     ;;; ioctls.h
669    
670     ;;; Routing table calls.
671     (defconstant siocaddrt #x890B) ;; add routing table entry
672     (defconstant siocdelrt #x890C) ;; delete routing table entry
673     (defconstant siocrtmsg #x890D) ;; call to routing system
674    
675     ;;; Socket configuration controls.
676     (defconstant siocgifname #x8910) ;; get iface name
677     (defconstant siocsiflink #x8911) ;; set iface channel
678     (defconstant siocgifconf #x8912) ;; get iface list
679     (defconstant siocgifflags #x8913) ;; get flags
680     (defconstant siocsifflags #x8914) ;; set flags
681     (defconstant siocgifaddr #x8915) ;; get PA address
682     (defconstant siocsifaddr #x8916) ;; set PA address
683     (defconstant siocgifdstaddr #x8917 ) ;; get remote PA address
684     (defconstant siocsifdstaddr #x8918 ) ;; set remote PA address
685     (defconstant siocgifbrdaddr #x8919 ) ;; get broadcast PA address
686     (defconstant siocsifbrdaddr #x891a ) ;; set broadcast PA address
687     (defconstant siocgifnetmask #x891b ) ;; get network PA mask
688     (defconstant siocsifnetmask #x891c ) ;; set network PA mask
689     (defconstant siocgifmetric #x891d ) ;; get metric
690     (defconstant siocsifmetric #x891e ) ;; set metric
691     (defconstant siocgifmem #x891f ) ;; get memory address (BSD)
692     (defconstant siocsifmem #x8920 ) ;; set memory address (BSD)
693     (defconstant siocgifmtu #x8921 ) ;; get MTU size
694     (defconstant siocsifmtu #x8922 ) ;; set MTU size
695     (defconstant siocsifhwaddr #x8924 ) ;; set hardware address
696     (defconstant siocgifencap #x8925 ) ;; get/set encapsulations
697     (defconstant siocsifencap #x8926)
698     (defconstant siocgifhwaddr #x8927 ) ;; Get hardware address
699     (defconstant siocgifslave #x8929 ) ;; Driver slaving support
700     (defconstant siocsifslave #x8930)
701     (defconstant siocaddmulti #x8931 ) ;; Multicast address lists
702     (defconstant siocdelmulti #x8932)
703     (defconstant siocgifindex #x8933 ) ;; name -> if_index mapping
704     (defconstant siogifindex SIOCGIFINDEX ) ;; misprint compatibility :-)
705     (defconstant siocsifpflags #x8934 ) ;; set/get extended flags set
706     (defconstant siocgifpflags #x8935)
707     (defconstant siocdifaddr #x8936 ) ;; delete PA address
708     (defconstant siocsifhwbroadcast #x8937 ) ;; set hardware broadcast addr
709     (defconstant siocgifcount #x8938 ) ;; get number of devices
710    
711     (defconstant siocgifbr #x8940 ) ;; Bridging support
712     (defconstant siocsifbr #x8941 ) ;; Set bridging options
713    
714     (defconstant siocgiftxqlen #x8942 ) ;; Get the tx queue length
715     (defconstant siocsiftxqlen #x8943 ) ;; Set the tx queue length
716    
717    
718     ;;; ARP cache control calls.
719     ;; 0x8950 - 0x8952 * obsolete calls, don't re-use
720     (defconstant siocdarp #x8953 ) ;; delete ARP table entry
721     (defconstant siocgarp #x8954 ) ;; get ARP table entry
722     (defconstant siocsarp #x8955 ) ;; set ARP table entry
723    
724     ;;; RARP cache control calls.
725     (defconstant siocdrarp #x8960 ) ;; delete RARP table entry
726     (defconstant siocgrarp #x8961 ) ;; get RARP table entry
727     (defconstant siocsrarp #x8962 ) ;; set RARP table entry
728    
729     ;;; Driver configuration calls
730    
731     (defconstant siocgifmap #x8970 ) ;; Get device parameters
732     (defconstant siocsifmap #x8971 ) ;; Set device parameters
733    
734     ;;; DLCI configuration calls
735    
736     (defconstant siocadddlci #x8980 ) ;; Create new DLCI device
737     (defconstant siocdeldlci #x8981 ) ;; Delete DLCI device
738    
739     ;;; Device private ioctl calls.
740    
741     ;; These 16 ioctls are available to devices via the do_ioctl() device
742     ;; vector. Each device should include this file and redefine these
743     ;; names as their own. Because these are device dependent it is a good
744     ;; idea _NOT_ to issue them to random objects and hope.
745 dtc 1.1
746 dtc 1.2 (defconstant siocdevprivate #x89F0 ) ;; to 89FF
747 dtc 1.1
748    
749 dtc 1.2 ;;; mathcalls.h
750 dtc 1.1
751 dtc 1.2 #+nil
752     (defmacro def-math-rtn (name num-args)
753     (let ((function (intern (concatenate 'simple-string
754     "%"
755     (string-upcase name)))))
756     `(progn
757     (proclaim '(inline ,function))
758     (export ',function)
759     (alien:def-alien-routine (,name ,function) double-float
760     ,@(let ((results nil))
761     (dotimes (i num-args (nreverse results))
762     (push (list (intern (format nil "ARG-~D" i))
763     'double-float)
764     results)))))))
765 dtc 1.1
766 dtc 1.2 #+nil
767     (defmacro def-math-rtn-int-double (name num-args)
768     (let ((function (intern (concatenate 'simple-string
769     "%"
770     (string-upcase name)))))
771     `(progn
772     (proclaim '(inline ,function))
773     (export ',function)
774     (alien:def-alien-routine (,name ,function) double-float
775     (ARG-1 'integer)
776     (ARG-2 'double)))))
777 dtc 1.1
778 dtc 1.2 #+nil
779     (def-math-rtn "expm1" 1) ;Return exp(X) - 1.
780 dtc 1.1
781 dtc 1.2 #+nil
782     (def-math-rtn "log1p" 1) ;Return log(1 + X).
783 dtc 1.1
784    
785 dtc 1.2 #+nil
786     (def-math-rtn "logb" 1) ;Return the base 2 signed integral exponent of X.
787 dtc 1.1
788 dtc 1.2 #+nil
789     (def-math-rtn "cbrt" 1) ; returns cuberoot
790 dtc 1.1
791 dtc 1.2 #+nil
792     (def-math-rtn "copysign" 2) ;Return X with its signed changed to Y's.
793 dtc 1.1
794 dtc 1.2 #+nil
795     (def-math-rtn "cabs" 2) ;Return `sqrt(X*X + Y*Y)'.
796 dtc 1.1
797 dtc 1.2 #+nil
798     (def-math-rtn "erf" 1)
799 dtc 1.1
800 dtc 1.2 #+nil
801     (def-math-rtn "erfc" 1)
802 dtc 1.1
803 dtc 1.2 #+nil
804     (def-math-rtn "gamma" 1)
805 dtc 1.1
806 dtc 1.2 #+nil
807     (def-math-rtn "j0" 1)
808 dtc 1.1
809 dtc 1.2 #+nil
810     (def-math-rtn "j1" 1)
811 dtc 1.1
812 dtc 1.2 #+nil
813     (def-math-rtn-int-double "jn")
814 dtc 1.1
815 dtc 1.2 #+nil
816     (def-math-rtn "lgamma" 1)
817 dtc 1.1
818 dtc 1.2 #+nil
819     (def-math-rtn "y0" 1)
820 dtc 1.1
821 dtc 1.2 #+nil
822     (def-math-rtn "y1" 1)
823 dtc 1.1
824 dtc 1.2 #+nil
825     (def-math-rtn-int-double "yn")
826 dtc 1.1
827 dtc 1.2 ;;; netdb.h
828 dtc 1.1
829 dtc 1.2 ;; All data returned by the network data base library are supplied in
830     ;; host order and returned in network order (suitable for use in
831     ;; system calls).
832    
833     ;;; Absolute file name for network data base files.
834     (defconstant path-hequiv "/etc/hosts.equiv")
835     (defconstant path-hosts "/etc/hosts")
836     (defconstant path-networks "/etc/networks")
837     (defconstant path-nsswitch_conf "/etc/nsswitch.conf")
838     (defconstant path-protocols "/etc/protocols")
839     (defconstant path-services "/etc/services")
840    
841    
842     ;;; Possible values left in `h_errno'.
843     (defconstant netdb-internal -1 "See errno.")
844     (defconstant netdb-success 0 "No problem.")
845     (defconstant host-not-found 1 "Authoritative Answer Host not found.")
846     (defconstant try-again 2 "Non-Authoritative Host not found,or SERVERFAIL.")
847     (defconstant no-recovery 3 "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
848     (defconstant no-data 4 "Valid name, no data record of requested type.")
849     (defconstant no-address no-data "No address, look for MX record.")
850 dtc 1.1
851 dtc 1.2 ;;; Description of data base entry for a single host.
852 dtc 1.1
853 dtc 1.2 (def-alien-type nil
854     (struct hostent
855     (h-name c-string) ; Official name of host.
856     (h-aliases (* c-string)) ; Alias list.
857     (h-addrtype int) ; Host address type.
858     (h_length int) ; Length of address.
859     (h-addr-list (* c-string)))) ; List of addresses from name server.
860 dtc 1.1
861 dtc 1.2 #+nil
862     (defun unix-sethostent (stay-open)
863     "Open host data base files and mark them as staying open even after
864     a later search if STAY_OPEN is non-zero."
865     (void-syscall ("sethostent" int) stay-open))
866 dtc 1.1
867 dtc 1.2 #+nil
868     (defun unix-endhostent ()
869     "Close host data base files and clear `stay open' flag."
870     (void-syscall ("endhostent")))
871 dtc 1.1
872 dtc 1.2 #+nil
873     (defun unix-gethostent ()
874     "Get next entry from host data base file. Open data base if
875     necessary."
876     (let ((result (alien-funcall (extern-alien "gethostent"
877     (function (* (struct hostent)))))))
878     (declare (type system-area-pointer result))
879     (if (zerop (sap-int result))
880     nil
881     result)))
882 dtc 1.1
883 dtc 1.2 #+nil
884     (defun unix-gethostbyaddr(addr length type)
885     "Return entry from host data base which address match ADDR with
886     length LEN and type TYPE."
887     (let ((result (alien-funcall (extern-alien "gethostbyaddr"
888     (function (* (struct hostent))
889     c-string int int))
890     addr len type)))
891     (declare (type system-area-pointer result))
892     (if (zerop (sap-int result))
893     nil
894     result)))
895 dtc 1.1
896 dtc 1.2 #+nil
897     (defun unix-gethostbyname (name)
898     "Return entry from host data base for host with NAME."
899     (let ((result (alien-funcall (extern-alien "gethostbyname"
900     (function (* (struct hostent))
901     c-string))
902     name)))
903     (declare (type system-area-pointer result))
904     (if (zerop (sap-int result))
905     nil
906     result)))
907 dtc 1.1
908 dtc 1.2 #+nil
909     (defun unix-gethostbyname2 (name af)
910     "Return entry from host data base for host with NAME. AF must be
911     set to the address type which as `AF_INET' for IPv4 or `AF_INET6'
912     for IPv6."
913     (let ((result (alien-funcall (extern-alien "gethostbyname2"
914     (function (* (struct hostent))
915     c-string int))
916     name af)))
917     (declare (type system-area-pointer result))
918     (if (zerop (sap-int result))
919     nil
920     result)))
921 dtc 1.1
922 dtc 1.2 ;; Description of data base entry for a single network. NOTE: here a
923     ;; poor assumption is made. The network number is expected to fit
924     ;; into an unsigned long int variable.
925 dtc 1.1
926 dtc 1.2 (def-alien-type nil
927     (struct netent
928     (n-name c-string) ; Official name of network.
929     (n-aliases (* c-string)) ; Alias list.
930     (n-addrtype int) ; Net address type.
931     (n-net unsigned-long))) ; Network number.
932 dtc 1.1
933 dtc 1.2 #+nil
934     (defun unix-setnetent (stay-open)
935     "Open network data base files and mark them as staying open even
936     after a later search if STAY_OPEN is non-zero."
937     (void-syscall ("setnetent" int) stay-open))
938 dtc 1.1
939    
940 dtc 1.2 #+nil
941     (defun unix-endnetent ()
942     "Close network data base files and clear `stay open' flag."
943     (void-syscall ("endnetent")))
944 dtc 1.1
945    
946 dtc 1.2 #+nil
947     (defun unix-getnetent ()
948     "Get next entry from network data base file. Open data base if
949     necessary."
950     (let ((result (alien-funcall (extern-alien "getnetent"
951     (function (* (struct netent)))))))
952     (declare (type system-area-pointer result))
953     (if (zerop (sap-int result))
954     nil
955     result)))
956 dtc 1.1
957    
958 dtc 1.2 #+nil
959     (defun unix-getnetbyaddr (net type)
960     "Return entry from network data base which address match NET and
961     type TYPE."
962     (let ((result (alien-funcall (extern-alien "getnetbyaddr"
963     (function (* (struct netent))
964     unsigned-long int))
965     net type)))
966     (declare (type system-area-pointer result))
967     (if (zerop (sap-int result))
968     nil
969     result)))
970 dtc 1.1
971 dtc 1.2 #+nil
972     (defun unix-getnetbyname (name)
973     "Return entry from network data base for network with NAME."
974     (let ((result (alien-funcall (extern-alien "getnetbyname"
975     (function (* (struct netent))
976     c-string))
977     name)))
978     (declare (type system-area-pointer result))
979     (if (zerop (sap-int result))
980     nil
981     result)))
982 dtc 1.1
983 dtc 1.2 ;; Description of data base entry for a single service.
984     (def-alien-type nil
985     (struct servent
986     (s-name c-string) ; Official service name.
987     (s-aliases (* c-string)) ; Alias list.
988     (s-port int) ; Port number.
989     (s-proto c-string))) ; Protocol to use.
990 dtc 1.1
991 dtc 1.2 #+nil
992     (defun unix-setservent (stay-open)
993     "Open service data base files and mark them as staying open even
994     after a later search if STAY_OPEN is non-zero."
995     (void-syscall ("setservent" int) stay-open))
996 dtc 1.1
997 dtc 1.2 #+nil
998     (defun unix-endservent (stay-open)
999     "Close service data base files and clear `stay open' flag."
1000     (void-syscall ("endservent")))
1001 dtc 1.1
1002    
1003 dtc 1.2 #+nil
1004     (defun unix-getservent ()
1005     "Get next entry from service data base file. Open data base if
1006     necessary."
1007     (let ((result (alien-funcall (extern-alien "getservent"
1008     (function (* (struct servent)))))))
1009     (declare (type system-area-pointer result))
1010     (if (zerop (sap-int result))
1011     nil
1012     result)))
1013 dtc 1.1
1014 dtc 1.2 #+nil
1015     (defun unix-getservbyname (name proto)
1016     "Return entry from network data base for network with NAME and
1017     protocol PROTO."
1018     (let ((result (alien-funcall (extern-alien "getservbyname"
1019     (function (* (struct netent))
1020     c-string (* char)))
1021     name proto)))
1022     (declare (type system-area-pointer result))
1023     (if (zerop (sap-int result))
1024     nil
1025     result)))
1026 dtc 1.1
1027 dtc 1.2 #+nil
1028     (defun unix-getservbyport (port proto)
1029     "Return entry from service data base which matches port PORT and
1030     protocol PROTO."
1031     (let ((result (alien-funcall (extern-alien "getservbyport"
1032     (function (* (struct netent))
1033     int (* char)))
1034     port proto)))
1035     (declare (type system-area-pointer result))
1036     (if (zerop (sap-int result))
1037     nil
1038     result)))
1039 dtc 1.1
1040 dtc 1.2 ;; Description of data base entry for a single service.
1041 dtc 1.1
1042 dtc 1.2 (def-alien-type nil
1043     (struct protoent
1044     (p-name c-string) ; Official protocol name.
1045     (p-aliases (* c-string)) ; Alias list.
1046     (p-proto int))) ; Protocol number.
1047 dtc 1.1
1048 dtc 1.2 #+nil
1049     (defun unix-setprotoent (stay-open)
1050     "Open protocol data base files and mark them as staying open even
1051     after a later search if STAY_OPEN is non-zero."
1052     (void-syscall ("setprotoent" int) stay-open))
1053 dtc 1.1
1054 dtc 1.2 #+nil
1055     (defun unix-endprotoent ()
1056     "Close protocol data base files and clear `stay open' flag."
1057     (void-syscall ("endprotoent")))
1058 dtc 1.1
1059 dtc 1.2 #+nil
1060     (defun unix-getprotoent ()
1061     "Get next entry from protocol data base file. Open data base if
1062     necessary."
1063     (let ((result (alien-funcall (extern-alien "getprotoent"
1064     (function (* (struct protoent)))))))
1065     (declare (type system-area-pointer result))
1066     (if (zerop (sap-int result))
1067     nil
1068     result)))
1069 dtc 1.1
1070 dtc 1.2 #+nil
1071     (defun unix-getprotobyname (name)
1072     "Return entry from protocol data base for network with NAME."
1073     (let ((result (alien-funcall (extern-alien "getprotobyname"
1074     (function (* (struct protoent))
1075     c-string))
1076     name)))
1077     (declare (type system-area-pointer result))
1078     (if (zerop (sap-int result))
1079     nil
1080     result)))
1081 dtc 1.1
1082 dtc 1.2 #+nil
1083     (defun unix-getprotobynumber (proto)
1084     "Return entry from protocol data base which number is PROTO."
1085     (let ((result (alien-funcall (extern-alien "getprotobynumber"
1086     (function (* (struct protoent))
1087     int))
1088     proto)))
1089     (declare (type system-area-pointer result))
1090     (if (zerop (sap-int result))
1091     nil
1092     result)))
1093 dtc 1.1
1094 dtc 1.2 #+nil
1095     (defun unix-setnetgrent (netgroup)
1096     "Establish network group NETGROUP for enumeration."
1097     (int-syscall ("setservent" c-string) netgroup))
1098 dtc 1.1
1099 dtc 1.2 #+nil
1100     (defun unix-endnetgrent ()
1101     "Free all space allocated by previous `setnetgrent' call."
1102     (void-syscall ("endnetgrent")))
1103 dtc 1.1
1104 dtc 1.2 #+nil
1105     (defun unix-getnetgrent (hostp userp domainp)
1106     "Get next member of netgroup established by last `setnetgrent' call
1107     and return pointers to elements in HOSTP, USERP, and DOMAINP."
1108     (int-syscall ("getnetgrent" (* c-string) (* c-string) (* c-string))
1109     hostp userp domainp))
1110 dtc 1.1
1111 dtc 1.2 #+nil
1112     (defun unix-innetgr (netgroup host user domain)
1113     "Test whether NETGROUP contains the triple (HOST,USER,DOMAIN)."
1114     (int-syscall ("innetgr" c-string c-string c-string c-string)
1115     netgroup host user domain))
1116 dtc 1.1
1117 dtc 1.2 (def-alien-type nil
1118     (struct addrinfo
1119     (ai-flags int) ; Input flags.
1120     (ai-family int) ; Protocol family for socket.
1121     (ai-socktype int) ; Socket type.
1122     (ai-protocol int) ; Protocol for socket.
1123     (ai-addrlen int) ; Length of socket address.
1124     (ai-addr (* (struct sockaddr)))
1125     ; Socket address for socket.
1126     (ai-cononname c-string)
1127     ; Canonical name for service location.
1128     (ai-net (* (struct addrinfo))))) ; Pointer to next in list.
1129    
1130     ;; Possible values for `ai_flags' field in `addrinfo' structure.
1131    
1132     (defconstant ai_passive 1 "Socket address is intended for `bind'.")
1133     (defconstant ai_canonname 2 "Request for canonical name.")
1134    
1135     ;; Error values for `getaddrinfo' function.
1136     (defconstant eai_badflags -1 "Invalid value for `ai_flags' field.")
1137     (defconstant eai_noname -2 "NAME or SERVICE is unknown.")
1138     (defconstant eai_again -3 "Temporary failure in name resolution.")
1139     (defconstant eai_fail -4 "Non-recoverable failure in name res.")
1140     (defconstant eai_nodata -5 "No address associated with NAME.")
1141     (defconstant eai_family -6 "ai_family not supported.")
1142     (defconstant eai_socktype -7 "ai_socktype not supported.")
1143     (defconstant eai_service -8 "SERVICE not supported for ai_socktype.")
1144     (defconstant eai_addrfamily -9 "Address family for NAME not supported.")
1145     (defconstant eai_memory -10 "Memory allocation failure.")
1146     (defconstant eai_system -11 "System error returned in errno.")
1147 dtc 1.1
1148    
1149 dtc 1.2 #+nil
1150     (defun unix-getaddrinfo (name service req pai)
1151     "Translate name of a service location and/or a service name to set of
1152     socket addresses."
1153     (int-syscall ("getaddrinfo" c-string c-string (* (struct addrinfo))
1154     (* (* struct addrinfo)))
1155     name service req pai))
1156 dtc 1.1
1157    
1158 dtc 1.2 #+nil
1159     (defun unix-freeaddrinfo (ai)
1160     "Free `addrinfo' structure AI including associated storage."
1161     (void-syscall ("freeaddrinfo" (* struct addrinfo))
1162     ai))
1163 dtc 1.1
1164    
1165 dtc 1.2 ;;; pty.h
1166 dtc 1.1
1167 dtc 1.2 #+nil
1168     (defun unix-openpty (amaster aslave name termp winp)
1169     "Create pseudo tty master slave pair with NAME and set terminal
1170     attributes according to TERMP and WINP and return handles for both
1171     ends in AMASTER and ASLAVE."
1172     (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios))
1173     (* (struct winsize)))
1174     amaster aslave name termp winp))
1175 dtc 1.1
1176 dtc 1.2 #+nil
1177     (defun unix-forkpty (amaster name termp winp)
1178     "Create child process and establish the slave pseudo terminal as the
1179     child's controlling terminal."
1180     (int-syscall ("forkpty" (* int) c-string (* (struct termios))
1181     (* (struct winsize)))
1182     amaster name termp winp))
1183 dtc 1.1
1184 dtc 1.2 ;;; pwd.h
1185     ;; POSIX Standard: 9.2.2 User Database Access <pwd.h>
1186 dtc 1.1
1187 dtc 1.2 (def-alien-type nil
1188     (struct passwd
1189     (pw-name c-string) ; Username
1190     (pw-passwd c-string) ; Password
1191     (pw-uid uid-t) ; User ID
1192     (pw-gid gid-t) ; Group ID
1193     (pw-gecos c-string) ; Real name
1194     (pw-dir c-string) ; Home directory
1195     (pw-shell c-string))); Shell program
1196 dtc 1.1
1197 dtc 1.2 #+nil
1198     (defun unix-setpwent ()
1199     "Rewind the password-file stream."
1200     (void-syscall ("setpwent")))
1201 dtc 1.1
1202 dtc 1.2 #+nil
1203     (defun unix-endpwent ()
1204     "Close the password-file stream."
1205     (void-syscall ("endpwent")))
1206 dtc 1.1
1207 dtc 1.2 #+nil
1208     (defun unix-getpwent ()
1209     "Read an entry from the password-file stream, opening it if necessary."
1210     (let ((result (alien-funcall (extern-alien "getpwent"
1211     (function (* (struct passwd)))))))
1212     (declare (type system-area-pointer result))
1213     (if (zerop (sap-int result))
1214     nil
1215 dtc 1.7 result)))
1216 dtc 1.1
1217 dtc 1.2 ;;; resourcebits.h
1218 dtc 1.1
1219 dtc 1.2 (def-alien-type nil
1220     (struct rlimit
1221     (rlim-cur long) ; current (soft) limit
1222     (rlim-max long))); maximum value for rlim-cur
1223 dtc 1.1
1224 dtc 1.2 (defconstant rusage_self 0 "The calling process.")
1225     (defconstant rusage_children -1 "Terminated child processes.")
1226     (defconstant rusage_both -2)
1227 dtc 1.1
1228 dtc 1.2 (def-alien-type nil
1229     (struct rusage
1230     (ru-utime (struct timeval)) ; user time used
1231     (ru-stime (struct timeval)) ; system time used.
1232     (ru-maxrss long) ; Maximum resident set size (in kilobytes)
1233     (ru-ixrss long) ; integral shared memory size
1234     (ru-idrss long) ; integral unshared data "
1235     (ru-isrss long) ; integral unshared stack "
1236     (ru-minflt long) ; page reclaims
1237     (ru-majflt long) ; page faults
1238     (ru-nswap long) ; swaps
1239     (ru-inblock long) ; block input operations
1240     (ru-oublock long) ; block output operations
1241     (ru-msgsnd long) ; messages sent
1242     (ru-msgrcv long) ; messages received
1243     (ru-nsignals long) ; signals received
1244     (ru-nvcsw long) ; voluntary context switches
1245     (ru-nivcsw long))) ; involuntary "
1246 dtc 1.1
1247 dtc 1.2 ;; Priority limits.
1248 dtc 1.1
1249 dtc 1.2 (defconstant prio-min -20 "Minimum priority a process can have")
1250     (defconstant prio-max 20 "Maximum priority a process can have")
1251 dtc 1.1
1252    
1253 dtc 1.2 ;;; The type of the WHICH argument to `getpriority' and `setpriority',
1254     ;;; indicating what flavor of entity the WHO argument specifies.
1255 dtc 1.1
1256 dtc 1.2 (defconstant priority-process 0 "WHO is a process ID")
1257     (defconstant priority-pgrp 1 "WHO is a process group ID")
1258     (defconstant priority-user 2 "WHO is a user ID")
1259 dtc 1.1
1260 dtc 1.2 ;;; sched.h
1261 dtc 1.1
1262 dtc 1.2 #+nil
1263     (defun unix-sched_setparam (pid param)
1264     "Rewind the password-file stream."
1265     (int-syscall ("sched_setparam" pid-t (struct psched-param))
1266     pid param))
1267 dtc 1.1
1268 dtc 1.2 #+nil
1269     (defun unix-sched_getparam (pid param)
1270     "Rewind the password-file stream."
1271     (int-syscall ("sched_getparam" pid-t (struct psched-param))
1272     pid param))
1273 dtc 1.1
1274    
1275 dtc 1.2 #+nil
1276     (defun unix-sched_setscheduler (pid policy param)
1277     "Set scheduling algorithm and/or parameters for a process."
1278     (int-syscall ("sched_setscheduler" pid-t int (struct psched-param))
1279     pid policy param))
1280 dtc 1.1
1281 dtc 1.2 #+nil
1282     (defun unix-sched_getscheduler (pid)
1283     "Retrieve scheduling algorithm for a particular purpose."
1284     (int-syscall ("sched_getscheduler" pid-t)
1285     pid))
1286 dtc 1.1
1287 dtc 1.8 (defun unix-sched-yield ()
1288 dtc 1.2 "Retrieve scheduling algorithm for a particular purpose."
1289     (int-syscall ("sched_yield")))
1290 dtc 1.1
1291 dtc 1.2 #+nil
1292     (defun unix-sched_get_priority_max (algorithm)
1293     "Get maximum priority value for a scheduler."
1294     (int-syscall ("sched_get_priority_max" int)
1295     algorithm))
1296 dtc 1.1
1297 dtc 1.2 #+nil
1298     (defun unix-sched_get_priority_min (algorithm)
1299     "Get minimum priority value for a scheduler."
1300     (int-syscall ("sched_get_priority_min" int)
1301     algorithm))
1302 dtc 1.1
1303    
1304    
1305 dtc 1.2 #+nil
1306     (defun unix-sched_rr_get_interval (pid t)
1307     "Get the SCHED_RR interval for the named process."
1308     (int-syscall ("sched_rr_get_interval" pid-t (* (struct timespec)))
1309     pid t))
1310 dtc 1.1
1311 dtc 1.2 ;;; schedbits.h
1312 dtc 1.1
1313 dtc 1.2 (defconstant scheduler-other 0)
1314     (defconstant scheduler-fifo 1)
1315     (defconstant scheduler-rr 2)
1316 dtc 1.1
1317    
1318 dtc 1.2 ;; Data structure to describe a process' schedulability.
1319 dtc 1.1
1320 dtc 1.2 (def-alien-type nil
1321     (struct sched_param
1322     (sched-priority int)))
1323 dtc 1.1
1324 dtc 1.2 ;; Cloning flags.
1325     (defconstant csignal #x000000ff "Signal mask to be sent at exit.")
1326     (defconstant clone_vm #x00000100 "Set if VM shared between processes.")
1327     (defconstant clone_fs #x00000200 "Set if fs info shared between processes")
1328     (defconstant clone_files #x00000400 "Set if open files shared between processe")
1329     (defconstant clone_sighand #x00000800 "Set if signal handlers shared.")
1330     (defconstant clone_pid #x00001000 "Set if pid shared.")
1331 dtc 1.1
1332    
1333 dtc 1.2 ;;; shadow.h
1334 dtc 1.1
1335 dtc 1.2 ;; Structure of the password file.
1336 dtc 1.1
1337 dtc 1.2 (def-alien-type nil
1338     (struct spwd
1339     (sp-namp c-string) ; Login name.
1340     (sp-pwdp c-string) ; Encrypted password.
1341     (sp-lstchg long) ; Date of last change.
1342     (sp-min long) ; Minimum number of days between changes.
1343     (sp-max long) ; Maximum number of days between changes.
1344     (sp-warn long) ; Number of days to warn user to change the password.
1345     (sp-inact long) ; Number of days the account may be inactive.
1346     (sp-expire long) ; Number of days since 1970-01-01 until account expires.
1347     (sp-flags long))) ; Reserved.
1348 dtc 1.1
1349 dtc 1.2 #+nil
1350     (defun unix-setspent ()
1351     "Open database for reading."
1352     (void-syscall ("setspent")))
1353 dtc 1.1
1354 dtc 1.2 #+nil
1355     (defun unix-endspent ()
1356     "Close database."
1357     (void-syscall ("endspent")))
1358 dtc 1.1
1359 dtc 1.2 #+nil
1360     (defun unix-getspent ()
1361     "Get next entry from database, perhaps after opening the file."
1362     (let ((result (alien-funcall (extern-alien "getspent"
1363     (function (* (struct spwd)))))))
1364     (declare (type system-area-pointer result))
1365     (if (zerop (sap-int result))
1366     nil
1367     result)))
1368 dtc 1.1
1369 dtc 1.2 #+nil
1370     (defun unix-getspnam (name)
1371     "Get shadow entry matching NAME."
1372     (let ((result (alien-funcall (extern-alien "getspnam"
1373     (function (* (struct spwd))
1374     c-string))
1375     name)))
1376     (declare (type system-area-pointer result))
1377     (if (zerop (sap-int result))
1378     nil
1379     result)))
1380 dtc 1.1
1381 dtc 1.2 #+nil
1382     (defun unix-sgetspent (string)
1383     "Read shadow entry from STRING."
1384     (let ((result (alien-funcall (extern-alien "sgetspent"
1385     (function (* (struct spwd))
1386     c-string))
1387     string)))
1388     (declare (type system-area-pointer result))
1389     (if (zerop (sap-int result))
1390     nil
1391     result)))
1392 dtc 1.1
1393 dtc 1.2 ;;
1394 dtc 1.1
1395 dtc 1.2 #+nil
1396     (defun unix-lckpwdf ()
1397     "Protect password file against multi writers."
1398     (void-syscall ("lckpwdf")))
1399 dtc 1.1
1400    
1401 dtc 1.2 #+nil
1402     (defun unix-ulckpwdf ()
1403     "Unlock password file."
1404     (void-syscall ("ulckpwdf")))
1405 dtc 1.1
1406 dtc 1.2 ;;; statbuf.h
1407 dtc 1.1
1408 dtc 1.2 (def-alien-type nil
1409     (struct stat
1410     (st-dev dev-t)
1411 pw 1.4 #-alpha (st-pad1 unsigned-short)
1412 dtc 1.2 (st-ino ino-t)
1413     (st-mode mode-t)
1414     (st-nlink nlink-t)
1415     (st-uid uid-t)
1416     (st-gid gid-t)
1417     (st-rdev dev-t)
1418 pw 1.4 #-alpha (st-pad2 unsigned-short)
1419     #+alpha (st-pad2 unsigned-int)
1420 dtc 1.2 (st-size off-t)
1421 pw 1.4 #-alpha (st-blksize unsigned-long)
1422     #-alpha (st-blocks unsigned-long)
1423 dtc 1.2 (st-atime time-t)
1424 pw 1.4 #-alpha (unused-1 unsigned-long)
1425 dtc 1.2 (st-mtime time-t)
1426 pw 1.4 #-alpha (unused-2 unsigned-long)
1427 dtc 1.2 (st-ctime time-t)
1428 pw 1.4 #+alpha (st-blksize unsigned-int)
1429     #+alpha (st-blocks int)
1430     #+alpha (st-flags unsigned-int)
1431     #+alpha (st-gen unsigned-int)
1432     #-alpha (unused-3 unsigned-long)
1433     #-alpha (unused-4 unsigned-long)
1434     #-alpha (unused-5 unsigned-long)))
1435 dtc 1.2
1436     ;; Encoding of the file mode.
1437    
1438     (defconstant s-ifmt #o0170000 "These bits determine file type.")
1439    
1440     ;; File types.
1441    
1442     (defconstant s-ififo #o0010000 "FIFO")
1443     (defconstant s-ifchr #o0020000 "Character device")
1444     (defconstant s-ifdir #o0040000 "Directory")
1445     (defconstant s-ifblk #o0060000 "Block device")
1446     (defconstant s-ifreg #o0100000 "Regular file")
1447    
1448     ;; These don't actually exist on System V, but having them doesn't hurt.
1449    
1450     (defconstant s-iflnk #o0120000 "Symbolic link.")
1451     (defconstant s-ifsock #o0140000 "Socket.")
1452    
1453     ;; Protection bits.
1454 dtc 1.1
1455 dtc 1.2 (defconstant s-isuid #o0004000 "Set user ID on execution.")
1456     (defconstant s-isgid #o0002000 "Set group ID on execution.")
1457     (defconstant s-isvtx #o0001000 "Save swapped text after use (sticky).")
1458     (defconstant s-iread #o0000400 "Read by owner")
1459     (defconstant s-iwrite #o0000200 "Write by owner.")
1460     (defconstant s-iexec #o0000100 "Execute by owner.")
1461 dtc 1.1
1462 dtc 1.2 ;;; statfsbuf.h
1463 dtc 1.1
1464 dtc 1.2 (def-alien-type nil
1465     (struct statfs
1466     (f-type int)
1467     (f-bsize int)
1468     (f-blocks int)
1469     (f-bfree int)
1470 pw 1.4 (f-bavail int)
1471 dtc 1.2 (f-files int)
1472     (f-ffree int)
1473     (f-fsid fsid-t)
1474     (f-namelen int)
1475     (f-spare (array int 6))))
1476    
1477    
1478     ;;; termbits.h
1479    
1480     (def-alien-type cc-t unsigned-char)
1481     (def-alien-type speed-t unsigned-int)
1482     (def-alien-type tcflag-t unsigned-int)
1483 dtc 1.1
1484 dtc 1.2 (defconstant +NCCS+ 32
1485     "Size of control character vector.")
1486 dtc 1.1
1487 dtc 1.2 (def-alien-type nil
1488     (struct termios
1489     (c-iflag tcflag-t)
1490     (c-oflag tcflag-t)
1491     (c-cflag tcflag-t)
1492     (c-lflag tcflag-t)
1493     (c-line cc-t)
1494     (c-cc (array cc-t #.+NCCS+))
1495     (c-ispeed speed-t)
1496     (c-ospeed speed-t)))
1497    
1498     ;; c_cc characters
1499    
1500     (def-enum + 0 vintr vquit verase
1501     vkill veof vtime
1502     vmin vswtc vstart
1503     vstop vsusp veol
1504     vreprint vdiscard vwerase
1505     vlnext veol2)
1506     (defvar vdsusp vsusp)
1507 dtc 1.1
1508 dtc 1.2 (def-enum + 0 tciflush tcoflush tcioflush)
1509 dtc 1.1
1510 dtc 1.2 (def-enum + 0 tcsanow tcsadrain tcsaflush)
1511 dtc 1.1
1512 dtc 1.2 ;; c_iflag bits
1513     (def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck
1514     tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc
1515     tty-ixon tty-ixany tty-ixoff
1516     tty-imaxbel)
1517 dtc 1.1
1518 dtc 1.2 ;; c_oflag bits
1519     (def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr
1520     tty-onlret tty-ofill tty-ofdel tty-nldly)
1521 dtc 1.1
1522 dtc 1.2 (defconstant tty-nl0 0)
1523     (defconstant tty-nl1 #o400)
1524 dtc 1.1
1525 dtc 1.2 (defconstant tty-crdly #o0003000)
1526     (defconstant tty-cr0 #o0000000)
1527     (defconstant tty-cr1 #o0001000)
1528     (defconstant tty-cr2 #o0002000)
1529     (defconstant tty-cr3 #o0003000)
1530     (defconstant tty-tabdly #o0014000)
1531     (defconstant tty-tab0 #o0000000)
1532     (defconstant tty-tab1 #o0004000)
1533     (defconstant tty-tab2 #o0010000)
1534     (defconstant tty-tab3 #o0014000)
1535     (defconstant tty-xtabs #o0014000)
1536     (defconstant tty-bsdly #o0020000)
1537     (defconstant tty-bs0 #o0000000)
1538     (defconstant tty-bs1 #o0020000)
1539     (defconstant tty-vtdly #o0040000)
1540     (defconstant tty-vt0 #o0000000)
1541     (defconstant tty-vt1 #o0040000)
1542     (defconstant tty-ffdly #o0100000)
1543     (defconstant tty-ff0 #o0000000)
1544     (defconstant tty-ff1 #o0100000)
1545    
1546     ;; c-cflag bit meaning
1547     (defconstant tty-cbaud #o0010017)
1548     (defconstant tty-b0 #o0000000) ;; hang up
1549     (defconstant tty-b50 #o0000001)
1550     (defconstant tty-b75 #o0000002)
1551     (defconstant tty-b110 #o0000003)
1552     (defconstant tty-b134 #o0000004)
1553     (defconstant tty-b150 #o0000005)
1554     (defconstant tty-b200 #o0000006)
1555     (defconstant tty-b300 #o0000007)
1556     (defconstant tty-b600 #o0000010)
1557     (defconstant tty-b1200 #o0000011)
1558     (defconstant tty-b1800 #o0000012)
1559     (defconstant tty-b2400 #o0000013)
1560     (defconstant tty-b4800 #o0000014)
1561     (defconstant tty-b9600 #o0000015)
1562     (defconstant tty-b19200 #o0000016)
1563     (defconstant tty-b38400 #o0000017)
1564     (defconstant tty-exta tty-b19200)
1565     (defconstant tty-extb tty-b38400)
1566     (defconstant tty-csize #o0000060)
1567     (defconstant tty-cs5 #o0000000)
1568     (defconstant tty-cs6 #o0000020)
1569     (defconstant tty-cs7 #o0000040)
1570     (defconstant tty-cs8 #o0000060)
1571     (defconstant tty-cstopb #o0000100)
1572     (defconstant tty-cread #o0000200)
1573     (defconstant tty-parenb #o0000400)
1574     (defconstant tty-parodd #o0001000)
1575     (defconstant tty-hupcl #o0002000)
1576     (defconstant tty-clocal #o0004000)
1577     (defconstant tty-cbaudex #o0010000)
1578     (defconstant tty-b57600 #o0010001)
1579     (defconstant tty-b115200 #o0010002)
1580     (defconstant tty-b230400 #o0010003)
1581     (defconstant tty-b460800 #o0010004)
1582     (defconstant tty-cibaud #o002003600000) ; input baud rate (not used)
1583     (defconstant tty-crtscts #o020000000000) ;flow control
1584 dtc 1.1
1585 dtc 1.2 ;; c_lflag bits
1586     (def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe
1587     tty-echok tty-echonl tty-noflsh
1588     tty-tostop tty-echoctl tty-echoprt
1589     tty-echoke tty-flusho
1590     tty-pendin tty-iexten)
1591 dtc 1.1
1592 dtc 1.2 ;;; tcflow() and TCXONC use these
1593     (def-enum + 0 tty-tcooff tty-tcoon tty-tcioff tty-tcion)
1594 dtc 1.1
1595 dtc 1.2 ;; tcflush() and TCFLSH use these */
1596     (def-enum + 0 tty-tciflush tty-tcoflush tty-tcioflush)
1597 dtc 1.1
1598 dtc 1.2 ;; tcsetattr uses these
1599     (def-enum + 0 tty-tcsanow tty-tcsadrain tty-tcsaflush)
1600 dtc 1.1
1601 dtc 1.2 ;;; termios.h
1602 dtc 1.1
1603 dtc 1.2 (defun unix-cfgetospeed (termios)
1604     "Get terminal output speed."
1605     (multiple-value-bind (speed errno)
1606     (int-syscall ("cfgetospeed" (* (struct termios))) termios)
1607     (if speed
1608     (values (svref terminal-speeds speed) 0)
1609     (values speed errno))))
1610 dtc 1.1
1611 dtc 1.2 (defun unix-cfsetospeed (termios speed)
1612     "Set terminal output speed."
1613     (let ((baud (or (position speed terminal-speeds)
1614     (error "Bogus baud rate ~S" speed))))
1615     (void-syscall ("cfsetospeed" (* (struct termios)) int) termios baud)))
1616 dtc 1.1
1617 dtc 1.2 (defun unix-cfgetispeed (termios)
1618     "Get terminal input speed."
1619     (multiple-value-bind (speed errno)
1620     (int-syscall ("cfgetispeed" (* (struct termios))) termios)
1621     (if speed
1622     (values (svref terminal-speeds speed) 0)
1623     (values speed errno))))
1624 dtc 1.1
1625 dtc 1.2 (defun unix-cfsetispeed (termios speed)
1626     "Set terminal input speed."
1627     (let ((baud (or (position speed terminal-speeds)
1628     (error "Bogus baud rate ~S" speed))))
1629     (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud)))
1630 dtc 1.1
1631 dtc 1.2 (defun unix-tcgetattr (fd termios)
1632     "Get terminal attributes."
1633     (declare (type unix-fd fd))
1634     (void-syscall ("tcgetattr" int (* (struct termios))) fd termios))
1635 dtc 1.1
1636 dtc 1.2 (defun unix-tcsetattr (fd opt termios)
1637     "Set terminal attributes."
1638     (declare (type unix-fd fd))
1639     (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios))
1640 dtc 1.1
1641 dtc 1.2 (defun unix-tcsendbreak (fd duration)
1642     "Send break"
1643     (declare (type unix-fd fd))
1644     (void-syscall ("tcsendbreak" int int) fd duration))
1645 dtc 1.1
1646 dtc 1.2 (defun unix-tcdrain (fd)
1647     "Wait for output for finish"
1648     (declare (type unix-fd fd))
1649     (void-syscall ("tcdrain" int) fd))
1650 dtc 1.1
1651 dtc 1.2 (defun unix-tcflush (fd selector)
1652     "See tcflush(3)"
1653     (declare (type unix-fd fd))
1654     (void-syscall ("tcflush" int int) fd selector))
1655 dtc 1.1
1656 dtc 1.2 (defun unix-tcflow (fd action)
1657     "Flow control"
1658     (declare (type unix-fd fd))
1659     (void-syscall ("tcflow" int int) fd action))
1660 dtc 1.1
1661 dtc 1.2 ;;; timebits.h
1662 dtc 1.1
1663 dtc 1.2 ;; A time value that is accurate to the nearest
1664     ;; microsecond but also has a range of years.
1665     (def-alien-type nil
1666     (struct timeval
1667 pw 1.4 (tv-sec #-alpha time-t #+alpha int) ; seconds
1668     (tv-usec #-alpha time-t #+alpha int))) ; and microseconds
1669 dtc 1.1
1670 dtc 1.2 ;;; unistd.h
1671 dtc 1.1
1672 dtc 1.2 (defun sub-unix-execve (program arg-list env-list)
1673     (let ((argv nil)
1674     (argv-bytes 0)
1675     (envp nil)
1676     (envp-bytes 0)
1677     result error-code)
1678     (unwind-protect
1679     (progn
1680     ;; Blast the stuff into the proper format
1681     (multiple-value-setq
1682     (argv argv-bytes)
1683     (string-list-to-c-strvec arg-list))
1684     (multiple-value-setq
1685     (envp envp-bytes)
1686     (string-list-to-c-strvec env-list))
1687     ;;
1688     ;; Now do the system call
1689     (multiple-value-setq
1690     (result error-code)
1691     (int-syscall ("execve"
1692     (* char) system-area-pointer system-area-pointer)
1693     (vector-sap program) argv envp)))
1694     ;;
1695     ;; Deallocate memory
1696     (when argv
1697     (system:deallocate-system-memory argv argv-bytes))
1698     (when envp
1699     (system:deallocate-system-memory envp envp-bytes)))
1700     (values result error-code)))
1701 dtc 1.1
1702 dtc 1.2 ;;;; UNIX-EXECVE
1703 dtc 1.1
1704 dtc 1.2 (defun unix-execve (program &optional arg-list
1705     (environment *environment-list*))
1706     "Executes the Unix execve system call. If the system call suceeds, lisp
1707 dtc 1.1 will no longer be running in this process. If the system call fails this
1708     function returns two values: NIL and an error code. Arg-list should be a
1709     list of simple-strings which are passed as arguments to the exec'ed program.
1710     Environment should be an a-list mapping symbols to simple-strings which this
1711     function bashes together to form the environment for the exec'ed program."
1712     (check-type program simple-string)
1713     (let ((env-list (let ((envlist nil))
1714     (dolist (cons environment)
1715     (push (if (cdr cons)
1716     (concatenate 'simple-string
1717     (string (car cons)) "="
1718     (cdr cons))
1719     (car cons))
1720     envlist))
1721     envlist)))
1722     (sub-unix-execve program arg-list env-list)))
1723    
1724    
1725     (defmacro round-bytes-to-words (n)
1726     `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
1727    
1728 dtc 1.2 ;; Values for the second argument to access.
1729 dtc 1.1
1730 dtc 1.2 ;;; Unix-access accepts a path and a mode. It returns two values the
1731     ;;; first is T if the file is accessible and NIL otherwise. The second
1732     ;;; only has meaning in the second case and is the unix errno value.
1733 dtc 1.1
1734 dtc 1.2 (defun unix-access (path mode)
1735     "Given a file path (a string) and one of four constant modes,
1736     unix-access returns T if the file is accessible with that
1737     mode and NIL if not. It also returns an errno value with
1738     NIL which determines why the file was not accessible.
1739 dtc 1.1
1740 dtc 1.2 The access modes are:
1741     r_ok Read permission.
1742     w_ok Write permission.
1743     x_ok Execute permission.
1744     f_ok Presence of file."
1745     (declare (type unix-pathname path)
1746     (type (mod 8) mode))
1747     (void-syscall ("access" c-string int) path mode))
1748    
1749     (defconstant l_set 0 "set the file pointer")
1750     (defconstant l_incr 1 "increment the file pointer")
1751     (defconstant l_xtnd 2 "extend the file size")
1752    
1753     (defun unix-lseek (fd offset whence)
1754     "Unix-lseek accepts a file descriptor and moves the file pointer ahead
1755     a certain offset for that file. Whence can be any of the following:
1756    
1757     l_set Set the file pointer.
1758     l_incr Increment the file pointer.
1759     l_xtnd Extend the file size.
1760     "
1761     (declare (type unix-fd fd)
1762     (type (unsigned-byte 32) offset)
1763     (type (integer 0 2) whence))
1764     (int-syscall ("lseek" int off-t int) fd offset whence))
1765 dtc 1.1
1766    
1767 dtc 1.2 ;;; Unix-read accepts a file descriptor, a buffer, and the length to read.
1768     ;;; It attempts to read len bytes from the device associated with fd
1769     ;;; and store them into the buffer. It returns the actual number of
1770     ;;; bytes read.
1771 dtc 1.1
1772 dtc 1.2 (defun unix-read (fd buf len)
1773     "Unix-read attempts to read from the file described by fd into
1774     the buffer buf until it is full. Len is the length of the buffer.
1775     The number of bytes actually read is returned or NIL and an error
1776     number if an error occured."
1777     (declare (type unix-fd fd)
1778     (type (unsigned-byte 32) len))
1779 dtc 1.1
1780 dtc 1.2 (int-syscall ("read" int (* char) int) fd buf len))
1781 dtc 1.1
1782    
1783 dtc 1.2 ;;; Unix-write accepts a file descriptor, a buffer, an offset, and the
1784     ;;; length to write. It attempts to write len bytes to the device
1785     ;;; associated with fd from the the buffer starting at offset. It returns
1786     ;;; the actual number of bytes written.
1787 dtc 1.1
1788 dtc 1.2 (defun unix-write (fd buf offset len)
1789     "Unix-write attempts to write a character buffer (buf) of length
1790     len to the file described by the file descriptor fd. NIL and an
1791     error is returned if the call is unsuccessful."
1792     (declare (type unix-fd fd)
1793     (type (unsigned-byte 32) offset len))
1794     (int-syscall ("write" int (* char) int)
1795     fd
1796     (with-alien ((ptr (* char) (etypecase buf
1797     ((simple-array * (*))
1798     (vector-sap buf))
1799     (system-area-pointer
1800     buf))))
1801     (addr (deref ptr offset)))
1802     len))
1803 dtc 1.1
1804 dtc 1.2 (defun unix-pipe ()
1805     "Unix-pipe sets up a unix-piping mechanism consisting of
1806     an input pipe and an output pipe. Unix-Pipe returns two
1807     values: if no error occurred the first value is the pipe
1808     to be read from and the second is can be written to. If
1809     an error occurred the first value is NIL and the second
1810     the unix error code."
1811     (with-alien ((fds (array int 2)))
1812     (syscall ("pipe" (* int))
1813     (values (deref fds 0) (deref fds 1))
1814     (cast fds (* int)))))
1815 dtc 1.1
1816    
1817 dtc 1.2 (defun unix-chown (path uid gid)
1818     "Given a file path, an integer user-id, and an integer group-id,
1819     unix-chown changes the owner of the file and the group of the
1820     file to those specified. Either the owner or the group may be
1821     left unchanged by specifying them as -1. Note: Permission will
1822     fail if the caller is not the superuser."
1823     (declare (type unix-pathname path)
1824     (type (or unix-uid (integer -1 -1)) uid)
1825     (type (or unix-gid (integer -1 -1)) gid))
1826     (void-syscall ("chown" c-string int int) path uid gid))
1827 dtc 1.1
1828 dtc 1.2 ;;; Unix-fchown is exactly the same as unix-chown except that the file
1829     ;;; is specified by a file-descriptor ("fd") instead of a pathname.
1830 dtc 1.1
1831 dtc 1.2 (defun unix-fchown (fd uid gid)
1832     "Unix-fchown is like unix-chown, except that it accepts an integer
1833     file descriptor instead of a file path name."
1834     (declare (type unix-fd fd)
1835     (type (or unix-uid (integer -1 -1)) uid)
1836     (type (or unix-gid (integer -1 -1)) gid))
1837     (void-syscall ("fchown" int int int) fd uid gid))
1838 dtc 1.1
1839 dtc 1.2 ;;; Unix-chdir accepts a directory name and makes that the
1840     ;;; current working directory.
1841 dtc 1.1
1842 dtc 1.2 (defun unix-chdir (path)
1843     "Given a file path string, unix-chdir changes the current working
1844     directory to the one specified."
1845     (declare (type unix-pathname path))
1846     (void-syscall ("chdir" c-string) path))
1847 dtc 1.1
1848 dtc 1.2 (defun unix-current-directory ()
1849     "Put the absolute pathname of the current working directory in BUF.
1850     If successful, return BUF. If not, put an error message in
1851     BUF and return NULL. BUF should be at least PATH_MAX bytes long."
1852     (with-alien ((buf (array char 1024)))
1853     (values (not (zerop (alien-funcall (extern-alien "getwd"
1854     (function int (* char)))
1855     (cast buf (* char)))))
1856     (cast buf c-string))))
1857 dtc 1.1
1858    
1859 dtc 1.2 ;;; Unix-dup returns a duplicate copy of the existing file-descriptor
1860     ;;; passed as an argument.
1861 dtc 1.1
1862 dtc 1.2 (defun unix-dup (fd)
1863     "Unix-dup duplicates an existing file descriptor (given as the
1864     argument) and return it. If FD is not a valid file descriptor, NIL
1865     and an error number are returned."
1866     (declare (type unix-fd fd))
1867     (int-syscall ("dup" int) fd))
1868 dtc 1.1
1869 dtc 1.2 ;;; Unix-dup2 makes the second file-descriptor describe the same file
1870     ;;; as the first. If the second file-descriptor points to an open
1871     ;;; file, it is first closed. In any case, the second should have a
1872     ;;; value which is a valid file-descriptor.
1873 dtc 1.1
1874 dtc 1.2 (defun unix-dup2 (fd1 fd2)
1875     "Unix-dup2 duplicates an existing file descriptor just as unix-dup
1876     does only the new value of the duplicate descriptor may be requested
1877     through the second argument. If a file already exists with the
1878     requested descriptor number, it will be closed and the number
1879     assigned to the duplicate."
1880     (declare (type unix-fd fd1 fd2))
1881     (void-syscall ("dup2" int int) fd1 fd2))
1882 dtc 1.1
1883 dtc 1.2 ;;; Unix-exit terminates a program.
1884 dtc 1.1
1885 dtc 1.2 (defun unix-exit (&optional (code 0))
1886     "Unix-exit terminates the current process with an optional
1887     error code. If successful, the call doesn't return. If
1888     unsuccessful, the call returns NIL and an error number."
1889     (declare (type (signed-byte 32) code))
1890     (void-syscall ("exit" int) code))
1891 dtc 1.1
1892     #+nil
1893 dtc 1.2 (defun unix-pathconf (path name)
1894     "Get file-specific configuration information about PATH."
1895     (int-syscall ("pathconf" c-string int) path name))
1896 dtc 1.1
1897 dtc 1.2 #+nil
1898     (defun unix-sysconf (name)
1899     "Get the value of the system variable NAME."
1900     (int-syscall ("sysconf" c-string) name))
1901 dtc 1.1
1902     #+nil
1903 dtc 1.2 (defun unix-confstr (name)
1904     "Get the value of the string-valued system variable NAME."
1905     (with-alien ((buf (array char 1024)))
1906     (values (not (zerop (alien-funcall (extern-alien "confstr"
1907     (function int
1908     c-string
1909     size-t))
1910     name buf 1024)))
1911     (cast buf c-string))))
1912    
1913    
1914     (def-alien-routine ("getpid" unix-getpid) int
1915     "Unix-getpid returns the process-id of the current process.")
1916    
1917     (def-alien-routine ("getppid" unix-getppid) int
1918     "Unix-getppid returns the process-id of the parent of the current process.")
1919    
1920     ;;; Unix-getpgrp returns the group-id associated with the
1921 dtc 1.6 ;;; current process.
1922 dtc 1.1
1923 dtc 1.6 (defun unix-getpgrp ()
1924     "Unix-getpgrp returns the group-id of the calling process."
1925     (int-syscall ("getpgrp")))
1926    
1927     ;;; Unix-setpgid sets the group-id of the process specified by
1928 dtc 1.2 ;;; "pid" to the value of "pgrp". The process must either have
1929     ;;; the same effective user-id or be a super-user process.
1930 dtc 1.1
1931 dtc 1.6 ;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained
1932     ;;; for backward compatibility. setpgrp(void)[solaris] is being phased
1933     ;;; out in favor of setsid().
1934    
1935 dtc 1.2 (defun unix-setpgrp (pid pgrp)
1936     "Unix-setpgrp sets the process group on the process pid to
1937 dtc 1.6 pgrp. NIL and an error number are returned upon failure."
1938     (void-syscall ("setpgid" int int) pid pgrp))
1939    
1940     (defun unix-setpgid (pid pgrp)
1941     "Unix-setpgid sets the process group of the process pid to
1942     pgrp. If pgid is equal to pid, the process becomes a process
1943     group leader. NIL and an error number are returned upon failure."
1944     (void-syscall ("setpgid" int int) pid pgrp))
1945 dtc 1.1
1946     #+nil
1947 dtc 1.2 (defun unix-setsid ()
1948     "Create a new session with the calling process as its leader.
1949     The process group IDs of the session and the calling process
1950     are set to the process ID of the calling process, which is returned."
1951     (void-syscall ( "setsid")))
1952 dtc 1.1
1953     #+nil
1954 dtc 1.2 (defun unix-getsid ()
1955     "Return the session ID of the given process."
1956     (int-syscall ( "getsid")))
1957    
1958     (def-alien-routine ("getuid" unix-getuid) int
1959     "Unix-getuid returns the real user-id associated with the
1960     current process.")
1961 dtc 1.1
1962     #+nil
1963 dtc 1.2 (def-alien-routine ("geteuid" unix-getuid) int
1964     "Get the effective user ID of the calling process.")
1965    
1966     (def-alien-routine ("getgid" unix-getgid) int
1967     "Unix-getgid returns the real group-id of the current process.")
1968    
1969     (def-alien-routine ("getegid" unix-getegid) int
1970     "Unix-getegid returns the effective group-id of the current process.")
1971    
1972     ;/* If SIZE is zero, return the number of supplementary groups
1973     ; the calling process is in. Otherwise, fill in the group IDs
1974     ; of its supplementary groups in LIST and return the number written. */
1975     ;extern int getgroups __P ((int __size, __gid_t __list[]));
1976 dtc 1.1
1977     #+nil
1978 dtc 1.2 (defun unix-group-member (gid)
1979     "Return nonzero iff the calling process is in group GID."
1980     (int-syscall ( "group-member" gid-t) gid))
1981    
1982 dtc 1.1
1983     #+nil
1984 dtc 1.2 (defun unix-setuid (uid)
1985     "Set the user ID of the calling process to UID.
1986     If the calling process is the super-user, set the real
1987     and effective user IDs, and the saved set-user-ID to UID;
1988     if not, the effective user ID is set to UID."
1989     (int-syscall ( "setuid" uid-t) uid))
1990    
1991     ;;; Unix-setreuid sets the real and effective user-id's of the current
1992     ;;; process to the arguments "ruid" and "euid", respectively. Usage is
1993     ;;; restricted for anyone but the super-user. Setting either "ruid" or
1994     ;;; "euid" to -1 makes the system use the current id instead.
1995    
1996     (defun unix-setreuid (ruid euid)
1997     "Unix-setreuid sets the real and effective user-id's of the current
1998     process to the specified ones. NIL and an error number is returned
1999     if the call fails."
2000     (void-syscall ("setreuid" int int) ruid euid))
2001 dtc 1.1
2002     #+nil
2003 dtc 1.2 (defun unix-setgid (gid)
2004     "Set the group ID of the calling process to GID.
2005     If the calling process is the super-user, set the real
2006     and effective group IDs, and the saved set-group-ID to GID;
2007     if not, the effective group ID is set to GID."
2008     (int-syscall ( "setgid" gid-t) gid))
2009    
2010    
2011     ;;; Unix-setregid sets the real and effective group-id's of the current
2012     ;;; process to the arguments "rgid" and "egid", respectively. Usage is
2013     ;;; restricted for anyone but the super-user. Setting either "rgid" or
2014     ;;; "egid" to -1 makes the system use the current id instead.
2015    
2016     (defun unix-setregid (rgid egid)
2017     "Unix-setregid sets the real and effective group-id's of the current
2018     process process to the specified ones. NIL and an error number is
2019     returned if the call fails."
2020     (void-syscall ("setregid" int int) rgid egid))
2021    
2022     (defun unix-fork ()
2023     "Executes the unix fork system call. Returns 0 in the child and the pid
2024     of the child in the parent if it works, or NIL and an error number if it
2025     doesn't work."
2026     (int-syscall ("fork")))
2027    
2028     (def-alien-routine ("ttyname" unix-ttyname) c-string
2029     (fd int))
2030    
2031     (def-alien-routine ("isatty" unix-isatty) boolean
2032     "Accepts a Unix file descriptor and returns T if the device
2033     associated with it is a terminal."
2034     (fd int))
2035    
2036     ;;; Unix-link creates a hard link from name2 to name1.
2037    
2038     (defun unix-link (name1 name2)
2039     "Unix-link creates a hard link from the file with name1 to the
2040     file with name2."
2041     (declare (type unix-pathname name1 name2))
2042     (void-syscall ("link" c-string c-string) name1 name2))
2043    
2044     (defun unix-symlink (name1 name2)
2045     "Unix-symlink creates a symbolic link named name2 to the file
2046     named name1. NIL and an error number is returned if the call
2047     is unsuccessful."
2048     (declare (type unix-pathname name1 name2))
2049     (void-syscall ("symlink" c-string c-string) name1 name2))
2050    
2051     (defun unix-readlink (path)
2052     "Unix-readlink invokes the readlink system call on the file name
2053     specified by the simple string path. It returns up to two values:
2054     the contents of the symbolic link if the call is successful, or
2055     NIL and the Unix error number."
2056     (declare (type unix-pathname path))
2057     (with-alien ((buf (array char 1024)))
2058     (syscall ("readlink" c-string (* char) int)
2059     (let ((string (make-string result)))
2060     (kernel:copy-from-system-area
2061     (alien-sap buf) 0
2062     string (* vm:vector-data-offset vm:word-bits)
2063     (* result vm:byte-bits))
2064     string)
2065     path (cast buf (* char)) 1024)))
2066    
2067     ;;; Unix-unlink accepts a name and deletes the directory entry for that
2068     ;;; name and the file if this is the last link.
2069    
2070     (defun unix-unlink (name)
2071     "Unix-unlink removes the directory entry for the named file.
2072     NIL and an error code is returned if the call fails."
2073     (declare (type unix-pathname name))
2074     (void-syscall ("unlink" c-string) name))
2075    
2076     ;;; Unix-rmdir accepts a name and removes the associated directory.
2077    
2078     (defun unix-rmdir (name)
2079     "Unix-rmdir attempts to remove the directory name. NIL and
2080     an error number is returned if an error occured."
2081     (declare (type unix-pathname name))
2082     (void-syscall ("rmdir" c-string) name))
2083    
2084     (defun tcgetpgrp (fd)
2085     "Get the tty-process-group for the unix file-descriptor FD."
2086     (alien:with-alien ((alien-pgrp c-call:int))
2087     (multiple-value-bind (ok err)
2088     (unix-ioctl fd
2089     tiocgpgrp
2090     (alien:alien-sap (alien:addr alien-pgrp)))
2091     (if ok
2092     (values alien-pgrp nil)
2093     (values nil err)))))
2094    
2095     (defun tty-process-group (&optional fd)
2096     "Get the tty-process-group for the unix file-descriptor FD. If not supplied,
2097     FD defaults to /dev/tty."
2098     (if fd
2099     (tcgetpgrp fd)
2100     (multiple-value-bind (tty-fd errno)
2101     (unix-open "/dev/tty" o_rdwr 0)
2102     (cond (tty-fd
2103     (multiple-value-prog1
2104     (tcgetpgrp tty-fd)
2105     (unix-close tty-fd)))
2106     (t
2107     (values nil errno))))))
2108    
2109     (defun tcsetpgrp (fd pgrp)
2110     "Set the tty-process-group for the unix file-descriptor FD to PGRP."
2111     (alien:with-alien ((alien-pgrp c-call:int pgrp))
2112     (unix-ioctl fd
2113     tiocspgrp
2114     (alien:alien-sap (alien:addr alien-pgrp)))))
2115    
2116     (defun %set-tty-process-group (pgrp &optional fd)
2117     "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
2118     supplied, FD defaults to /dev/tty."
2119     (let ((old-sigs
2120     (unix-sigblock
2121     (sigmask :sigttou :sigttin :sigtstp :sigchld))))
2122     (declare (type (unsigned-byte 32) old-sigs))
2123     (unwind-protect
2124     (if fd
2125     (tcsetpgrp fd pgrp)
2126     (multiple-value-bind (tty-fd errno)
2127     (unix-open "/dev/tty" o_rdwr 0)
2128     (cond (tty-fd
2129     (multiple-value-prog1
2130     (tcsetpgrp tty-fd pgrp)
2131     (unix-close tty-fd)))
2132     (t
2133     (values nil errno)))))
2134     (unix-sigsetmask old-sigs))))
2135    
2136     (defsetf tty-process-group (&optional fd) (pgrp)
2137     "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
2138     supplied, FD defaults to /dev/tty."
2139     `(%set-tty-process-group ,pgrp ,fd))
2140 dtc 1.1
2141     #+nil
2142 dtc 1.2 (defun unix-getlogin ()
2143     "Return the login name of the user."
2144     (let ((result (alien-funcall (extern-alien "getlogin"
2145     (function c-string)))))
2146     (declare (type system-area-pointer result))
2147     (if (zerop (sap-int result))
2148     nil
2149     result)))
2150    
2151     (defun unix-gethostname ()
2152     "Unix-gethostname returns the name of the host machine as a string."
2153     (with-alien ((buf (array char 256)))
2154     (syscall ("gethostname" (* char) int)
2155     (cast buf c-string)
2156     (cast buf (* char)) 256)))
2157 dtc 1.1
2158     #+nil
2159 dtc 1.2 (defun unix-sethostname (name len)
2160     (int-syscall ("sethostname" c-string size-t) name len))
2161 dtc 1.1
2162     #+nil
2163 dtc 1.2 (defun unix-sethostid (id)
2164     (int-syscall ("sethostid" long) id))
2165 dtc 1.1
2166     #+nil
2167 dtc 1.2 (defun unix-getdomainname (name len)
2168     (int-syscall ("getdomainname" c-string size-t) name len))
2169 dtc 1.1
2170     #+nil
2171 dtc 1.2 (defun unix-setdomainname (name len)
2172     (int-syscall ("setdomainname" c-string size-t) name len))
2173    
2174     ;;; Unix-fsync writes the core-image of the file described by "fd" to
2175     ;;; permanent storage (i.e. disk).
2176    
2177     (defun unix-fsync (fd)
2178     "Unix-fsync writes the core image of the file described by
2179     fd to disk."
2180     (declare (type unix-fd fd))
2181     (void-syscall ("fsync" int) fd))
2182    
2183 dtc 1.1
2184     #+nil
2185 dtc 1.2 (defun unix-vhangup ()
2186     "Revoke access permissions to all processes currently communicating
2187     with the control terminal, and then send a SIGHUP signal to the process
2188     group of the control terminal."
2189     (int-syscall ("vhangup")))
2190 dtc 1.1
2191     #+nil
2192 dtc 1.2 (defun unix-revoke (file)
2193     "Revoke the access of all descriptors currently open on FILE."
2194     (int-syscall ("revoke" c-string) file))
2195    
2196    
2197     #+nil
2198     (defun unix-chroot (path)
2199     "Make PATH be the root directory (the starting point for absolute paths).
2200     This call is restricted to the super-user."
2201     (int-syscall ("chroot" c-string) path))
2202    
2203     (def-alien-routine ("gethostid" unix-gethostid) unsigned-long
2204     "Unix-gethostid returns a 32-bit integer which provides unique
2205     identification for the host machine.")
2206    
2207     ;;; Unix-sync writes all information in core memory which has been modified
2208     ;;; to permanent storage (i.e. disk).
2209    
2210     (defun unix-sync ()
2211     "Unix-sync writes all information in core memory which has been
2212     modified to disk. It returns NIL and an error code if an error
2213     occured."
2214     (void-syscall ("sync")))
2215    
2216     ;;; Unix-getpagesize returns the number of bytes in the system page.
2217    
2218     (defun unix-getpagesize ()
2219     "Unix-getpagesize returns the number of bytes in a system page."
2220     (int-syscall ("getpagesize")))
2221    
2222     ;;; Unix-truncate accepts a file name and a new length. The file is
2223     ;;; truncated to the new length.
2224    
2225     (defun unix-truncate (name len)
2226     "Unix-truncate truncates the named file to the length (in
2227     bytes) specified by len. NIL and an error number is returned
2228     if the call is unsuccessful."
2229     (declare (type unix-pathname name)
2230     (type (unsigned-byte 32) len))
2231     (void-syscall ("truncate" c-string off-t) name len))
2232    
2233     (defun unix-ftruncate (fd len)
2234     "Unix-ftruncate is similar to unix-truncate except that the first
2235     argument is a file descriptor rather than a file name."
2236     (declare (type unix-fd fd)
2237     (type (unsigned-byte 32) len))
2238     (void-syscall ("ftruncate" int off-t) fd len))
2239    
2240     #+nil
2241     (defun unix-getdtablesize ()
2242     "Return the maximum number of file descriptors
2243     the current process could possibly have."
2244     (int-syscall ("getdtablesize")))
2245    
2246     (defconstant f_ulock 0 "Unlock a locked region")
2247     (defconstant f_lock 1 "Lock a region for exclusive use")
2248     (defconstant f_tlock 2 "Test and lock a region for exclusive use")
2249     (defconstant f_test 3 "Test a region for othwer processes locks")
2250    
2251     #+nil
2252     (defun unix-lockf (fd cmd length)
2253     "Unix-locks can lock, unlock and test files according to the cmd
2254     which can be one of the following:
2255    
2256     f_ulock Unlock a locked region
2257     f_lock Lock a region for exclusive use
2258     f_tlock Test and lock a region for exclusive use
2259     f_test Test a region for othwer processes locks
2260    
2261     The lock is for a region from the current location for a length
2262     of length.
2263    
2264     This is a simpler version of the interface provided by unix-fcntl.
2265     "
2266     (declare (type unix-fd fd)
2267     (type (unsigned-byte 32) length)
2268     (type (integer 0 3) cmd))
2269     (int-syscall ("lockf" int int off-t) fd cmd length))
2270    
2271     ;;; ustatbits.h
2272    
2273     (def-alien-type nil
2274     (struct ustat
2275     (f-tfree daddr-t)
2276     (f-tinone ino-t)
2277     (f-fname (array char 6))
2278     (f-fpack (array char 6))))
2279    
2280     ;;; utime.h
2281    
2282     ;; Structure describing file times.
2283    
2284     (def-alien-type nil
2285     (struct utimbuf
2286     (actime time-t) ; Access time.
2287     (modtime time-t))) ; Modification time.
2288    
2289     ;;; Unix-utimes changes the accessed and updated times on UNIX
2290     ;;; files. The first argument is the filename (a string) and
2291     ;;; the second argument is a list of the 4 times- accessed and
2292     ;;; updated seconds and microseconds.
2293    
2294     (defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec)
2295     "Unix-utimes sets the 'last-accessed' and 'last-updated'
2296     times on a specified file. NIL and an error number is
2297     returned if the call is unsuccessful."
2298     (declare (type unix-pathname file)
2299     (type (alien unsigned-long)
2300     atime-sec atime-usec
2301     mtime-sec mtime-usec))
2302     (with-alien ((tvp (array (struct timeval) 2)))
2303     (setf (slot (deref tvp 0) 'tv-sec) atime-sec)
2304     (setf (slot (deref tvp 0) 'tv-usec) atime-usec)
2305     (setf (slot (deref tvp 1) 'tv-sec) mtime-sec)
2306     (setf (slot (deref tvp 1) 'tv-usec) mtime-usec)
2307     (void-syscall ("utimes" c-string (* (struct timeval)))
2308     file
2309     (cast tvp (* (struct