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