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