1 ;;;; This file contains Unix support that SBCL needs to implement
2 ;;;; itself. It's derived from Peter Van Eynde's unix-glibc2.lisp for
3 ;;;; CMU CL, which was derived from CMU CL unix.lisp 1.56. But those
4 ;;;; files aspired to be complete Unix interfaces exported to the end
5 ;;;; user, while this file aims to be as simple as possible and is not
6 ;;;; intended for the end user.
8 ;;;; FIXME: The old CMU CL unix.lisp code was implemented as hand
9 ;;;; transcriptions from Unix headers into Lisp. It appears that this was as
10 ;;;; unmaintainable in practice as you'd expect in theory, so I really really
11 ;;;; don't want to do that. It'd be good to implement the various system calls
12 ;;;; as C code implemented using the Unix header files, and have their
13 ;;;; interface back to SBCL code be characterized by things like "32-bit-wide
14 ;;;; int" which are already in the interface between the runtime
15 ;;;; executable and the SBCL lisp code.
17 ;;;; This software is part of the SBCL system. See the README file for
18 ;;;; more information.
20 ;;;; This software is derived from the CMU CL system, which was
21 ;;;; written at Carnegie Mellon University and released into the
22 ;;;; public domain. The software is in the public domain and is
23 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
24 ;;;; files for more information.
26 (in-package "SB!UNIX")
28 (/show0 "unix.lisp 21")
30 ;;;; common machine-independent stuff
32 (eval-when (:compile-toplevel :execute)
34 (defparameter *compiler-unix-errors* nil)
36 (/show0 "unix.lisp 29")
38 (sb!xc:defmacro def-unix-error (name number description)
40 (defconstant ,name ,number ,description)
41 (eval-when (:compile-toplevel :execute)
42 (push (cons ,number ,description) *compiler-unix-errors*))))
44 (sb!xc:defmacro emit-unix-errors ()
45 (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
46 (array (make-array (1+ max) :initial-element nil)))
47 (dolist (error *compiler-unix-errors*)
48 (setf (svref array (car error)) (cdr error)))
50 (defvar *unix-errors* ',array)
51 (proclaim '(simple-vector *unix-errors*)))))
55 ;;; FIXME: Couldn't all the *UNIX-ERRORS*/*COMPILER-UNIX-ERRORS* cruft
56 ;;; be replaced by POSIX strerror(3)?
57 (defvar *unix-errors*)
59 (/show0 "unix.lisp 52")
61 (defmacro def-enum (inc cur &rest names)
62 (flet ((defform (name)
63 (prog1 (when name `(defconstant ,name ,cur))
64 (setf cur (funcall inc cur 1)))))
65 `(progn ,@(mapcar #'defform names))))
67 ;;; Given a C-level zero-terminated array of C strings, return a
68 ;;; corresponding Lisp-level list of SIMPLE-STRINGs.
69 (defun c-strings->string-list (c-strings)
70 (declare (type (alien (* c-string)) c-strings))
71 (let ((reversed-result nil))
72 (dotimes (i most-positive-fixnum (error "argh! can't happen"))
73 (declare (type index i))
74 (let ((c-string (deref c-strings i)))
76 (push c-string reversed-result)
77 (return (nreverse reversed-result)))))))
79 ;;;; Lisp types used by syscalls
81 (deftype unix-pathname () 'simple-string)
82 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
84 (deftype unix-file-mode () '(unsigned-byte 32))
85 (deftype unix-pid () '(unsigned-byte 32))
86 (deftype unix-uid () '(unsigned-byte 32))
87 (deftype unix-gid () '(unsigned-byte 32))
91 (/show0 "unix.lisp 74")
93 (defun get-unix-error-msg (&optional (error-number (get-errno)))
95 "Returns a string describing the error number which was returned by a
97 (declare (type integer error-number))
98 (if (array-in-bounds-p *unix-errors* error-number)
99 (svref *unix-errors* error-number)
100 (format nil "unknown error [~D]" error-number)))
102 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
103 ;;; macros in this file, are only used in this file, and could be
104 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
106 (defmacro syscall ((name &rest arg-types) success-form &rest args)
107 `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
110 (values nil (get-errno))
113 ;;; This is like SYSCALL, but if it fails, signal an error instead of
114 ;;; returning error codes. Should only be used for syscalls that will
115 ;;; never really get an error.
116 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
117 `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
120 (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
123 (/show0 "unix.lisp 109")
125 (defmacro void-syscall ((name &rest arg-types) &rest args)
126 `(syscall (,name ,@arg-types) (values t 0) ,@args))
128 (defmacro int-syscall ((name &rest arg-types) &rest args)
129 `(syscall (,name ,@arg-types) (values result 0) ,@args))
131 ;;;; hacking the Unix environment
133 (def-alien-routine ("getenv" posix-getenv) c-string
134 "Return the environment string \"name=value\" which corresponds to NAME, or
135 NIL if there is none."
140 ;;; Rename the file with string NAME1 to the string NAME2. NIL and an
141 ;;; error code is returned if an error occurs.
142 (defun unix-rename (name1 name2)
143 (declare (type unix-pathname name1 name2))
144 (void-syscall ("rename" c-string c-string) name1 name2))
146 ;;; from sys/types.h and gnu/types.h
148 (/show0 "unix.lisp 220")
150 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
151 (defconstant +max-s-long+ 2147483647)
152 (defconstant +max-u-long+ 4294967295)
153 (def-alien-type quad-t #+nil long-long #-nil (array long 2))
154 (def-alien-type uquad-t #+nil unsigned-long-long
155 #-nil (array unsigned-long 2))
156 (def-alien-type qaddr-t (* quad-t))
157 (def-alien-type daddr-t int)
158 (def-alien-type caddr-t (* char))
159 (def-alien-type swblk-t long)
160 (def-alien-type size-t unsigned-int)
161 (def-alien-type time-t long)
162 (def-alien-type clock-t
164 #!+bsd unsigned-long)
165 (def-alien-type uid-t unsigned-int)
166 (def-alien-type ssize-t int)
168 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
169 ;;; unless we have extreme provocation. Reading directories is not extreme
170 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
171 ;;; those functions in C as a wrapper layer.
172 (def-alien-type fd-mask unsigned-long)
174 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
175 (def-alien-type dev-t
178 (def-alien-type uid-t unsigned-int)
179 (def-alien-type gid-t unsigned-int)
180 (def-alien-type ino-t
181 #!+linux unsigned-long
183 (def-alien-type mode-t
184 #!+linux unsigned-int
185 #!+bsd unsigned-short)
186 (def-alien-type nlink-t
187 #!+linux unsigned-int
188 #!+bsd unsigned-short)
189 (/show0 "unix.lisp 263")
191 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
192 ;;; unless we have extreme provocation. Reading directories is not extreme
193 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
194 ;;; those functions in C as a wrapper layer.
196 (def-alien-type off-t
200 (defconstant fd-setsize 1024)
204 (fds-bits (array fd-mask #.(/ fd-setsize 32)))))
208 (/show0 "unix.lisp 304")
212 (d-ino long); inode number of entry
213 (d-off off-t) ; offset of next disk directory entry
214 (d-reclen unsigned-short) ; length of this record
215 (d_type unsigned-char)
216 (d-name (array char 256)))) ; name must be no longer than this
220 ;;;; FIXME: It might be really nice to implement these in C, so that
221 ;;;; we don't need to do horrible things like hand-copying the
222 ;;;; direntry struct slot types into an alien struct.
225 ;;; FIXME: DIRECTORY is an external symbol of package CL, so we should
226 ;;; use some other name for this low-level implementation type.
227 (defstruct (directory (:copier nil))
229 (dir-struct (required-argument) :type system-area-pointer))
230 (def!method print-object ((dir directory) stream)
231 (print-unreadable-object (dir stream :type t)
232 (prin1 (directory-name dir) stream)))
234 (defun open-dir (pathname)
235 (declare (type unix-pathname pathname))
236 (when (string= pathname "")
238 (let ((kind (unix-file-kind pathname)))
242 (alien-funcall (extern-alien "opendir"
243 (function system-area-pointer
246 (if (zerop (sap-int dir-struct))
247 (values nil (get-errno))
248 (make-directory :name pathname :dir-struct dir-struct))))
252 (values nil enotdir)))))
254 (defun read-dir (dir)
255 (declare (type directory dir))
256 (let ((daddr (alien-funcall (extern-alien "readdir"
257 (function system-area-pointer
258 system-area-pointer))
259 (directory-dir-struct dir))))
260 (declare (type system-area-pointer daddr))
261 (if (zerop (sap-int daddr))
263 (with-alien ((direct (* (struct direct)) daddr))
264 (values (cast (slot direct 'd-name) c-string)
265 (slot direct 'd-ino))))))
267 (defun close-dir (dir)
268 (declare (type directory dir))
269 (alien-funcall (extern-alien "closedir"
270 (function void system-area-pointer))
271 (directory-dir-struct dir))
276 ;;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
278 (/show0 "unix.lisp 356")
279 (defconstant r_ok 4 #!+sb-doc "Test for read permission")
280 (defconstant w_ok 2 #!+sb-doc "Test for write permission")
281 (defconstant x_ok 1 #!+sb-doc "Test for execute permission")
282 (defconstant f_ok 0 #!+sb-doc "Test for presence of file")
284 ;;; Open the file whose pathname is specified by PATH for reading
285 ;;; and/or writing as specified by the FLAGS argument. Various FLAGS
286 ;;; masks (O_RDONLY etc.) are defined in fcntlbits.h.
288 ;;; If the O_CREAT flag is specified, then the file is created with a
289 ;;; permission of argument MODE if the file doesn't exist. An integer
290 ;;; file descriptor is returned by UNIX-OPEN.
291 (defun unix-open (path flags mode)
292 (declare (type unix-pathname path)
294 (type unix-file-mode mode))
295 (int-syscall ("open" c-string int int) path flags mode))
297 ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file
298 ;;; associated with it.
299 (/show0 "unix.lisp 391")
300 (defun unix-close (fd)
301 (declare (type unix-fd fd))
302 (void-syscall ("close" int) fd))
306 (/show0 "unix.lisp 337")
307 (defconstant o_rdonly 0) ; read-only flag
308 (defconstant o_wronly 1) ; write-only flag
309 (defconstant o_rdwr 2) ; read/write flag
310 (defconstant o_accmode 3) ; access mode mask
311 (defconstant o_creat ; create-if-nonexistent flag (not fcntl)
314 (/show0 "unix.lisp 345")
315 (defconstant o_excl ; error if already exists (not fcntl)
318 (defconstant o_noctty ; Don't assign controlling tty. (not fcntl)
321 (defconstant o_trunc ; truncation flag (not fcntl)
324 (defconstant o_append ; append flag
327 (/show0 "unix.lisp 361")
331 ;; A time value that is accurate to the nearest
332 ;; microsecond but also has a range of years.
335 (tv-sec time-t) ; seconds
336 (tv-usec time-t))) ; and microseconds
340 (defconstant rusage_self 0 #!+sb-doc "The calling process.")
341 (defconstant rusage_children -1 #!+sb-doc "Terminated child processes.")
342 (defconstant rusage_both -2)
346 (ru-utime (struct timeval)) ; user time used
347 (ru-stime (struct timeval)) ; system time used.
348 (ru-maxrss long) ; maximum resident set size (in kilobytes)
349 (ru-ixrss long) ; integral shared memory size
350 (ru-idrss long) ; integral unshared data size
351 (ru-isrss long) ; integral unshared stack size
352 (ru-minflt long) ; page reclaims
353 (ru-majflt long) ; page faults
354 (ru-nswap long) ; swaps
355 (ru-inblock long) ; block input operations
356 (ru-oublock long) ; block output operations
357 (ru-msgsnd long) ; messages sent
358 (ru-msgrcv long) ; messages received
359 (ru-nsignals long) ; signals received
360 (ru-nvcsw long) ; voluntary context switches
361 (ru-nivcsw long))) ; involuntary context switches
365 ;;; FIXME: This should go into C code so that we don't need to hand-copy
366 ;;; it from header files.
371 (st-pad1 unsigned-short)
378 (st-pad2 unsigned-short)
380 (st-blksize unsigned-long)
381 (st-blocks unsigned-long)
383 (unused-1 unsigned-long)
385 (unused-2 unsigned-long)
387 (unused-3 unsigned-long)
388 (unused-4 unsigned-long)
389 (unused-5 unsigned-long)))
407 (st-atime (struct timespec-t))
408 (st-mtime (struct timespec-t))
409 (st-ctime (struct timespec-t))
410 (st-size unsigned-long) ; really quad
411 (st-sizeh unsigned-long) ;
412 (st-blocks unsigned-long) ; really quad
413 (st-blocksh unsigned-long)
414 (st-blksize unsigned-long)
415 (st-flags unsigned-long)
416 (st-gen unsigned-long)
418 (st-qspare (array long 4))
421 ;; encoding of the file mode
423 (defconstant s-ifmt #o0170000 #!+sb-doc "These bits determine file type.")
426 (defconstant s-ififo #o0010000 #!+sb-doc "FIFO")
427 (defconstant s-ifchr #o0020000 #!+sb-doc "Character device")
428 (defconstant s-ifdir #o0040000 #!+sb-doc "Directory")
429 (defconstant s-ifblk #o0060000 #!+sb-doc "Block device")
430 (defconstant s-ifreg #o0100000 #!+sb-doc "Regular file")
432 ;; These don't actually exist on System V, but having them doesn't hurt.
433 (defconstant s-iflnk #o0120000 #!+sb-doc "Symbolic link.")
434 (defconstant s-ifsock #o0140000 #!+sb-doc "Socket.")
438 ;;; values for the second argument to access
439 (defun unix-access (path mode)
441 "Given a file path (a string) and one of four constant modes,
442 UNIX-ACCESS returns T if the file is accessible with that
443 mode and NIL if not. It also returns an errno value with
444 NIL which determines why the file was not accessible.
446 The access modes are:
447 r_ok Read permission.
448 w_ok Write permission.
449 x_ok Execute permission.
450 f_ok Presence of file."
451 (declare (type unix-pathname path)
453 (void-syscall ("access" c-string int) path mode))
455 (defconstant l_set 0 #!+sb-doc "set the file pointer")
456 (defconstant l_incr 1 #!+sb-doc "increment the file pointer")
457 (defconstant l_xtnd 2 #!+sb-doc "extend the file size")
459 (defun unix-lseek (fd offset whence)
461 "Unix-lseek accepts a file descriptor and moves the file pointer ahead
462 a certain offset for that file. Whence can be any of the following:
464 l_set Set the file pointer.
465 l_incr Increment the file pointer.
466 l_xtnd Extend the file size.
468 (declare (type unix-fd fd)
469 (type (unsigned-byte 32) offset)
470 (type (integer 0 2) whence))
472 (int-syscall ("lseek" int off-t int) fd offset whence)
473 ;; Need a 64-bit return value type for this. TBD. For now,
474 ;; don't use this with any 2G+ partitions.
476 (int-syscall ("lseek" int unsigned-long unsigned-long int)
479 ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
480 ;;; It attempts to read len bytes from the device associated with fd
481 ;;; and store them into the buffer. It returns the actual number of
483 (defun unix-read (fd buf len)
485 "Unix-read attempts to read from the file described by fd into
486 the buffer buf until it is full. Len is the length of the buffer.
487 The number of bytes actually read is returned or NIL and an error
488 number if an error occurred."
489 (declare (type unix-fd fd)
490 (type (unsigned-byte 32) len))
492 (int-syscall ("read" int (* char) int) fd buf len))
494 ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
495 ;;; length to write. It attempts to write len bytes to the device
496 ;;; associated with fd from the the buffer starting at offset. It returns
497 ;;; the actual number of bytes written.
498 (defun unix-write (fd buf offset len)
500 "Unix-write attempts to write a character buffer (buf) of length
501 len to the file described by the file descriptor fd. NIL and an
502 error is returned if the call is unsuccessful."
503 (declare (type unix-fd fd)
504 (type (unsigned-byte 32) offset len))
505 (int-syscall ("write" int (* char) int)
507 (with-alien ((ptr (* char) (etypecase buf
508 ((simple-array * (*))
512 (addr (deref ptr offset)))
515 ;;; Set up a unix-piping mechanism consisting of
516 ;;; an input pipe and an output pipe. Return two
517 ;;; values: if no error occurred the first value is the pipe
518 ;;; to be read from and the second is can be written to. If
519 ;;; an error occurred the first value is NIL and the second
520 ;;; the unix error code.
522 (with-alien ((fds (array int 2)))
523 (syscall ("pipe" (* int))
524 (values (deref fds 0) (deref fds 1))
525 (cast fds (* int)))))
527 ;;; UNIX-CHDIR accepts a directory name and makes that the
528 ;;; current working directory.
529 (defun unix-chdir (path)
531 "Given a file path string, unix-chdir changes the current working
532 directory to the one specified."
533 (declare (type unix-pathname path))
534 (void-syscall ("chdir" c-string) path))
536 (defun unix-current-directory ()
538 "Return the current directory as a SIMPLE-STRING."
539 ;; FIXME: Gcc justifiably complains that getwd is dangerous and should
540 ;; not be used; especially with a hardwired 1024 buffer size, yecch.
541 ;; This should be rewritten to use getcwd(3), perhaps by writing
542 ;; a C service routine to do the actual call to getcwd(3) and check
544 (with-alien ((buf (array char 1024)))
545 (values (not (zerop (alien-funcall (extern-alien "getwd"
546 (function int (* char)))
547 (cast buf (* char)))))
548 (cast buf c-string))))
552 "Unix-dup duplicates an existing file descriptor (given as the
553 argument) and returns it. If FD is not a valid file descriptor, NIL
554 and an error number are returned."
555 (declare (type unix-fd fd))
556 (int-syscall ("dup" int) fd))
558 ;;; UNIX-EXIT terminates a program.
559 (defun unix-exit (&optional (code 0))
561 "Unix-exit terminates the current process with an optional
562 error code. If successful, the call doesn't return. If
563 unsuccessful, the call returns NIL and an error number."
564 (declare (type (signed-byte 32) code))
565 (void-syscall ("exit" int) code))
567 (def-alien-routine ("getpid" unix-getpid) int
569 "Unix-getpid returns the process-id of the current process.")
571 (def-alien-routine ("getuid" unix-getuid) int
573 "Unix-getuid returns the real user-id associated with the
576 (defun unix-readlink (path)
578 "Unix-readlink invokes the readlink system call on the file name
579 specified by the simple string path. It returns up to two values:
580 the contents of the symbolic link if the call is successful, or
581 NIL and the Unix error number."
582 (declare (type unix-pathname path))
583 (with-alien ((buf (array char 1024)))
584 (syscall ("readlink" c-string (* char) int)
585 (let ((string (make-string result)))
586 (sb!kernel:copy-from-system-area
588 string (* sb!vm:vector-data-offset sb!vm:word-bits)
589 (* result sb!vm:byte-bits))
591 path (cast buf (* char)) 1024)))
593 ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
594 ;;; name and the file if this is the last link.
595 (defun unix-unlink (name)
597 "Unix-unlink removes the directory entry for the named file.
598 NIL and an error code is returned if the call fails."
599 (declare (type unix-pathname name))
600 (void-syscall ("unlink" c-string) name))
602 (defun %set-tty-process-group (pgrp &optional fd)
604 "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
605 supplied, FD defaults to /dev/tty."
606 (let ((old-sigs (unix-sigblock (sigmask :sigttou
610 (declare (type (unsigned-byte 32) old-sigs))
614 (multiple-value-bind (tty-fd errno) (unix-open "/dev/tty" o_rdwr 0)
616 (multiple-value-prog1
617 (tcsetpgrp tty-fd pgrp)
618 (unix-close tty-fd)))
620 (values nil errno)))))
621 (unix-sigsetmask old-sigs))))
623 (defun unix-gethostname ()
625 "Unix-gethostname returns the name of the host machine as a string."
626 (with-alien ((buf (array char 256)))
627 (syscall ("gethostname" (* char) int)
629 (cast buf (* char)) 256)))
631 (defun unix-fsync (fd)
633 "Unix-fsync writes the core image of the file described by
635 (declare (type unix-fd fd))
636 (void-syscall ("fsync" int) fd))
640 (defun unix-ioctl (fd cmd arg)
642 "Unix-ioctl performs a variety of operations on open i/o
643 descriptors. See the UNIX Programmer's Manual for more
645 (declare (type unix-fd fd)
646 (type (unsigned-byte 32) cmd))
647 (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
651 ;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
652 #!-sb-fluid (declaim (inline unix-fast-getrusage))
653 (defun unix-fast-getrusage (who)
655 "Like call getrusage, but return only the system and user time, and returns
656 the seconds and microseconds as separate values."
657 (declare (values (member t)
658 (unsigned-byte 31) (mod 1000000)
659 (unsigned-byte 31) (mod 1000000)))
660 (with-alien ((usage (struct rusage)))
661 (syscall* ("getrusage" int (* (struct rusage)))
663 (slot (slot usage 'ru-utime) 'tv-sec)
664 (slot (slot usage 'ru-utime) 'tv-usec)
665 (slot (slot usage 'ru-stime) 'tv-sec)
666 (slot (slot usage 'ru-stime) 'tv-usec))
669 (defun unix-getrusage (who)
671 "Unix-getrusage returns information about the resource usage
672 of the process specified by who. Who can be either the
673 current process (rusage_self) or all of the terminated
674 child processes (rusage_children). NIL and an error number
675 is returned if the call fails."
676 (with-alien ((usage (struct rusage)))
677 (syscall ("getrusage" int (* (struct rusage)))
679 (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
680 (slot (slot usage 'ru-utime) 'tv-usec))
681 (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
682 (slot (slot usage 'ru-stime) 'tv-usec))
683 (slot usage 'ru-maxrss)
684 (slot usage 'ru-ixrss)
685 (slot usage 'ru-idrss)
686 (slot usage 'ru-isrss)
687 (slot usage 'ru-minflt)
688 (slot usage 'ru-majflt)
689 (slot usage 'ru-nswap)
690 (slot usage 'ru-inblock)
691 (slot usage 'ru-oublock)
692 (slot usage 'ru-msgsnd)
693 (slot usage 'ru-msgrcv)
694 (slot usage 'ru-nsignals)
695 (slot usage 'ru-nvcsw)
696 (slot usage 'ru-nivcsw))
702 (defmacro unix-fast-select (num-descriptors
703 read-fds write-fds exception-fds
704 timeout-secs &optional (timeout-usecs 0))
706 "Perform the UNIX select(2) system call."
707 (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
708 (type (or (alien (* (struct fd-set))) null)
709 read-fds write-fds exception-fds)
710 (type (or null (unsigned-byte 31)) timeout-secs)
711 (type (unsigned-byte 31) timeout-usecs) )
713 ;; (optimize (speed 3) (safety 0) (inhibit-warnings 3))
714 ;; in the declarations above. If they're important, they should
715 ;; be in a declaration inside the LET expansion, not in the
716 ;; macro compile-time code.
717 `(let ((timeout-secs ,timeout-secs))
718 (with-alien ((tv (struct timeval)))
720 (setf (slot tv 'tv-sec) timeout-secs)
721 (setf (slot tv 'tv-usec) ,timeout-usecs))
722 (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
723 (* (struct fd-set)) (* (struct timeval)))
724 ,num-descriptors ,read-fds ,write-fds ,exception-fds
725 (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
727 ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
728 ;;; to happen on one of them or to time out.
729 (defmacro num-to-fd-set (fdset num)
732 (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
733 ,@(loop for index upfrom 1 below (/ fd-setsize 32)
734 collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
736 ,@(loop for index upfrom 0 below (/ fd-setsize 32)
737 collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
738 (ldb (byte 32 ,(* index 32)) ,num))))))
740 (defmacro fd-set-to-num (nfds fdset)
742 (deref (slot ,fdset 'fds-bits) 0)
743 (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
744 collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
747 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
749 "Unix-select examines the sets of descriptors passed as arguments
750 to see whether they are ready for reading and writing. See the UNIX
751 Programmers Manual for more information."
752 (declare (type (integer 0 #.FD-SETSIZE) nfds)
753 (type unsigned-byte rdfds wrfds xpfds)
754 (type (or (unsigned-byte 31) null) to-secs)
755 (type (unsigned-byte 31) to-usecs)
756 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
757 (with-alien ((tv (struct timeval))
758 (rdf (struct fd-set))
759 (wrf (struct fd-set))
760 (xpf (struct fd-set)))
762 (setf (slot tv 'tv-sec) to-secs)
763 (setf (slot tv 'tv-usec) to-usecs))
764 (num-to-fd-set rdf rdfds)
765 (num-to-fd-set wrf wrfds)
766 (num-to-fd-set xpf xpfds)
767 (macrolet ((frob (lispvar alienvar)
768 `(if (zerop ,lispvar)
770 (alien-sap (addr ,alienvar)))))
771 (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
772 (* (struct fd-set)) (* (struct timeval)))
774 (fd-set-to-num nfds rdf)
775 (fd-set-to-num nfds wrf)
776 (fd-set-to-num nfds xpf))
777 nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
778 (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
782 ;;; FIXME: This is only used in this file, and needn't be in target Lisp
783 ;;; runtime. It's also unclear why it needs to be a macro instead of a
784 ;;; function. Perhaps it should become a FLET.
785 (defmacro extract-stat-results (buf)
790 (+ (deref (slot ,buf 'st-dev) 0)
791 (* (+ +max-u-long+ 1)
792 (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works..
795 (slot ,buf 'st-nlink)
801 (+ (deref (slot ,buf 'st-rdev) 0)
802 (* (+ +max-u-long+ 1)
803 (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works..
804 #!+linux (slot ,buf 'st-size)
806 (+ (slot ,buf 'st-size)
807 (* (+ +max-u-long+ 1)
808 (slot ,buf 'st-sizeh)))
809 #!+linux (slot ,buf 'st-atime)
810 #!+bsd (slot (slot ,buf 'st-atime) 'tv-sec)
811 #!+linux (slot ,buf 'st-mtime)
812 #!+bsd (slot (slot ,buf 'st-mtime) 'tv-sec)
813 #!+linux (slot ,buf 'st-ctime)
814 #!+bsd (slot (slot ,buf 'st-ctime) 'tv-sec)
815 (slot ,buf 'st-blksize)
816 #!+linux (slot ,buf 'st-blocks)
818 (+ (slot ,buf 'st-blocks)
819 (* (+ +max-u-long+ 1)
820 (slot ,buf 'st-blocksh)))
823 (defun unix-stat (name)
825 "Unix-stat retrieves information about the specified
826 file returning them in the form of multiple values.
827 See the UNIX Programmer's Manual for a description
828 of the values returned. If the call fails, then NIL
829 and an error number is returned instead."
830 (declare (type unix-pathname name))
831 (when (string= name "")
833 (with-alien ((buf (struct stat)))
834 (syscall ("stat" c-string (* (struct stat)))
835 (extract-stat-results buf)
838 (defun unix-fstat (fd)
840 "Unix-fstat is similar to unix-stat except the file is specified
841 by the file descriptor fd."
842 (declare (type unix-fd fd))
843 (with-alien ((buf (struct stat)))
844 (syscall ("fstat" int (* (struct stat)))
845 (extract-stat-results buf)
848 (defun unix-lstat (name)
850 "Unix-lstat is similar to unix-stat except the specified
851 file must be a symbolic link."
852 (declare (type unix-pathname name))
853 (with-alien ((buf (struct stat)))
854 (syscall ("lstat" c-string (* (struct stat)))
855 (extract-stat-results buf)
858 ;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
859 ;;; corresponding directory with mode mode.
860 (defun unix-mkdir (name mode)
862 "Unix-mkdir creates a new directory with the specified name and mode.
863 (Same as those for unix-fchmod.) It returns T upon success, otherwise
864 NIL and an error number."
865 (declare (type unix-pathname name)
866 (type unix-file-mode mode))
867 (void-syscall ("mkdir" c-string int) name mode))
871 ;; the POSIX.4 structure for a time value. This is like a `struct
872 ;; timeval' but has nanoseconds instead of microseconds.
875 (tv-sec long) ;Seconds
876 (tv-nsec long))) ;Nanoseconds
878 ;; used by other time functions
881 (tm-sec int) ; Seconds. [0-60] (1 leap second)
882 (tm-min int) ; Minutes. [0-59]
883 (tm-hour int) ; Hours. [0-23]
884 (tm-mday int) ; Day. [1-31]
885 (tm-mon int) ; Month. [0-11]
886 (tm-year int) ; Year - 1900.
887 (tm-wday int) ; Day of week. [0-6]
888 (tm-yday int) ; Days in year.[0-365]
889 (tm-isdst int) ; DST. [-1/0/1]
890 (tm-gmtoff long) ; Seconds east of UTC.
891 (tm-zone c-string))) ; Timezone abbreviation.
893 (def-alien-routine get-timezone sb!c-call:void
894 (when sb!c-call:long :in)
895 (minutes-west sb!c-call:int :out)
896 (daylight-savings-p sb!alien:boolean :out))
898 (defun unix-get-minutes-west (secs)
899 (multiple-value-bind (ignore minutes dst) (get-timezone secs)
900 (declare (ignore ignore) (ignore dst))
903 (defun unix-get-timezone (secs)
904 (multiple-value-bind (ignore minutes dst) (get-timezone secs)
905 (declare (ignore ignore) (ignore minutes))
906 (values (deref unix-tzname (if dst 1 0)))))
911 ;;; Structure crudely representing a timezone. KLUDGE: This is
912 ;;; obsolete and should never be used.
915 (tz-minuteswest int) ; minutes west of Greenwich
916 (tz-dsttime int))) ; type of dst correction
918 #!-sb-fluid (declaim (inline unix-gettimeofday))
919 (defun unix-gettimeofday ()
921 "If it works, unix-gettimeofday returns 5 values: T, the seconds and
922 microseconds of the current time of day, the timezone (in minutes west
923 of Greenwich), and a daylight-savings flag. If it doesn't work, it
924 returns NIL and the errno."
925 (with-alien ((tv (struct timeval))
926 (tz (struct timezone)))
927 (syscall* ("gettimeofday" (* (struct timeval))
928 (* (struct timezone)))
932 (slot tz 'tz-minuteswest)
933 (slot tz 'tz-dsttime))
940 (def-unix-error ESUCCESS 0 "Successful")
941 (def-unix-error EPERM 1 "Operation not permitted")
943 (def-unix-error ENOENT 2 "No such file or directory")
945 (def-unix-error ESRCH 3 "No such process")
947 (def-unix-error EINTR 4 "Interrupted system call")
948 (def-unix-error EIO 5 "I/O error")
950 (def-unix-error ENXIO 6 "No such device or address")
951 (def-unix-error E2BIG 7 "Arg list too long")
952 (def-unix-error ENOEXEC 8 "Exec format error")
953 (def-unix-error EBADF 9 "Bad file number")
954 (def-unix-error ECHILD 10 "No children")
955 (def-unix-error EAGAIN 11 "Try again")
956 (def-unix-error ENOMEM 12 "Out of memory")
958 (def-unix-error EACCES 13 "Permission denied")
960 (def-unix-error EFAULT 14 "Bad address")
961 (def-unix-error ENOTBLK 15 "Block device required")
962 (def-unix-error EBUSY 16 "Device or resource busy")
964 (def-unix-error EEXIST 17 "File exists")
966 (def-unix-error EXDEV 18 "Cross-device link")
967 (def-unix-error ENODEV 19 "No such device")
969 (def-unix-error ENOTDIR 20 "Not a directory")
971 (def-unix-error EISDIR 21 "Is a directory")
972 (def-unix-error EINVAL 22 "Invalid argument")
973 (def-unix-error ENFILE 23 "File table overflow")
974 (def-unix-error EMFILE 24 "Too many open files")
975 (def-unix-error ENOTTY 25 "Not a typewriter")
976 (def-unix-error ETXTBSY 26 "Text file busy")
977 (def-unix-error EFBIG 27 "File too large")
978 (def-unix-error ENOSPC 28 "No space left on device")
980 (def-unix-error ESPIPE 29 "Illegal seek")
982 (def-unix-error EROFS 30 "Read-only file system")
983 (def-unix-error EMLINK 31 "Too many links")
984 (def-unix-error EPIPE 32 "Broken pipe")
989 (def-unix-error EDOM 33 "Math argument out of domain")
990 (def-unix-error ERANGE 34 "Math result not representable")
991 (def-unix-error EDEADLK 35 "Resource deadlock would occur")
992 (def-unix-error ENAMETOOLONG 36 "File name too long")
993 (def-unix-error ENOLCK 37 "No record locks available")
994 (def-unix-error ENOSYS 38 "Function not implemented")
995 (def-unix-error ENOTEMPTY 39 "Directory not empty")
996 (def-unix-error ELOOP 40 "Too many symbolic links encountered")
998 (def-unix-error EWOULDBLOCK 11 "Operation would block")
999 (/show0 "unix.lisp 3192")
1001 (def-unix-error ENOMSG 42 "No message of desired type")
1002 (def-unix-error EIDRM 43 "Identifier removed")
1003 (def-unix-error ECHRNG 44 "Channel number out of range")
1004 (def-unix-error EL2NSYNC 45 "Level 2 not synchronized")
1005 (def-unix-error EL3HLT 46 "Level 3 halted")
1006 (def-unix-error EL3RST 47 "Level 3 reset")
1007 (def-unix-error ELNRNG 48 "Link number out of range")
1008 (def-unix-error EUNATCH 49 "Protocol driver not attached")
1009 (def-unix-error ENOCSI 50 "No CSI structure available")
1010 (def-unix-error EL2HLT 51 "Level 2 halted")
1011 (def-unix-error EBADE 52 "Invalid exchange")
1012 (def-unix-error EBADR 53 "Invalid request descriptor")
1013 (def-unix-error EXFULL 54 "Exchange full")
1014 (def-unix-error ENOANO 55 "No anode")
1015 (def-unix-error EBADRQC 56 "Invalid request code")
1016 (def-unix-error EBADSLT 57 "Invalid slot")
1017 (def-unix-error EDEADLOCK EDEADLK "File locking deadlock error")
1018 (def-unix-error EBFONT 59 "Bad font file format")
1019 (def-unix-error ENOSTR 60 "Device not a stream")
1020 (def-unix-error ENODATA 61 "No data available")
1021 (def-unix-error ETIME 62 "Timer expired")
1022 (def-unix-error ENOSR 63 "Out of streams resources")
1023 (def-unix-error ENONET 64 "Machine is not on the network")
1024 (def-unix-error ENOPKG 65 "Package not installed")
1025 (def-unix-error EREMOTE 66 "Object is remote")
1026 (def-unix-error ENOLINK 67 "Link has been severed")
1027 (def-unix-error EADV 68 "Advertise error")
1028 (def-unix-error ESRMNT 69 "Srmount error")
1029 (def-unix-error ECOMM 70 "Communication error on send")
1030 (def-unix-error EPROTO 71 "Protocol error")
1031 (def-unix-error EMULTIHOP 72 "Multihop attempted")
1032 (def-unix-error EDOTDOT 73 "RFS specific error")
1033 (def-unix-error EBADMSG 74 "Not a data message")
1034 (def-unix-error EOVERFLOW 75 "Value too large for defined data type")
1035 (def-unix-error ENOTUNIQ 76 "Name not unique on network")
1036 (def-unix-error EBADFD 77 "File descriptor in bad state")
1037 (def-unix-error EREMCHG 78 "Remote address changed")
1038 (def-unix-error ELIBACC 79 "Can not access a needed shared library")
1039 (def-unix-error ELIBBAD 80 "Accessing a corrupted shared library")
1040 (def-unix-error ELIBSCN 81 ".lib section in a.out corrupted")
1041 (def-unix-error ELIBMAX 82 "Attempting to link in too many shared libraries")
1042 (def-unix-error ELIBEXEC 83 "Cannot exec a shared library directly")
1043 (def-unix-error EILSEQ 84 "Illegal byte sequence")
1044 (def-unix-error ERESTART 85 "Interrupted system call should be restarted ")
1045 (def-unix-error ESTRPIPE 86 "Streams pipe error")
1046 (def-unix-error EUSERS 87 "Too many users")
1047 (def-unix-error ENOTSOCK 88 "Socket operation on non-socket")
1048 (def-unix-error EDESTADDRREQ 89 "Destination address required")
1049 (def-unix-error EMSGSIZE 90 "Message too long")
1050 (def-unix-error EPROTOTYPE 91 "Protocol wrong type for socket")
1051 (def-unix-error ENOPROTOOPT 92 "Protocol not available")
1052 (def-unix-error EPROTONOSUPPORT 93 "Protocol not supported")
1053 (def-unix-error ESOCKTNOSUPPORT 94 "Socket type not supported")
1054 (def-unix-error EOPNOTSUPP 95 "Operation not supported on transport endpoint")
1055 (def-unix-error EPFNOSUPPORT 96 "Protocol family not supported")
1056 (def-unix-error EAFNOSUPPORT 97 "Address family not supported by protocol")
1057 (def-unix-error EADDRINUSE 98 "Address already in use")
1058 (def-unix-error EADDRNOTAVAIL 99 "Cannot assign requested address")
1059 (def-unix-error ENETDOWN 100 "Network is down")
1060 (def-unix-error ENETUNREACH 101 "Network is unreachable")
1061 (def-unix-error ENETRESET 102 "Network dropped connection because of reset")
1062 (def-unix-error ECONNABORTED 103 "Software caused connection abort")
1063 (def-unix-error ECONNRESET 104 "Connection reset by peer")
1064 (def-unix-error ENOBUFS 105 "No buffer space available")
1065 (def-unix-error EISCONN 106 "Transport endpoint is already connected")
1066 (def-unix-error ENOTCONN 107 "Transport endpoint is not connected")
1067 (def-unix-error ESHUTDOWN 108 "Cannot send after transport endpoint shutdown")
1068 (def-unix-error ETOOMANYREFS 109 "Too many references: cannot splice")
1069 (def-unix-error ETIMEDOUT 110 "Connection timed out")
1070 (def-unix-error ECONNREFUSED 111 "Connection refused")
1071 (def-unix-error EHOSTDOWN 112 "Host is down")
1072 (def-unix-error EHOSTUNREACH 113 "No route to host")
1073 (def-unix-error EALREADY 114 "Operation already in progress")
1074 (def-unix-error EINPROGRESS 115 "Operation now in progress")
1075 (def-unix-error ESTALE 116 "Stale NFS file handle")
1076 (def-unix-error EUCLEAN 117 "Structure needs cleaning")
1077 (def-unix-error ENOTNAM 118 "Not a XENIX named type file")
1078 (def-unix-error ENAVAIL 119 "No XENIX semaphores available")
1079 (def-unix-error EISNAM 120 "Is a named type file")
1080 (def-unix-error EREMOTEIO 121 "Remote I/O error")
1081 (def-unix-error EDQUOT 122 "Quota exceeded")
1084 ;;; And now for something completely different ...
1087 ;;;; support routines for dealing with Unix pathnames
1089 (defun unix-file-kind (name &optional check-for-links)
1091 "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
1092 (declare (simple-string name))
1093 (multiple-value-bind (res dev ino mode)
1094 (if check-for-links (unix-lstat name) (unix-stat name))
1095 (declare (type (or fixnum null) mode)
1098 (let ((kind (logand mode s-ifmt)))
1099 (cond ((eql kind s-ifdir) :directory)
1100 ((eql kind s-ifreg) :file)
1101 ((eql kind s-iflnk) :link)
1104 (defun unix-maybe-prepend-current-directory (name)
1105 (declare (simple-string name))
1106 (if (and (> (length name) 0) (char= (schar name 0) #\/))
1108 (multiple-value-bind (win dir) (unix-current-directory)
1110 (concatenate 'simple-string dir "/" name)
1113 ;;; Return the pathname with all symbolic links resolved.
1114 (defun unix-resolve-links (pathname)
1115 (declare (simple-string pathname))
1116 (let ((len (length pathname))
1118 (declare (fixnum len) (simple-string pending))
1121 (let ((result (make-string 1024 :initial-element (code-char 0)))
1125 (let* ((name-end (or (position #\/ pending :start name-start) len))
1126 (new-fill-ptr (+ fill-ptr (- name-end name-start))))
1127 (replace result pending
1132 (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t)))
1133 (unless kind (return nil))
1134 (cond ((eq kind :link)
1135 (multiple-value-bind (link err) (unix-readlink result)
1137 (error "error reading link ~S: ~S"
1138 (subseq result 0 fill-ptr)
1139 (get-unix-error-msg err)))
1140 (cond ((or (zerop (length link))
1141 (char/= (schar link 0) #\/))
1142 ;; It's a relative link.
1143 (fill result (code-char 0)
1146 ((string= result "/../" :end1 4)
1147 ;; It's across the super-root.
1148 (let ((slash (or (position #\/ result :start 4)
1150 (fill result (code-char 0)
1153 (setf fill-ptr slash)))
1156 (and (> (length link) 0)
1157 (char= (schar link 0) #\/))
1158 (fill result (code-char 0) :end new-fill-ptr)
1161 (if (= name-end len)
1163 (concatenate 'simple-string
1165 (subseq pending name-end))))
1166 (setf len (length pending))
1167 (setf name-start 0)))
1169 (return (subseq result 0 new-fill-ptr)))
1170 ((eq kind :directory)
1171 (setf (schar result new-fill-ptr) #\/)
1172 (setf fill-ptr (1+ new-fill-ptr))
1173 (setf name-start (1+ name-end)))
1175 (return nil))))))))))
1177 (defun unix-simplify-pathname (src)
1178 (declare (simple-string src))
1179 (let* ((src-len (length src))
1180 (dst (make-string src-len))
1184 (macrolet ((deposit (char)
1186 (setf (schar dst dst-len) ,char)
1188 (dotimes (src-index src-len)
1189 (let ((char (schar src src-index)))
1190 (cond ((char= char #\.)
1197 ;; Either ``/...' or ``...//...'
1199 (setf last-slash dst-len)
1202 ;; Either ``./...'' or ``..././...''
1207 ((and last-slash (not (zerop last-slash)))
1208 ;; There is something before this ..
1209 (let ((prev-prev-slash
1210 (position #\/ dst :end last-slash :from-end t)))
1211 (cond ((and (= (+ (or prev-prev-slash 0) 2)
1213 (char= (schar dst (- last-slash 2)) #\.)
1214 (char= (schar dst (1- last-slash)) #\.))
1215 ;; The something before this .. is another ..
1217 (setf last-slash dst-len))
1219 ;; The something is some directory or other.
1222 (1+ prev-prev-slash)
1224 (setf last-slash prev-prev-slash)))))
1226 ;; There is nothing before this .., so we need to keep it
1227 (setf last-slash dst-len)
1230 ;; Something other than a dot between slashes.
1231 (setf last-slash dst-len)
1236 (setf (schar dst dst-len) char)
1238 (when (and last-slash (not (zerop last-slash)))
1241 ;; We've got ``foobar/.''
1244 ;; We've got ``foobar/..''
1245 (unless (and (>= last-slash 2)
1246 (char= (schar dst (1- last-slash)) #\.)
1247 (char= (schar dst (- last-slash 2)) #\.)
1248 (or (= last-slash 2)
1249 (char= (schar dst (- last-slash 3)) #\/)))
1250 (let ((prev-prev-slash
1251 (position #\/ dst :end last-slash :from-end t)))
1253 (setf dst-len (1+ prev-prev-slash))
1254 (return-from unix-simplify-pathname "./")))))))
1255 (cond ((zerop dst-len)
1257 ((= dst-len src-len)
1260 (subseq dst 0 dst-len)))))
1262 ;;;; stuff not yet found in the header files
1264 ;;;; Abandon all hope who enters here...
1266 ;;; not checked for linux...
1267 (defmacro fd-set (offset fd-set)
1268 (let ((word (gensym))
1270 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1271 (setf (deref (slot ,fd-set 'fds-bits) ,word)
1272 (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
1273 (deref (slot ,fd-set 'fds-bits) ,word))))))
1275 ;;; not checked for linux...
1276 (defmacro fd-clr (offset fd-set)
1277 (let ((word (gensym))
1279 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1280 (setf (deref (slot ,fd-set 'fds-bits) ,word)
1281 (logand (deref (slot ,fd-set 'fds-bits) ,word)
1282 (sb!kernel:32bit-logical-not
1283 (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
1285 ;;; not checked for linux...
1286 (defmacro fd-isset (offset fd-set)
1287 (let ((word (gensym))
1289 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1290 (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
1292 ;;; not checked for linux...
1293 (defmacro fd-zero (fd-set)
1295 ,@(loop for index upfrom 0 below (/ fd-setsize 32)
1296 collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
1298 (/show0 "unix.lisp 3555")