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