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