/[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.25 - (hide annotations)
Sun Apr 13 12:31:52 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.24: +5 -3 lines
	Don't export a class DIRECTORY from CL.  Fixes ANSI test case
	ALL-EXPORTED-CL-CLASS-NAMES-ARE-VALID.

	* src-types/code/unix.lisp (%directory): Struct renamed from
	directory, give it a :conc-name and :constructor for compatibility.

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