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