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