src/code/unix.lisp

   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.
   7 ;;;;
   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.
  16
  17 ;;;; This software is part of the SBCL system. See the README file for
  18 ;;;; more information.
  19 ;;;;
  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.
  25
  26 (in-package "SB!UNIX")
  27
  28 (/show0 "unix.lisp 21")
  29
  30 (defmacro def-enum (inc cur &rest names)
  31   (flet ((defform (name)
  32            (prog1 (when name `(defconstant ,name ,cur))
  33              (setf cur (funcall inc cur 1)))))
  34     `(progn ,@(mapcar #'defform names))))
  35
  36 ;;; Given a C-level zero-terminated array of C strings, return a
  37 ;;; corresponding Lisp-level list of SIMPLE-STRINGs.
  38 (defun c-strings->string-list (c-strings)
  39   (declare (type (alien (* c-string)) c-strings))
  40   (let ((reversed-result nil))
  41     (dotimes (i most-positive-fixnum (error "argh! can't happen"))
  42       (declare (type index i))
  43       (let ((c-string (deref c-strings i)))
  44         (if c-string
  45             (push c-string reversed-result)
  46             (return (nreverse reversed-result)))))))
  47 \f
  48 ;;;; Lisp types used by syscalls
  49
  50 (deftype unix-pathname () 'simple-string)
  51 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
  52
  53 (deftype unix-file-mode () '(unsigned-byte 32))
  54 (deftype unix-pid () '(unsigned-byte 32))
  55 (deftype unix-uid () '(unsigned-byte 32))
  56 (deftype unix-gid () '(unsigned-byte 32))
  57 \f
  58 ;;;; system calls
  59
  60 (/show0 "unix.lisp 74")
  61
  62 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
  63 ;;; macros in this file, are only used in this file, and could be
  64 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
  65
  66 (defmacro syscall ((name &rest arg-types) success-form &rest args)
  67   `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
  68                                 ,@args)))
  69      (if (minusp result)
  70          (values nil (get-errno))
  71          ,success-form)))
  72
  73 ;;; This is like SYSCALL, but if it fails, signal an error instead of
  74 ;;; returning error codes. Should only be used for syscalls that will
  75 ;;; never really get an error.
  76 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
  77   `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
  78                                 ,@args)))
  79      (if (minusp result)
  80          (error "Syscall ~A failed: ~A" ,name (strerror))
  81          ,success-form)))
  82
  83 (/show0 "unix.lisp 109")
  84
  85 (defmacro void-syscall ((name &rest arg-types) &rest args)
  86   `(syscall (,name ,@arg-types) (values t 0) ,@args))
  87
  88 (defmacro int-syscall ((name &rest arg-types) &rest args)
  89   `(syscall (,name ,@arg-types) (values result 0) ,@args))
  90 \f
  91 ;;;; hacking the Unix environment
  92
  93 (def-alien-routine ("getenv" posix-getenv) c-string
  94   "Return the environment string \"name=value\" which corresponds to NAME, or
  95    NIL if there is none."
  96   (name c-string))
  97 \f
  98 ;;; from stdio.h
  99
 100 ;;; Rename the file with string NAME1 to the string NAME2. NIL and an
 101 ;;; error code is returned if an error occurs.
 102 (defun unix-rename (name1 name2)
 103   (declare (type unix-pathname name1 name2))
 104   (void-syscall ("rename" c-string c-string) name1 name2))
 105 \f
 106 ;;; from sys/types.h and gnu/types.h
 107
 108 (/show0 "unix.lisp 220")
 109
 110 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
 111 (defconstant +max-s-long+ 2147483647)
 112 (defconstant +max-u-long+ 4294967295)
 113 (def-alien-type quad-t #+nil long-long #-nil (array long 2))
 114 (def-alien-type uquad-t #+nil unsigned-long-long
 115                 #-nil (array unsigned-long 2))
 116 (def-alien-type qaddr-t (* quad-t))
 117 (def-alien-type daddr-t int)
 118 (def-alien-type caddr-t (* char))
 119 (def-alien-type swblk-t long)
 120 (def-alien-type size-t unsigned-int)
 121 (def-alien-type time-t long)
 122 (def-alien-type clock-t
 123   #!+linux long
 124   #!+bsd   unsigned-long)
 125 (def-alien-type uid-t unsigned-int)
 126 (def-alien-type ssize-t int)
 127
 128 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
 129 ;;; unless we have extreme provocation. Reading directories is not extreme
 130 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
 131 ;;; those functions in C as a wrapper layer.
 132 (def-alien-type fd-mask unsigned-long)
 133
 134 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
 135 (def-alien-type dev-t
 136   #!+linux uquad-t
 137   #!+bsd   unsigned-int)
 138 (def-alien-type uid-t unsigned-int)
 139 (def-alien-type gid-t unsigned-int)
 140 (def-alien-type ino-t
 141   #!+linux unsigned-long
 142   #!+bsd   unsigned-int)
 143 (def-alien-type mode-t
 144   #!+linux unsigned-int
 145   #!+bsd   unsigned-short)
 146 (def-alien-type nlink-t
 147   #!+linux unsigned-int
 148   #!+bsd   unsigned-short)
 149 (/show0 "unix.lisp 263")
 150
 151 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
 152 ;;; unless we have extreme provocation. Reading directories is not extreme
 153 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
 154 ;;; those functions in C as a wrapper layer.
 155
 156 (def-alien-type off-t
 157   #!+linux long
 158   #!+bsd   quad-t)
 159
 160 (defconstant fd-setsize 1024)
 161
 162 (def-alien-type nil
 163   (struct fd-set
 164           (fds-bits (array fd-mask #.(/ fd-setsize 32)))))
 165
 166 (/show0 "unix.lisp 304")
 167 \f
 168 ;;;; direntry.h
 169 ;;;; dirent.h
 170 ;;;;
 171 ;;;; (CMU CL copied stuff out of these, but as of 0.6.11.41, SBCL
 172 ;;;; doesn't need to, instead calling C-level wrapper code to handle
 173 ;;;; all the opendir/readdir/closedir stuff.)
 174 \f
 175 ;;;; fcntl.h
 176 ;;;;
 177 ;;;; POSIX Standard: 6.5 File Control Operations        <fcntl.h>
 178
 179 (/show0 "unix.lisp 356")
 180 (defconstant r_ok 4 #!+sb-doc "Test for read permission")
 181 (defconstant w_ok 2 #!+sb-doc "Test for write permission")
 182 (defconstant x_ok 1 #!+sb-doc "Test for execute permission")
 183 (defconstant f_ok 0 #!+sb-doc "Test for presence of file")
 184
 185 ;;; Open the file whose pathname is specified by PATH for reading
 186 ;;; and/or writing as specified by the FLAGS argument. Various FLAGS
 187 ;;; masks (O_RDONLY etc.) are defined in fcntlbits.h.
 188 ;;;
 189 ;;; If the O_CREAT flag is specified, then the file is created with a
 190 ;;; permission of argument MODE if the file doesn't exist. An integer
 191 ;;; file descriptor is returned by UNIX-OPEN.
 192 (defun unix-open (path flags mode)
 193   (declare (type unix-pathname path)
 194            (type fixnum flags)
 195            (type unix-file-mode mode))
 196   (int-syscall ("open" c-string int int) path flags mode))
 197
 198 ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file
 199 ;;; associated with it.
 200 (/show0 "unix.lisp 391")
 201 (defun unix-close (fd)
 202   (declare (type unix-fd fd))
 203   (void-syscall ("close" int) fd))
 204 \f
 205 ;;;; fcntlbits.h
 206
 207 (/show0 "unix.lisp 337")
 208 (defconstant o_rdonly  0) ; read-only flag
 209 (defconstant o_wronly  1) ; write-only flag
 210 (defconstant o_rdwr    2) ; read/write flag
 211 (defconstant o_accmode 3) ; access mode mask
 212 (defconstant o_creat ; create-if-nonexistent flag (not fcntl)
 213   #!+linux #o100
 214   #!+bsd   #x0200)
 215 (/show0 "unix.lisp 345")
 216 (defconstant o_excl ; error if already exists (not fcntl)
 217   #!+linux #o200
 218   #!+bsd   #x0800)
 219 (defconstant o_noctty ; Don't assign controlling tty. (not fcntl)
 220   #!+linux #o400
 221   #!+bsd   #x8000)
 222 (defconstant o_trunc ; truncation flag (not fcntl)
 223   #!+linux #o1000
 224   #!+bsd   #x0400)
 225 (defconstant o_append ; append flag
 226   #!+linux #o2000
 227   #!+bsd   #x0008)
 228 (/show0 "unix.lisp 361")
 229 \f
 230 ;;;; timebits.h
 231
 232 ;; A time value that is accurate to the nearest
 233 ;; microsecond but also has a range of years.
 234 (def-alien-type nil
 235   (struct timeval
 236           (tv-sec time-t)               ; seconds
 237           (tv-usec time-t)))            ; and microseconds
 238 \f
 239 ;;;; resourcebits.h
 240
 241 (defconstant rusage_self 0) ; the calling process
 242 (defconstant rusage_children -1) ; terminated child processes
 243 (defconstant rusage_both -2)
 244
 245 (def-alien-type nil
 246   (struct rusage
 247     (ru-utime (struct timeval))     ; user time used
 248     (ru-stime (struct timeval))     ; system time used.
 249     (ru-maxrss long)                ; maximum resident set size (in kilobytes)
 250     (ru-ixrss long)                 ; integral shared memory size
 251     (ru-idrss long)                 ; integral unshared data size
 252     (ru-isrss long)                 ; integral unshared stack size
 253     (ru-minflt long)                ; page reclaims
 254     (ru-majflt long)                ; page faults
 255     (ru-nswap long)                 ; swaps
 256     (ru-inblock long)               ; block input operations
 257     (ru-oublock long)               ; block output operations
 258     (ru-msgsnd long)                ; messages sent
 259     (ru-msgrcv long)                ; messages received
 260     (ru-nsignals long)              ; signals received
 261     (ru-nvcsw long)                 ; voluntary context switches
 262     (ru-nivcsw long)))              ; involuntary context switches
 263 \f
 264 ;;;; statbuf.h
 265
 266 ;;; FIXME: This should go into C code so that we don't need to hand-copy
 267 ;;; it from header files.
 268 #!+Linux
 269 (def-alien-type nil
 270   (struct stat
 271     (st-dev dev-t)
 272     (st-pad1 unsigned-short)
 273     (st-ino ino-t)
 274     (st-mode mode-t)
 275     (st-nlink  nlink-t)
 276     (st-uid  uid-t)
 277     (st-gid  gid-t)
 278     (st-rdev dev-t)
 279     (st-pad2  unsigned-short)
 280     (st-size off-t)
 281     (st-blksize unsigned-long)
 282     (st-blocks unsigned-long)
 283     (st-atime time-t)
 284     (unused-1 unsigned-long)
 285     (st-mtime time-t)
 286     (unused-2 unsigned-long)
 287     (st-ctime time-t)
 288     (unused-3 unsigned-long)
 289     (unused-4 unsigned-long)
 290     (unused-5 unsigned-long)))
 291
 292 #!+bsd
 293 (def-alien-type nil
 294   (struct timespec-t
 295     (tv-sec long)
 296     (tv-nsec long)))
 297
 298 #!+bsd
 299 (def-alien-type nil
 300   (struct stat
 301     (st-dev dev-t)
 302     (st-ino ino-t)
 303     (st-mode mode-t)
 304     (st-nlink nlink-t)
 305     (st-uid uid-t)
 306     (st-gid gid-t)
 307     (st-rdev dev-t)
 308     (st-atime (struct timespec-t))
 309     (st-mtime (struct timespec-t))
 310     (st-ctime (struct timespec-t))
 311     (st-size    unsigned-long)          ; really quad
 312     (st-sizeh   unsigned-long)          ;
 313     (st-blocks  unsigned-long)          ; really quad
 314     (st-blocksh unsigned-long)
 315     (st-blksize unsigned-long)
 316     (st-flags   unsigned-long)
 317     (st-gen     unsigned-long)
 318     (st-lspare  long)
 319     (st-qspare (array long 4))
 320     ))
 321
 322 ;; encoding of the file mode
 323
 324 ;;; These bits determine file type.
 325 (defconstant s-ifmt   #o0170000)
 326
 327 ;; basic file types, exist even on System V
 328 (defconstant s-ififo  #o0010000) ; FIFO
 329 (defconstant s-ifchr  #o0020000) ; Character device
 330 (defconstant s-ifdir  #o0040000) ; Directory
 331 (defconstant s-ifblk  #o0060000) ; Block device
 332 (defconstant s-ifreg  #o0100000) ; Regular file
 333
 334 ;; more file types: These don't actually exist on System V, but having
 335 ;; them doesn't hurt.
 336 (defconstant s-iflnk  #o0120000) ; Symbolic link
 337 (defconstant s-ifsock #o0140000) ; Socket
 338 \f
 339 ;;;; unistd.h
 340
 341 ;;; Given a file path (a string) and one of four constant modes,
 342 ;;; return T if the file is accessible with that mode and NIL if not.
 343 ;;; When NIL, also return an errno value with NIL which tells why the
 344 ;;; file was not accessible.
 345 ;;;
 346 ;;; The access modes are:
 347 ;;;   r_ok     Read permission.
 348 ;;;   w_ok     Write permission.
 349 ;;;   x_ok     Execute permission.
 350 ;;;   f_ok     Presence of file.
 351 (defun unix-access (path mode)
 352   (declare (type unix-pathname path)
 353            (type (mod 8) mode))
 354   (void-syscall ("access" c-string int) path mode))
 355
 356 ;;; values for the second argument to UNIX-LSEEK
 357 (defconstant l_set 0) ; to set the file pointer
 358 (defconstant l_incr 1) ; to increment the file pointer
 359 (defconstant l_xtnd 2) ; to extend the file size
 360
 361 ;;; Accept a file descriptor and move the file pointer ahead
 362 ;;; a certain offset for that file. WHENCE can be any of the following:
 363 ;;;  L_SET     Set the file pointer.
 364 ;;;  L_INCR    Increment the file pointer.
 365 ;;;  L_XTND    Extend the file size.
 366 (defun unix-lseek (fd offset whence)
 367   (declare (type unix-fd fd)
 368            (type (unsigned-byte 32) offset)
 369            (type (integer 0 2) whence))
 370   #!-(and x86 bsd)
 371   (int-syscall ("lseek" int off-t int) fd offset whence)
 372   ;; Need a 64-bit return value type for this. TBD. For now,
 373   ;; don't use this with any 2G+ partitions.
 374   #!+(and x86 bsd)
 375   (int-syscall ("lseek" int unsigned-long unsigned-long int)
 376                fd offset 0 whence))
 377
 378 ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
 379 ;;; It attempts to read len bytes from the device associated with fd
 380 ;;; and store them into the buffer. It returns the actual number of
 381 ;;; bytes read.
 382 (defun unix-read (fd buf len)
 383   (declare (type unix-fd fd)
 384            (type (unsigned-byte 32) len))
 385
 386   (int-syscall ("read" int (* char) int) fd buf len))
 387
 388 ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
 389 ;;; length to write. It attempts to write len bytes to the device
 390 ;;; associated with fd from the the buffer starting at offset. It returns
 391 ;;; the actual number of bytes written.
 392 (defun unix-write (fd buf offset len)
 393   (declare (type unix-fd fd)
 394            (type (unsigned-byte 32) offset len))
 395   (int-syscall ("write" int (* char) int)
 396                fd
 397                (with-alien ((ptr (* char) (etypecase buf
 398                                             ((simple-array * (*))
 399                                              (vector-sap buf))
 400                                             (system-area-pointer
 401                                              buf))))
 402                  (addr (deref ptr offset)))
 403                len))
 404
 405 ;;; Set up a unix-piping mechanism consisting of an input pipe and an
 406 ;;; output pipe. Return two values: if no error occurred the first
 407 ;;; value is the pipe to be read from and the second is can be written
 408 ;;; to. If an error occurred the first value is NIL and the second the
 409 ;;; unix error code.
 410 (defun unix-pipe ()
 411   (with-alien ((fds (array int 2)))
 412     (syscall ("pipe" (* int))
 413              (values (deref fds 0) (deref fds 1))
 414              (cast fds (* int)))))
 415
 416 ;;; UNIX-CHDIR accepts a directory name and makes that the
 417 ;;; current working directory.
 418 (defun unix-chdir (path)
 419   (declare (type unix-pathname path))
 420   (void-syscall ("chdir" c-string) path))
 421
 422 ;;; Return the current directory as a SIMPLE-STRING.
 423 (defun unix-current-directory ()
 424   ;; FIXME: Gcc justifiably complains that getwd is dangerous and should
 425   ;; not be used; especially with a hardwired 1024 buffer size, yecch.
 426   ;; This should be rewritten to use getcwd(3), perhaps by writing
 427   ;; a C service routine to do the actual call to getcwd(3) and check
 428   ;; of return values.
 429   (with-alien ((buf (array char 1024)))
 430     (values (not (zerop (alien-funcall (extern-alien "getwd"
 431                                                      (function int (* char)))
 432                                        (cast buf (* char)))))
 433             (cast buf c-string))))
 434
 435 ;;; Duplicate an existing file descriptor (given as the argument) and
 436 ;;; return it. If FD is not a valid file descriptor, NIL and an error
 437 ;;; number are returned.
 438 (defun unix-dup (fd)
 439   (declare (type unix-fd fd))
 440   (int-syscall ("dup" int) fd))
 441
 442 ;;; Terminate the current process with an optional error code. If
 443 ;;; successful, the call doesn't return. If unsuccessful, the call
 444 ;;; returns NIL and an error number.
 445 (defun unix-exit (&optional (code 0))
 446   (declare (type (signed-byte 32) code))
 447   (void-syscall ("exit" int) code))
 448
 449 ;;; Return the process id of the current process.
 450 (def-alien-routine ("getpid" unix-getpid) int)
 451
 452 ;;; Return the real user-id associated with the current process.
 453 (def-alien-routine ("getuid" unix-getuid) int)
 454
 455 ;;; Invoke readlink(2) on the file name specified by the simple string
 456 ;;; PATH. Return up to two values: the contents of the symbolic link
 457 ;;; if the call is successful, or NIL and the Unix error number.
 458 (defun unix-readlink (path)
 459   (declare (type unix-pathname path))
 460   (with-alien ((buf (array char 1024)))
 461     (syscall ("readlink" c-string (* char) int)
 462              (let ((string (make-string result)))
 463                (sb!kernel:copy-from-system-area
 464                 (alien-sap buf) 0
 465                 string (* sb!vm:vector-data-offset sb!vm:word-bits)
 466                 (* result sb!vm:byte-bits))
 467                string)
 468              path (cast buf (* char)) 1024)))
 469
 470 ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
 471 ;;; name and the file if this is the last link.
 472 (defun unix-unlink (name)
 473   (declare (type unix-pathname name))
 474   (void-syscall ("unlink" c-string) name))
 475
 476 ;;; Set the tty-process-group for the unix file-descriptor FD to PGRP.
 477 ;;; If not supplied, FD defaults to "/dev/tty".
 478 (defun %set-tty-process-group (pgrp &optional fd)
 479   (let ((old-sigs (unix-sigblock (sigmask :sigttou
 480                                           :sigttin
 481                                           :sigtstp
 482                                           :sigchld))))
 483     (declare (type (unsigned-byte 32) old-sigs))
 484     (unwind-protect
 485         (if fd
 486             (tcsetpgrp fd pgrp)
 487             (multiple-value-bind (tty-fd errno) (unix-open "/dev/tty" o_rdwr 0)
 488               (cond (tty-fd
 489                      (multiple-value-prog1
 490                          (tcsetpgrp tty-fd pgrp)
 491                        (unix-close tty-fd)))
 492                     (t
 493                      (values nil errno)))))
 494       (unix-sigsetmask old-sigs))))
 495
 496 ;;; Return the name of the host machine as a string.
 497 (defun unix-gethostname ()
 498   (with-alien ((buf (array char 256)))
 499     (syscall ("gethostname" (* char) int)
 500              (cast buf c-string)
 501              (cast buf (* char)) 256)))
 502
 503 ;;; Write the core image of the file described by FD to disk.
 504 (defun unix-fsync (fd)
 505   (declare (type unix-fd fd))
 506   (void-syscall ("fsync" int) fd))
 507 \f
 508 ;;;; sys/ioctl.h
 509
 510 ;;; UNIX-IOCTL performs a variety of operations on open i/o
 511 ;;; descriptors. See the UNIX Programmer's Manual for more
 512 ;;; information.
 513 (defun unix-ioctl (fd cmd arg)
 514   (declare (type unix-fd fd)
 515            (type (unsigned-byte 32) cmd))
 516   (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
 517 \f
 518 ;;;; sys/resource.h
 519
 520 ;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
 521 ;;;
 522 ;;; Like getrusage(2), but return only the system and user time,
 523 ;;; and return the seconds and microseconds as separate values.
 524 #!-sb-fluid (declaim (inline unix-fast-getrusage))
 525 (defun unix-fast-getrusage (who)
 526   (declare (values (member t)
 527                    (unsigned-byte 31) (mod 1000000)
 528                    (unsigned-byte 31) (mod 1000000)))
 529   (with-alien ((usage (struct rusage)))
 530     (syscall* ("getrusage" int (* (struct rusage)))
 531               (values t
 532                       (slot (slot usage 'ru-utime) 'tv-sec)
 533                       (slot (slot usage 'ru-utime) 'tv-usec)
 534                       (slot (slot usage 'ru-stime) 'tv-sec)
 535                       (slot (slot usage 'ru-stime) 'tv-usec))
 536               who (addr usage))))
 537
 538 ;;; Return information about the resource usage of the process
 539 ;;; specified by WHO. WHO can be either the current process
 540 ;;; (rusage_self) or all of the terminated child processes
 541 ;;; (rusage_children). NIL and an error number is returned if the call
 542 ;;; fails.
 543 (defun unix-getrusage (who)
 544   (with-alien ((usage (struct rusage)))
 545     (syscall ("getrusage" int (* (struct rusage)))
 546               (values t
 547                       (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
 548                          (slot (slot usage 'ru-utime) 'tv-usec))
 549                       (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
 550                          (slot (slot usage 'ru-stime) 'tv-usec))
 551                       (slot usage 'ru-maxrss)
 552                       (slot usage 'ru-ixrss)
 553                       (slot usage 'ru-idrss)
 554                       (slot usage 'ru-isrss)
 555                       (slot usage 'ru-minflt)
 556                       (slot usage 'ru-majflt)
 557                       (slot usage 'ru-nswap)
 558                       (slot usage 'ru-inblock)
 559                       (slot usage 'ru-oublock)
 560                       (slot usage 'ru-msgsnd)
 561                       (slot usage 'ru-msgrcv)
 562                       (slot usage 'ru-nsignals)
 563                       (slot usage 'ru-nvcsw)
 564                       (slot usage 'ru-nivcsw))
 565               who (addr usage))))
 566 \f
 567 ;;;; sys/select.h
 568
 569 (defmacro unix-fast-select (num-descriptors
 570                             read-fds write-fds exception-fds
 571                             timeout-secs &optional (timeout-usecs 0))
 572   #!+sb-doc
 573   "Perform the UNIX select(2) system call."
 574   (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
 575            (type (or (alien (* (struct fd-set))) null)
 576                  read-fds write-fds exception-fds)
 577            (type (or null (unsigned-byte 31)) timeout-secs)
 578            (type (unsigned-byte 31) timeout-usecs) )
 579   ;; FIXME: CMU CL had
 580   ;;   (optimize (speed 3) (safety 0) (inhibit-warnings 3))
 581   ;; in the declarations above. If they're important, they should
 582   ;; be in a declaration inside the LET expansion, not in the
 583   ;; macro compile-time code.
 584   `(let ((timeout-secs ,timeout-secs))
 585      (with-alien ((tv (struct timeval)))
 586        (when timeout-secs
 587          (setf (slot tv 'tv-sec) timeout-secs)
 588          (setf (slot tv 'tv-usec) ,timeout-usecs))
 589        (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
 590                      (* (struct fd-set)) (* (struct timeval)))
 591                     ,num-descriptors ,read-fds ,write-fds ,exception-fds
 592                     (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
 593
 594 ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
 595 ;;; to happen on one of them or to time out.
 596 (defmacro num-to-fd-set (fdset num)
 597   `(if (fixnump ,num)
 598        (progn
 599          (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
 600          ,@(loop for index upfrom 1 below (/ fd-setsize 32)
 601              collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
 602        (progn
 603          ,@(loop for index upfrom 0 below (/ fd-setsize 32)
 604              collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
 605                             (ldb (byte 32 ,(* index 32)) ,num))))))
 606
 607 (defmacro fd-set-to-num (nfds fdset)
 608   `(if (<= ,nfds 32)
 609        (deref (slot ,fdset 'fds-bits) 0)
 610        (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
 611               collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
 612                             ,(* index 32))))))
 613
 614 ;;; Examine the sets of descriptors passed as arguments to see whether
 615 ;;; they are ready for reading and writing. See the UNIX Programmer's
 616 ;;; Manual for more information.
 617 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
 618   (declare (type (integer 0 #.FD-SETSIZE) nfds)
 619            (type unsigned-byte rdfds wrfds xpfds)
 620            (type (or (unsigned-byte 31) null) to-secs)
 621            (type (unsigned-byte 31) to-usecs)
 622            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
 623   (with-alien ((tv (struct timeval))
 624                (rdf (struct fd-set))
 625                (wrf (struct fd-set))
 626                (xpf (struct fd-set)))
 627     (when to-secs
 628       (setf (slot tv 'tv-sec) to-secs)
 629      (setf (slot tv 'tv-usec) to-usecs))
 630     (num-to-fd-set rdf rdfds)
 631     (num-to-fd-set wrf wrfds)
 632     (num-to-fd-set xpf xpfds)
 633     (macrolet ((frob (lispvar alienvar)
 634                  `(if (zerop ,lispvar)
 635                       (int-sap 0)
 636                       (alien-sap (addr ,alienvar)))))
 637       (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
 638                 (* (struct fd-set)) (* (struct timeval)))
 639                (values result
 640                        (fd-set-to-num nfds rdf)
 641                        (fd-set-to-num nfds wrf)
 642                        (fd-set-to-num nfds xpf))
 643                nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
 644                (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
 645 \f
 646 ;;;; sys/stat.h
 647
 648 ;;; FIXME: This is only used in this file, and needn't be in target Lisp
 649 ;;; runtime. It's also unclear why it needs to be a macro instead of a
 650 ;;; function. Perhaps it should become a FLET.
 651 (defmacro extract-stat-results (buf)
 652   `(values T
 653            #!+bsd
 654            (slot ,buf 'st-dev)
 655            #!+linux
 656            (+ (deref (slot ,buf 'st-dev) 0)
 657               (* (+ +max-u-long+  1)
 658                  (deref (slot ,buf 'st-dev) 1)))   ;;; let's hope this works..
 659            (slot ,buf 'st-ino)
 660            (slot ,buf 'st-mode)
 661            (slot ,buf 'st-nlink)
 662            (slot ,buf 'st-uid)
 663            (slot ,buf 'st-gid)
 664            #!+bsd
 665            (slot ,buf 'st-rdev)
 666            #!+linux
 667            (+ (deref (slot ,buf 'st-rdev) 0)
 668               (* (+ +max-u-long+  1)
 669                  (deref (slot ,buf 'st-rdev) 1)))   ;;; let's hope this works..
 670            #!+linux (slot ,buf 'st-size)
 671            #!+bsd
 672            (+ (slot ,buf 'st-size)
 673               (* (+ +max-u-long+ 1)
 674                  (slot ,buf 'st-sizeh)))
 675            #!+linux (slot ,buf 'st-atime)
 676            #!+bsd   (slot (slot ,buf 'st-atime) 'tv-sec)
 677            #!+linux (slot ,buf 'st-mtime)
 678            #!+bsd   (slot (slot ,buf 'st-mtime) 'tv-sec)
 679            #!+linux (slot ,buf 'st-ctime)
 680            #!+bsd   (slot (slot ,buf 'st-ctime) 'tv-sec)
 681            (slot ,buf 'st-blksize)
 682            #!+linux (slot ,buf 'st-blocks)
 683            #!+bsd
 684            (+ (slot ,buf 'st-blocks)
 685               (* (+ +max-u-long+ 1)
 686                  (slot ,buf 'st-blocksh)))
 687            ))
 688
 689 ;;; Retrieve information about the specified file returning them in
 690 ;;; the form of multiple values. See the UNIX Programmer's Manual for
 691 ;;; a description of the values returned. If the call fails, then NIL
 692 ;;; and an error number is returned instead.
 693 (defun unix-stat (name)
 694   (declare (type unix-pathname name))
 695   (when (string= name "")
 696     (setf name "."))
 697   (with-alien ((buf (struct stat)))
 698     (syscall ("stat" c-string (* (struct stat)))
 699              (extract-stat-results buf)
 700              name (addr buf))))
 701
 702 ;;; like UNIX-STAT except the file is specified by the file descriptor FD
 703 (defun unix-fstat (fd)
 704   (declare (type unix-fd fd))
 705   (with-alien ((buf (struct stat)))
 706     (syscall ("fstat" int (* (struct stat)))
 707              (extract-stat-results buf)
 708              fd (addr buf))))
 709
 710 ;;; like UNIX-STAT except the specified file must be a symbolic link
 711 (defun unix-lstat (name)
 712   (declare (type unix-pathname name))
 713   (with-alien ((buf (struct stat)))
 714     (syscall ("lstat" c-string (* (struct stat)))
 715              (extract-stat-results buf)
 716              name (addr buf))))
 717
 718 ;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
 719 ;;; corresponding directory with mode mode.
 720 (defun unix-mkdir (name mode)
 721   (declare (type unix-pathname name)
 722            (type unix-file-mode mode))
 723   (void-syscall ("mkdir" c-string int) name mode))
 724 \f
 725 ;;;; time.h
 726
 727 ;; the POSIX.4 structure for a time value. This is like a `struct
 728 ;; timeval' but has nanoseconds instead of microseconds.
 729 (def-alien-type nil
 730     (struct timespec
 731             (tv-sec long)   ;Seconds
 732             (tv-nsec long))) ;Nanoseconds
 733
 734 ;; used by other time functions
 735 (def-alien-type nil
 736     (struct tm
 737             (tm-sec int)   ; Seconds.   [0-60] (1 leap second)
 738             (tm-min int)   ; Minutes.   [0-59]
 739             (tm-hour int)  ; Hours.     [0-23]
 740             (tm-mday int)  ; Day.               [1-31]
 741             (tm-mon int)   ;  Month.    [0-11]
 742             (tm-year int)  ; Year       - 1900.
 743             (tm-wday int)  ; Day of week.       [0-6]
 744             (tm-yday int)  ; Days in year.[0-365]
 745             (tm-isdst int) ;  DST.              [-1/0/1]
 746             (tm-gmtoff long)    ;  Seconds east of UTC.
 747             (tm-zone c-string)))        ; Timezone abbreviation.
 748
 749 (def-alien-routine get-timezone sb!c-call:void
 750   (when sb!c-call:long :in)
 751   (minutes-west sb!c-call:int :out)
 752   (daylight-savings-p sb!alien:boolean :out))
 753
 754 (defun unix-get-minutes-west (secs)
 755   (multiple-value-bind (ignore minutes dst) (get-timezone secs)
 756     (declare (ignore ignore) (ignore dst))
 757     (values minutes)))
 758
 759 (defun unix-get-timezone (secs)
 760   (multiple-value-bind (ignore minutes dst) (get-timezone secs)
 761     (declare (ignore ignore) (ignore minutes))
 762     (values (deref unix-tzname (if dst 1 0)))))
 763
 764 \f
 765 ;;;; sys/time.h
 766
 767 ;;; Structure crudely representing a timezone. KLUDGE: This is
 768 ;;; obsolete and should never be used.
 769 (def-alien-type nil
 770   (struct timezone
 771     (tz-minuteswest int)                ; minutes west of Greenwich
 772     (tz-dsttime int)))                  ; type of dst correction
 773
 774 ;;; If it works, UNIX-GETTIMEOFDAY returns 5 values: T, the seconds
 775 ;;; and microseconds of the current time of day, the timezone (in
 776 ;;; minutes west of Greenwich), and a daylight-savings flag. If it
 777 ;;; doesn't work, it returns NIL and the errno.
 778 #!-sb-fluid (declaim (inline unix-gettimeofday))
 779 (defun unix-gettimeofday ()
 780   (with-alien ((tv (struct timeval))
 781                (tz (struct timezone)))
 782     (syscall* ("gettimeofday" (* (struct timeval))
 783                               (* (struct timezone)))
 784               (values T
 785                       (slot tv 'tv-sec)
 786                       (slot tv 'tv-usec)
 787                       (slot tz 'tz-minuteswest)
 788                       (slot tz 'tz-dsttime))
 789               (addr tv)
 790               (addr tz))))
 791 \f
 792 ;;;; asm/errno.h
 793
 794 (defconstant ENOENT 2) ; Unix error code, "No such file or directory"
 795 (defconstant EINTR 4) ; Unix error code, "Interrupted system call"
 796 (defconstant EIO 5) ; Unix error code, "I/O error"
 797 (defconstant EEXIST 17) ; Unix error code, "File exists"
 798 (defconstant ESPIPE 29) ; Unix error code, "Illegal seek"
 799 (defconstant EWOULDBLOCK 11) ; Unix error code, "Operation would block"
 800 ;;; FIXME: Many Unix error code definitions were deleted from the old
 801 ;;; CMU CL source code here, but not in the exports of SB-UNIX. I
 802 ;;; (WHN) hope that someday I'll figure out an automatic way to detect
 803 ;;; unused symbols in package exports, but if I don't, there are
 804 ;;; enough of them all in one place here that they should probably be
 805 ;;; removed by hand.
 806 \f
 807 ;;;; support routines for dealing with Unix pathnames
 808
 809 (defun unix-file-kind (name &optional check-for-links)
 810   #!+sb-doc
 811   "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
 812   (declare (simple-string name))
 813   (multiple-value-bind (res dev ino mode)
 814       (if check-for-links (unix-lstat name) (unix-stat name))
 815     (declare (type (or fixnum null) mode)
 816              (ignore dev ino))
 817     (when res
 818       (let ((kind (logand mode s-ifmt)))
 819         (cond ((eql kind s-ifdir) :directory)
 820               ((eql kind s-ifreg) :file)
 821               ((eql kind s-iflnk) :link)
 822               (t :special))))))
 823
 824 (defun unix-maybe-prepend-current-directory (name)
 825   (declare (simple-string name))
 826   (if (and (> (length name) 0) (char= (schar name 0) #\/))
 827       name
 828       (multiple-value-bind (win dir) (unix-current-directory)
 829         (if win
 830             (concatenate 'simple-string dir "/" name)
 831             name))))
 832
 833 ;;; Return the pathname with all symbolic links resolved.
 834 ;;;
 835 ;;; FIXME: Could we just use Unix readlink(2) instead?
 836 (defun unix-resolve-links (pathname)
 837   (declare (simple-string pathname))
 838   (let ((len (length pathname))
 839         (pending pathname))
 840     (declare (fixnum len) (simple-string pending))
 841     (if (zerop len)
 842         pathname
 843         (let ((result (make-string 1024 :initial-element (code-char 0)))
 844               (fill-ptr 0)
 845               (name-start 0))
 846           (loop
 847             (let* ((name-end (or (position #\/ pending :start name-start) len))
 848                    (new-fill-ptr (+ fill-ptr (- name-end name-start))))
 849               (replace result pending
 850                        :start1 fill-ptr
 851                        :end1 new-fill-ptr
 852                        :start2 name-start
 853                        :end2 name-end)
 854               (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t)))
 855                 (unless kind (return nil))
 856                 (cond ((eq kind :link)
 857                        (multiple-value-bind (link err) (unix-readlink result)
 858                          (unless link
 859                            (error 'simple-file-error
 860                                   :pathname pathname
 861                                   :format-control
 862                                   "~@<error reading link ~S: ~2I~_~A~:>"
 863                                   :format-arguments (list (subseq
 864                                                            result 0 fill-ptr)
 865                                                           (strerror err))))
 866                          (cond ((or (zerop (length link))
 867                                     (char/= (schar link 0) #\/))
 868                                 ;; It's a relative link.
 869                                 (fill result (code-char 0)
 870                                       :start fill-ptr
 871                                       :end new-fill-ptr))
 872                                ((string= result "/../" :end1 4)
 873                                 ;; It's across the super-root.
 874                                 (let ((slash (or (position #\/ result :start 4)
 875                                                  0)))
 876                                   (fill result (code-char 0)
 877                                         :start slash
 878                                         :end new-fill-ptr)
 879                                   (setf fill-ptr slash)))
 880                                (t
 881                                 ;; It's absolute.
 882                                 (and (> (length link) 0)
 883                                      (char= (schar link 0) #\/))
 884                                 (fill result (code-char 0) :end new-fill-ptr)
 885                                 (setf fill-ptr 0)))
 886                          (setf pending
 887                                (if (= name-end len)
 888                                    link
 889                                    (concatenate 'simple-string
 890                                                 link
 891                                                 (subseq pending name-end))))
 892                          (setf len (length pending))
 893                          (setf name-start 0)))
 894                       ((= name-end len)
 895                        (return (subseq result 0 new-fill-ptr)))
 896                       ((eq kind :directory)
 897                        (setf (schar result new-fill-ptr) #\/)
 898                        (setf fill-ptr (1+ new-fill-ptr))
 899                        (setf name-start (1+ name-end)))
 900                       (t
 901                        (return nil))))))))))
 902
 903 (defun unix-simplify-pathname (src)
 904   (declare (simple-string src))
 905   (let* ((src-len (length src))
 906          (dst (make-string src-len))
 907          (dst-len 0)
 908          (dots 0)
 909          (last-slash nil))
 910     (macrolet ((deposit (char)
 911                         `(progn
 912                            (setf (schar dst dst-len) ,char)
 913                            (incf dst-len))))
 914       (dotimes (src-index src-len)
 915         (let ((char (schar src src-index)))
 916           (cond ((char= char #\.)
 917                  (when dots
 918                    (incf dots))
 919                  (deposit char))
 920                 ((char= char #\/)
 921                  (case dots
 922                    (0
 923                     ;; Either ``/...' or ``...//...'
 924                     (unless last-slash
 925                       (setf last-slash dst-len)
 926                       (deposit char)))
 927                    (1
 928                     ;; Either ``./...'' or ``..././...''
 929                     (decf dst-len))
 930                    (2
 931                     ;; We've found ..
 932                     (cond
 933                      ((and last-slash (not (zerop last-slash)))
 934                       ;; There is something before this ..
 935                       (let ((prev-prev-slash
 936                              (position #\/ dst :end last-slash :from-end t)))
 937                         (cond ((and (= (+ (or prev-prev-slash 0) 2)
 938                                        last-slash)
 939                                     (char= (schar dst (- last-slash 2)) #\.)
 940                                     (char= (schar dst (1- last-slash)) #\.))
 941                                ;; The something before this .. is another ..
 942                                (deposit char)
 943                                (setf last-slash dst-len))
 944                               (t
 945                                ;; The something is some directory or other.
 946                                (setf dst-len
 947                                      (if prev-prev-slash
 948                                          (1+ prev-prev-slash)
 949                                          0))
 950                                (setf last-slash prev-prev-slash)))))
 951                      (t
 952                       ;; There is nothing before this .., so we need to keep it
 953                       (setf last-slash dst-len)
 954                       (deposit char))))
 955                    (t
 956                     ;; Something other than a dot between slashes.
 957                     (setf last-slash dst-len)
 958                     (deposit char)))
 959                  (setf dots 0))
 960                 (t
 961                  (setf dots nil)
 962                  (setf (schar dst dst-len) char)
 963                  (incf dst-len))))))
 964     (when (and last-slash (not (zerop last-slash)))
 965       (case dots
 966         (1
 967          ;; We've got  ``foobar/.''
 968          (decf dst-len))
 969         (2
 970          ;; We've got ``foobar/..''
 971          (unless (and (>= last-slash 2)
 972                       (char= (schar dst (1- last-slash)) #\.)
 973                       (char= (schar dst (- last-slash 2)) #\.)
 974                       (or (= last-slash 2)
 975                           (char= (schar dst (- last-slash 3)) #\/)))
 976            (let ((prev-prev-slash
 977                   (position #\/ dst :end last-slash :from-end t)))
 978              (if prev-prev-slash
 979                  (setf dst-len (1+ prev-prev-slash))
 980                  (return-from unix-simplify-pathname "./")))))))
 981     (cond ((zerop dst-len)
 982            "./")
 983           ((= dst-len src-len)
 984            dst)
 985           (t
 986            (subseq dst 0 dst-len)))))
 987 \f
 988 ;;;; stuff not yet found in the header files
 989 ;;;;
 990 ;;;; Abandon all hope who enters here...
 991
 992 ;;; not checked for linux...
 993 (defmacro fd-set (offset fd-set)
 994   (let ((word (gensym))
 995         (bit (gensym)))
 996     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
 997        (setf (deref (slot ,fd-set 'fds-bits) ,word)
 998              (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
 999                      (deref (slot ,fd-set 'fds-bits) ,word))))))
1000
1001 ;;; not checked for linux...
1002 (defmacro fd-clr (offset fd-set)
1003   (let ((word (gensym))
1004         (bit (gensym)))
1005     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1006        (setf (deref (slot ,fd-set 'fds-bits) ,word)
1007              (logand (deref (slot ,fd-set 'fds-bits) ,word)
1008                      (sb!kernel:32bit-logical-not
1009                       (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
1010
1011 ;;; not checked for linux...
1012 (defmacro fd-isset (offset fd-set)
1013   (let ((word (gensym))
1014         (bit (gensym)))
1015     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1016        (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
1017
1018 ;;; not checked for linux...
1019 (defmacro fd-zero (fd-set)
1020   `(progn
1021      ,@(loop for index upfrom 0 below (/ fd-setsize 32)
1022          collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
1023
1024 (/show0 "unix.lisp 3555")