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