/[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.34 - (hide annotations)
Sat Sep 11 19:18:01 2004 UTC (9 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-10, snapshot-2004-12, snapshot-2004-11, snapshot-2005-01
Changes since 1.33: +15 -11 lines
Port of SBCL's float-accuracy compilation policy.  Intended to make
double-float-epsilon actually be epsilon on x86.  No effect on other
ports.

The default precision is now 53-bit (double-float) instead of 64-bit
(80-bit floats).  However, to preserve C expectations, all calls to C
have the precision set to 64-bit.  This slows down calls to C, but we
try to make syscalls and such fast by not changing precision for the
call.

By default ext:float-accuracy is 3.

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