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