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