src/code/unix.lisp

   1 ;;;; This file contains Unix support that SBCL needs to implement itself. It's
   2 ;;;; derived from Peter Van Eynde's unix-glibc2.lisp for CMU CL, which was
   3 ;;;; derived from CMU CL unix.lisp 1.56. But those files aspired to be complete
   4 ;;;; Unix interfaces exported to the end user, while this file aims to be as
   5 ;;;; simple as possible and is not intended for the end user.
   6 ;;;;
   7 ;;;; FIXME: The old CMU CL unix.lisp code was implemented as hand
   8 ;;;; transcriptions from Unix headers into Lisp. It appears that this was as
   9 ;;;; unmaintainable in practice as you'd expect in theory, so I really really
  10 ;;;; don't want to do that. It'd be good to implement the various system calls
  11 ;;;; as C code implemented using the Unix header files, and have their
  12 ;;;; interface back to SBCL code be characterized by things like "32-bit-wide
  13 ;;;; int" which are already in the interface between the runtime
  14 ;;;; executable and the SBCL lisp code.
  15
  16 ;;;; This software is part of the SBCL system. See the README file for
  17 ;;;; more information.
  18 ;;;;
  19 ;;;; This software is derived from the CMU CL system, which was
  20 ;;;; written at Carnegie Mellon University and released into the
  21 ;;;; public domain. The software is in the public domain and is
  22 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  23 ;;;; files for more information.
  24
  25 (in-package "SB!UNIX")
  26
  27 (/show0 "unix.lisp 21")
  28
  29 ;;;; common machine-independent structures
  30
  31 (eval-when (:compile-toplevel :execute)
  32
  33 (defparameter *compiler-unix-errors* nil)
  34
  35 (/show0 "unix.lisp 29")
  36
  37 (sb!xc:defmacro def-unix-error (name number description)
  38   `(progn
  39      (eval-when (:compile-toplevel :execute)
  40        (push (cons ,number ,description) *compiler-unix-errors*))
  41      (eval-when (:compile-toplevel :load-toplevel :execute)
  42        (defconstant ,name ,number ,description))))
  43
  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)))
  49     `(progn
  50        (defvar *unix-errors* ',array)
  51        (proclaim '(simple-vector *unix-errors*)))))
  52
  53 ) ; EVAL-WHEN
  54
  55 (defvar *unix-errors*)
  56
  57 (/show0 "unix.lisp 52")
  58
  59 (defmacro def-enum (inc cur &rest names)
  60   (flet ((defform (name)
  61            (prog1 (when name `(defconstant ,name ,cur))
  62              (setf cur (funcall inc cur 1)))))
  63     `(progn ,@(mapcar #'defform names))))
  64 \f
  65 ;;;; Lisp types used by syscalls
  66
  67 (deftype unix-pathname () 'simple-string)
  68 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
  69
  70 (deftype unix-file-mode () '(unsigned-byte 32))
  71 (deftype unix-pid () '(unsigned-byte 32))
  72 (deftype unix-uid () '(unsigned-byte 32))
  73 (deftype unix-gid () '(unsigned-byte 32))
  74 \f
  75 ;;;; system calls
  76
  77 (def-alien-routine ("os_get_errno" get-errno) integer
  78   "Return the value of the C library pseudo-variable named \"errno\".")
  79
  80 (/show0 "unix.lisp 74")
  81
  82 (defun get-unix-error-msg (&optional (error-number (get-errno)))
  83   #!+sb-doc
  84   "Returns a string describing the error number which was returned by a
  85   UNIX system call."
  86   (declare (type integer error-number))
  87   (if (array-in-bounds-p *unix-errors* error-number)
  88       (svref *unix-errors* error-number)
  89       (format nil "unknown error [~D]" error-number)))
  90
  91 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
  92 ;;; macros in this file, are only used in this file, and could be
  93 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
  94
  95 (defmacro syscall ((name &rest arg-types) success-form &rest args)
  96   `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
  97                                 ,@args)))
  98      (if (minusp result)
  99          (values nil (get-errno))
 100          ,success-form)))
 101
 102 ;;; Like SYSCALL, but if it fails, signal an error instead of returning error
 103 ;;; codes. Should only be used for syscalls that will never really get an
 104 ;;; error.
 105 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
 106   `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
 107                                 ,@args)))
 108      (if (minusp result)
 109          (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
 110          ,success-form)))
 111
 112 (/show0 "unix.lisp 109")
 113
 114 (defmacro void-syscall ((name &rest arg-types) &rest args)
 115   `(syscall (,name ,@arg-types) (values t 0) ,@args))
 116
 117 (defmacro int-syscall ((name &rest arg-types) &rest args)
 118   `(syscall (,name ,@arg-types) (values result 0) ,@args))
 119 \f
 120 ;;; from stdio.h
 121
 122 (/show0 "unix.lisp 124")
 123
 124 (defun unix-rename (name1 name2)
 125   #!+sb-doc
 126   "Unix-rename renames the file with string name1 to the string
 127    name2. NIL and an error code is returned if an error occurs."
 128   (declare (type unix-pathname name1 name2))
 129   (void-syscall ("rename" c-string c-string) name1 name2))
 130 \f
 131 ;;; from stdlib.h
 132
 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."
 136   (name c-string))
 137 \f
 138 ;;; from sys/types.h and gnu/types.h
 139
 140 (/show0 "unix.lisp 144")
 141
 142 (defconstant +max-s-long+ 2147483647)
 143 (defconstant +max-u-long+ 4294967295)
 144
 145 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
 146 (def-alien-type quad-t #+nil long-long #-nil (array long 2))
 147 (def-alien-type uquad-t #+nil unsigned-long-long
 148                 #-nil (array unsigned-long 2))
 149 (def-alien-type qaddr-t (* quad-t))
 150 (def-alien-type daddr-t int)
 151 (def-alien-type caddr-t (* char))
 152 (def-alien-type swblk-t long)
 153 (def-alien-type size-t unsigned-int)
 154 (def-alien-type time-t long)
 155 (def-alien-type clock-t
 156   #!+linux long
 157   #!+bsd   unsigned-long)
 158 (def-alien-type uid-t unsigned-int)
 159 (def-alien-type ssize-t int)
 160
 161 (/show0 "unix.lisp 163")
 162
 163 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
 164 ;;; unless we have extreme provocation. Reading directories is not extreme
 165 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
 166 ;;; those functions in C as a wrapper layer.
 167 (def-alien-type fd-mask unsigned-long)
 168 (/show0 "unix.lisp 171")
 169
 170 ;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
 171 (def-alien-type dev-t
 172   #!+linux uquad-t
 173   #!+bsd   unsigned-int)
 174 (def-alien-type uid-t unsigned-int)
 175 (def-alien-type gid-t unsigned-int)
 176 (def-alien-type ino-t
 177   #!+linux unsigned-long
 178   #!+bsd   unsigned-int)
 179 (def-alien-type mode-t
 180   #!+linux unsigned-int
 181   #!+bsd   unsigned-short)
 182 (def-alien-type nlink-t
 183   #!+linux unsigned-int
 184   #!+bsd   unsigned-short)
 185 (/show0 "unix.lisp 190")
 186
 187 ;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
 188 ;;; unless we have extreme provocation. Reading directories is not extreme
 189 ;;; enough, since it doesn't need to be blindingly fast: we can just implement
 190 ;;; those functions in C as a wrapper layer.
 191
 192 (def-alien-type off-t
 193   #!+linux long
 194   #!+bsd   quad-t)
 195
 196 (eval-when (:compile-toplevel :load-toplevel :execute)
 197   (/show0 "unix.lisp 215")
 198   (defconstant fd-setsize 1024))
 199 (/show0 "unix.lisp 217")
 200
 201 (def-alien-type nil
 202   (struct fd-set
 203           (fds-bits (array fd-mask #.(/ fd-setsize 32)))))
 204
 205 (/show0 "unix.lisp 223")
 206 \f
 207 ;;;; direntry.h
 208
 209 (def-alien-type nil
 210   (struct direct
 211     (d-ino long); inode number of entry
 212     (d-off off-t)                       ; offset of next disk directory entry
 213     (d-reclen unsigned-short)           ; length of this record
 214     (d_type unsigned-char)
 215     (d-name (array char 256))))         ; name must be no longer than this
 216 (/show0 "unix.lisp 241")
 217 \f
 218 ;;;; dirent.h
 219
 220 ;;; operations on Unix directories
 221
 222 ;;;; FIXME: It might be really nice to implement these in C, so that
 223 ;;;; we don't need to do horrible things like hand-copying the
 224 ;;;; direntry struct slot types into an alien struct.
 225
 226 ;;; FIXME: DIRECTORY is an external symbol of package CL, so we should use some
 227 ;;; other name for this low-level implementation type.
 228 (defstruct directory
 229   name
 230   (dir-struct (required-argument) :type system-area-pointer))
 231 (/show0 "unix.lisp 258")
 232
 233 (def!method print-object ((dir directory) stream)
 234   (print-unreadable-object (dir stream :type t)
 235     (prin1 (directory-name dir) stream)))
 236
 237 (/show0 "unix.lisp 264")
 238 (defun open-dir (pathname)
 239   (declare (type unix-pathname pathname))
 240   (when (string= pathname "")
 241     (setf pathname "."))
 242   (let ((kind (unix-file-kind pathname)))
 243     (case kind
 244       (:directory
 245        (let ((dir-struct
 246               (alien-funcall (extern-alien "opendir"
 247                                            (function system-area-pointer
 248                                                      c-string))
 249                              pathname)))
 250          (if (zerop (sap-int dir-struct))
 251              (values nil (get-errno))
 252              (make-directory :name pathname :dir-struct dir-struct))))
 253       ((nil)
 254        (values nil enoent))
 255       (t
 256        (values nil enotdir)))))
 257 (/show0 "unix.lisp 286")
 258
 259 (defun read-dir (dir)
 260   (declare (type directory dir))
 261   (let ((daddr (alien-funcall (extern-alien "readdir"
 262                                             (function system-area-pointer
 263                                                       system-area-pointer))
 264                               (directory-dir-struct dir))))
 265     (declare (type system-area-pointer daddr))
 266     (if (zerop (sap-int daddr))
 267         nil
 268         (with-alien ((direct (* (struct direct)) daddr))
 269           (values (cast (slot direct 'd-name) c-string)
 270                   (slot direct 'd-ino))))))
 271
 272 (/show0 "unix.lisp 301")
 273 (defun close-dir (dir)
 274   (declare (type directory dir))
 275   (alien-funcall (extern-alien "closedir"
 276                                (function void system-area-pointer))
 277                  (directory-dir-struct dir))
 278   nil)
 279
 280 ;;; dlfcn.h -> in foreign.lisp
 281
 282 ;;; fcntl.h
 283 ;;;
 284 ;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
 285
 286 (/show0 "unix.lisp 318")
 287 (defconstant r_ok 4 #!+sb-doc "Test for read permission")
 288 (defconstant w_ok 2 #!+sb-doc "Test for write permission")
 289 (defconstant x_ok 1 #!+sb-doc "Test for execute permission")
 290 (defconstant f_ok 0 #!+sb-doc "Test for presence of file")
 291
 292 (/show0 "unix.lisp 352")
 293 (defun unix-open (path flags mode)
 294   #!+sb-doc
 295   "Unix-open opens the file whose pathname is specified by path
 296    for reading and/or writing as specified by the flags argument.
 297    The flags argument can be:
 298
 299      o_rdonly   Read-only flag.
 300      o_wronly   Write-only flag.
 301      o_rdwr       Read-and-write flag.
 302      o_append   Append flag.
 303      o_creat     Create-if-nonexistent flag.
 304      o_trunc     Truncate-to-size-0 flag.
 305      o_excl       Error if the file allready exists
 306      o_noctty   Don't assign controlling tty
 307      o_ndelay   Non-blocking I/O
 308      o_sync       Synchronous I/O
 309      o_async     Asynchronous I/O
 310
 311    If the o_creat flag is specified, then the file is created with
 312    a permission of argument mode if the file doesn't exist. An
 313    integer file descriptor is returned by unix-open."
 314   (declare (type unix-pathname path)
 315            (type fixnum flags)
 316            (type unix-file-mode mode))
 317   (int-syscall ("open" c-string int int) path flags mode))
 318
 319 ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file
 320 ;;; associated with it.
 321 (/show0 "unix.lisp 391")
 322 (defun unix-close (fd)
 323   #!+sb-doc
 324   "Unix-close takes an integer file descriptor as an argument and
 325    closes the file associated with it. T is returned upon successful
 326    completion, otherwise NIL and an error number."
 327   (declare (type unix-fd fd))
 328   (void-syscall ("close" int) fd))
 329 \f
 330 ;;; fcntlbits.h
 331 (eval-when (:compile-toplevel :load-toplevel :execute)
 332
 333 (/show0 "unix.lisp 337")
 334 (defconstant o_rdonly  0) ; read-only flag
 335 (defconstant o_wronly  1) ; write-only flag
 336 (defconstant o_rdwr    2) ; read/write flag
 337 (defconstant o_accmode 3) ; access mode mask
 338 (defconstant o_creat ; create-if-nonexistent flag (not fcntl)
 339   #!+linux #o100
 340   #!+bsd   #x0200)
 341 (/show0 "unix.lisp 345")
 342 (defconstant o_excl ; error if already exists (not fcntl)
 343   #!+linux #o200
 344   #!+bsd   #x0800)
 345 (defconstant o_noctty ; Don't assign controlling tty. (not fcntl)
 346   #!+linux #o400
 347   #!+bsd   #x8000)
 348 (defconstant o_trunc ; truncation flag (not fcntl)
 349   #!+linux #o1000
 350   #!+bsd   #x0400)
 351 (defconstant o_append ; append flag
 352   #!+linux #o2000
 353   #!+bsd   #x0008)
 354 (/show0 "unix.lisp 361")
 355 ) ; EVAL-WHEN
 356 \f
 357 ;;;; timebits.h
 358
 359 ;; A time value that is accurate to the nearest
 360 ;; microsecond but also has a range of years.
 361 (def-alien-type nil
 362   (struct timeval
 363           (tv-sec time-t)               ; seconds
 364           (tv-usec time-t)))            ; and microseconds
 365 \f
 366 ;;;; resourcebits.h
 367
 368 (defconstant rusage_self 0 #!+sb-doc "The calling process.")
 369 (defconstant rusage_children -1 #!+sb-doc "Terminated child processes.")
 370 (defconstant rusage_both -2)
 371
 372 (def-alien-type nil
 373   (struct rusage
 374     (ru-utime (struct timeval))         ; user time used
 375     (ru-stime (struct timeval))         ; system time used.
 376     (ru-maxrss long)                ; Maximum resident set size (in kilobytes)
 377     (ru-ixrss long)                     ; integral shared memory size
 378     (ru-idrss long)                     ; integral unshared data size
 379     (ru-isrss long)                     ; integral unshared stack size
 380     (ru-minflt long)                    ; page reclaims
 381     (ru-majflt long)                    ; page faults
 382     (ru-nswap long)                     ; swaps
 383     (ru-inblock long)                   ; block input operations
 384     (ru-oublock long)                   ; block output operations
 385     (ru-msgsnd long)                    ; messages sent
 386     (ru-msgrcv long)                    ; messages received
 387     (ru-nsignals long)                  ; signals received
 388     (ru-nvcsw long)                     ; voluntary context switches
 389     (ru-nivcsw long)))                  ; involuntary context switches
 390 \f
 391 ;;;; statbuf.h
 392
 393 ;;; FIXME: This should go into C code so that we don't need to hand-copy
 394 ;;; it from header files.
 395 #!+Linux
 396 (def-alien-type nil
 397   (struct stat
 398     (st-dev dev-t)
 399     (st-pad1 unsigned-short)
 400     (st-ino ino-t)
 401     (st-mode mode-t)
 402     (st-nlink  nlink-t)
 403     (st-uid  uid-t)
 404     (st-gid  gid-t)
 405     (st-rdev dev-t)
 406     (st-pad2  unsigned-short)
 407     (st-size off-t)
 408     (st-blksize unsigned-long)
 409     (st-blocks unsigned-long)
 410     (st-atime time-t)
 411     (unused-1 unsigned-long)
 412     (st-mtime time-t)
 413     (unused-2 unsigned-long)
 414     (st-ctime time-t)
 415     (unused-3 unsigned-long)
 416     (unused-4 unsigned-long)
 417     (unused-5 unsigned-long)))
 418
 419 #!+bsd
 420 (def-alien-type nil
 421   (struct timespec-t
 422     (tv-sec long)
 423     (tv-nsec long)))
 424
 425 #!+bsd
 426 (def-alien-type nil
 427   (struct stat
 428     (st-dev dev-t)
 429     (st-ino ino-t)
 430     (st-mode mode-t)
 431     (st-nlink nlink-t)
 432     (st-uid uid-t)
 433     (st-gid gid-t)
 434     (st-rdev dev-t)
 435     (st-atime (struct timespec-t))
 436     (st-mtime (struct timespec-t))
 437     (st-ctime (struct timespec-t))
 438     (st-size    unsigned-long)          ; really quad
 439     (st-sizeh   unsigned-long)          ;
 440     (st-blocks  unsigned-long)          ; really quad
 441     (st-blocksh unsigned-long)
 442     (st-blksize unsigned-long)
 443     (st-flags   unsigned-long)
 444     (st-gen     unsigned-long)
 445     (st-lspare  long)
 446     (st-qspare (array long 4))
 447     ))
 448
 449 ;; encoding of the file mode
 450
 451 (defconstant s-ifmt   #o0170000 #!+sb-doc "These bits determine file type.")
 452
 453 ;; file types
 454 (defconstant s-ififo  #o0010000 #!+sb-doc "FIFO")
 455 (defconstant s-ifchr  #o0020000 #!+sb-doc "Character device")
 456 (defconstant s-ifdir  #o0040000 #!+sb-doc "Directory")
 457 (defconstant s-ifblk  #o0060000 #!+sb-doc "Block device")
 458 (defconstant s-ifreg  #o0100000 #!+sb-doc "Regular file")
 459
 460 ;; These don't actually exist on System V, but having them doesn't hurt.
 461 (defconstant s-iflnk  #o0120000 #!+sb-doc "Symbolic link.")
 462 (defconstant s-ifsock #o0140000 #!+sb-doc "Socket.")
 463 \f
 464 ;;;; unistd.h
 465
 466 ;;; values for the second argument to access
 467 (defun unix-access (path mode)
 468   #!+sb-doc
 469   "Given a file path (a string) and one of four constant modes,
 470    UNIX-ACCESS returns T if the file is accessible with that
 471    mode and NIL if not. It also returns an errno value with
 472    NIL which determines why the file was not accessible.
 473
 474    The access modes are:
 475         r_ok     Read permission.
 476         w_ok     Write permission.
 477         x_ok     Execute permission.
 478         f_ok     Presence of file."
 479   (declare (type unix-pathname path)
 480            (type (mod 8) mode))
 481   (void-syscall ("access" c-string int) path mode))
 482
 483 (defconstant l_set 0 #!+sb-doc "set the file pointer")
 484 (defconstant l_incr 1 #!+sb-doc "increment the file pointer")
 485 (defconstant l_xtnd 2 #!+sb-doc "extend the file size")
 486
 487 (defun unix-lseek (fd offset whence)
 488   #!+sb-doc
 489   "Unix-lseek accepts a file descriptor and moves the file pointer ahead
 490    a certain offset for that file. Whence can be any of the following:
 491
 492    l_set        Set the file pointer.
 493    l_incr       Increment the file pointer.
 494    l_xtnd       Extend the file size.
 495   "
 496   (declare (type unix-fd fd)
 497            (type (unsigned-byte 32) offset)
 498            (type (integer 0 2) whence))
 499   #!-(and x86 bsd)
 500   (int-syscall ("lseek" int off-t int) fd offset whence)
 501   ;; Need a 64-bit return value type for this. TBD. For now,
 502   ;; don't use this with any 2G+ partitions.
 503   #!+(and x86 bsd)
 504   (int-syscall ("lseek" int unsigned-long unsigned-long int)
 505                fd offset 0 whence))
 506
 507 ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
 508 ;;; It attempts to read len bytes from the device associated with fd
 509 ;;; and store them into the buffer. It returns the actual number of
 510 ;;; bytes read.
 511 (defun unix-read (fd buf len)
 512   #!+sb-doc
 513   "Unix-read attempts to read from the file described by fd into
 514    the buffer buf until it is full. Len is the length of the buffer.
 515    The number of bytes actually read is returned or NIL and an error
 516    number if an error occurred."
 517   (declare (type unix-fd fd)
 518            (type (unsigned-byte 32) len))
 519
 520   (int-syscall ("read" int (* char) int) fd buf len))
 521
 522 ;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
 523 ;;; length to write. It attempts to write len bytes to the device
 524 ;;; associated with fd from the the buffer starting at offset. It returns
 525 ;;; the actual number of bytes written.
 526 (defun unix-write (fd buf offset len)
 527   #!+sb-doc
 528   "Unix-write attempts to write a character buffer (buf) of length
 529    len to the file described by the file descriptor fd. NIL and an
 530    error is returned if the call is unsuccessful."
 531   (declare (type unix-fd fd)
 532            (type (unsigned-byte 32) offset len))
 533   (int-syscall ("write" int (* char) int)
 534                fd
 535                (with-alien ((ptr (* char) (etypecase buf
 536                                             ((simple-array * (*))
 537                                              (vector-sap buf))
 538                                             (system-area-pointer
 539                                              buf))))
 540                  (addr (deref ptr offset)))
 541                len))
 542
 543 (defun unix-pipe ()
 544   #!+sb-doc
 545   "Unix-pipe sets up a unix-piping mechanism consisting of
 546   an input pipe and an output pipe.  Unix-Pipe returns two
 547   values: if no error occurred the first value is the pipe
 548   to be read from and the second is can be written to.  If
 549   an error occurred the first value is NIL and the second
 550   the unix error code."
 551   (with-alien ((fds (array int 2)))
 552     (syscall ("pipe" (* int))
 553              (values (deref fds 0) (deref fds 1))
 554              (cast fds (* int)))))
 555
 556 ;;; UNIX-CHDIR accepts a directory name and makes that the
 557 ;;; current working directory.
 558 (defun unix-chdir (path)
 559   #!+sb-doc
 560   "Given a file path string, unix-chdir changes the current working
 561    directory to the one specified."
 562   (declare (type unix-pathname path))
 563   (void-syscall ("chdir" c-string) path))
 564
 565 (defun unix-current-directory ()
 566   #!+sb-doc
 567   "Return the current directory as a SIMPLE-STRING."
 568   ;; FIXME: Gcc justifiably complains that getwd is dangerous and should
 569   ;; not be used; especially with a hardwired 1024 buffer size, yecch.
 570   ;; This should be rewritten to use getcwd(3), perhaps by writing
 571   ;; a C service routine to do the actual call to getcwd(3) and check
 572   ;; of return values.
 573   (with-alien ((buf (array char 1024)))
 574     (values (not (zerop (alien-funcall (extern-alien "getwd"
 575                                                      (function int (* char)))
 576                                        (cast buf (* char)))))
 577             (cast buf c-string))))
 578
 579 (defun unix-dup (fd)
 580   #!+sb-doc
 581   "Unix-dup duplicates an existing file descriptor (given as the
 582    argument) and returns it.  If FD is not a valid file descriptor, NIL
 583    and an error number are returned."
 584   (declare (type unix-fd fd))
 585   (int-syscall ("dup" int) fd))
 586
 587 ;;; UNIX-EXIT terminates a program.
 588 (defun unix-exit (&optional (code 0))
 589   #!+sb-doc
 590   "Unix-exit terminates the current process with an optional
 591    error code. If successful, the call doesn't return. If
 592    unsuccessful, the call returns NIL and an error number."
 593   (declare (type (signed-byte 32) code))
 594   (void-syscall ("exit" int) code))
 595
 596 (def-alien-routine ("getpid" unix-getpid) int
 597   #!+sb-doc
 598   "Unix-getpid returns the process-id of the current process.")
 599
 600 (def-alien-routine ("getuid" unix-getuid) int
 601   #!+sb-doc
 602   "Unix-getuid returns the real user-id associated with the
 603    current process.")
 604
 605 (defun unix-readlink (path)
 606   #!+sb-doc
 607   "Unix-readlink invokes the readlink system call on the file name
 608   specified by the simple string path. It returns up to two values:
 609   the contents of the symbolic link if the call is successful, or
 610   NIL and the Unix error number."
 611   (declare (type unix-pathname path))
 612   (with-alien ((buf (array char 1024)))
 613     (syscall ("readlink" c-string (* char) int)
 614              (let ((string (make-string result)))
 615                (sb!kernel:copy-from-system-area
 616                 (alien-sap buf) 0
 617                 string (* sb!vm:vector-data-offset sb!vm:word-bits)
 618                 (* result sb!vm:byte-bits))
 619                string)
 620              path (cast buf (* char)) 1024)))
 621
 622 ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
 623 ;;; name and the file if this is the last link.
 624 (defun unix-unlink (name)
 625   #!+sb-doc
 626   "Unix-unlink removes the directory entry for the named file.
 627    NIL and an error code is returned if the call fails."
 628   (declare (type unix-pathname name))
 629   (void-syscall ("unlink" c-string) name))
 630
 631 (defun %set-tty-process-group (pgrp &optional fd)
 632   #!+sb-doc
 633   "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
 634   supplied, FD defaults to /dev/tty."
 635   (let ((old-sigs (unix-sigblock (sigmask :sigttou
 636                                           :sigttin
 637                                           :sigtstp
 638                                           :sigchld))))
 639     (declare (type (unsigned-byte 32) old-sigs))
 640     (unwind-protect
 641         (if fd
 642             (tcsetpgrp fd pgrp)
 643             (multiple-value-bind (tty-fd errno) (unix-open "/dev/tty" o_rdwr 0)
 644               (cond (tty-fd
 645                      (multiple-value-prog1
 646                          (tcsetpgrp tty-fd pgrp)
 647                        (unix-close tty-fd)))
 648                     (t
 649                      (values nil errno)))))
 650       (unix-sigsetmask old-sigs))))
 651
 652 (defun unix-gethostname ()
 653   #!+sb-doc
 654   "Unix-gethostname returns the name of the host machine as a string."
 655   (with-alien ((buf (array char 256)))
 656     (syscall ("gethostname" (* char) int)
 657              (cast buf c-string)
 658              (cast buf (* char)) 256)))
 659
 660 (defun unix-fsync (fd)
 661   #!+sb-doc
 662   "Unix-fsync writes the core image of the file described by
 663    fd to disk."
 664   (declare (type unix-fd fd))
 665   (void-syscall ("fsync" int) fd))
 666 \f
 667 ;;;; sys/ioctl.h
 668
 669 (defun unix-ioctl (fd cmd arg)
 670   #!+sb-doc
 671   "Unix-ioctl performs a variety of operations on open i/o
 672    descriptors.  See the UNIX Programmer's Manual for more
 673    information."
 674   (declare (type unix-fd fd)
 675            (type (unsigned-byte 32) cmd))
 676   (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
 677 \f
 678 ;;;; sys/resource.h
 679
 680 ;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
 681 #!-sb-fluid (declaim (inline unix-fast-getrusage))
 682 (defun unix-fast-getrusage (who)
 683   #!+sb-doc
 684   "Like call getrusage, but return only the system and user time, and returns
 685    the seconds and microseconds as separate values."
 686   (declare (values (member t)
 687                    (unsigned-byte 31) (mod 1000000)
 688                    (unsigned-byte 31) (mod 1000000)))
 689   (with-alien ((usage (struct rusage)))
 690     (syscall* ("getrusage" int (* (struct rusage)))
 691               (values t
 692                       (slot (slot usage 'ru-utime) 'tv-sec)
 693                       (slot (slot usage 'ru-utime) 'tv-usec)
 694                       (slot (slot usage 'ru-stime) 'tv-sec)
 695                       (slot (slot usage 'ru-stime) 'tv-usec))
 696               who (addr usage))))
 697
 698 (defun unix-getrusage (who)
 699   #!+sb-doc
 700   "Unix-getrusage returns information about the resource usage
 701    of the process specified by who. Who can be either the
 702    current process (rusage_self) or all of the terminated
 703    child processes (rusage_children). NIL and an error number
 704    is returned if the call fails."
 705   (with-alien ((usage (struct rusage)))
 706     (syscall ("getrusage" int (* (struct rusage)))
 707               (values t
 708                       (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
 709                          (slot (slot usage 'ru-utime) 'tv-usec))
 710                       (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
 711                          (slot (slot usage 'ru-stime) 'tv-usec))
 712                       (slot usage 'ru-maxrss)
 713                       (slot usage 'ru-ixrss)
 714                       (slot usage 'ru-idrss)
 715                       (slot usage 'ru-isrss)
 716                       (slot usage 'ru-minflt)
 717                       (slot usage 'ru-majflt)
 718                       (slot usage 'ru-nswap)
 719                       (slot usage 'ru-inblock)
 720                       (slot usage 'ru-oublock)
 721                       (slot usage 'ru-msgsnd)
 722                       (slot usage 'ru-msgrcv)
 723                       (slot usage 'ru-nsignals)
 724                       (slot usage 'ru-nvcsw)
 725                       (slot usage 'ru-nivcsw))
 726               who (addr usage))))
 727
 728 \f
 729 ;;;; sys/select.h
 730
 731 (defmacro unix-fast-select (num-descriptors
 732                             read-fds write-fds exception-fds
 733                             timeout-secs &optional (timeout-usecs 0))
 734   #!+sb-doc
 735   "Perform the UNIX select(2) system call."
 736   (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
 737            (type (or (alien (* (struct fd-set))) null)
 738                  read-fds write-fds exception-fds)
 739            (type (or null (unsigned-byte 31)) timeout-secs)
 740            (type (unsigned-byte 31) timeout-usecs) )
 741   ;; FIXME: CMU CL had
 742   ;;   (optimize (speed 3) (safety 0) (inhibit-warnings 3))
 743   ;; in the declarations above. If they're important, they should
 744   ;; be in a declaration inside the LET expansion, not in the
 745   ;; macro compile-time code.
 746   `(let ((timeout-secs ,timeout-secs))
 747      (with-alien ((tv (struct timeval)))
 748        (when timeout-secs
 749          (setf (slot tv 'tv-sec) timeout-secs)
 750          (setf (slot tv 'tv-usec) ,timeout-usecs))
 751        (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
 752                      (* (struct fd-set)) (* (struct timeval)))
 753                     ,num-descriptors ,read-fds ,write-fds ,exception-fds
 754                     (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
 755
 756 ;;; Unix-select accepts sets of file descriptors and waits for an event
 757 ;;; to happen on one of them or to time out.
 758
 759 (defmacro num-to-fd-set (fdset num)
 760   `(if (fixnump ,num)
 761        (progn
 762          (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
 763          ,@(loop for index upfrom 1 below (/ fd-setsize 32)
 764              collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
 765        (progn
 766          ,@(loop for index upfrom 0 below (/ fd-setsize 32)
 767              collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
 768                             (ldb (byte 32 ,(* index 32)) ,num))))))
 769
 770 (defmacro fd-set-to-num (nfds fdset)
 771   `(if (<= ,nfds 32)
 772        (deref (slot ,fdset 'fds-bits) 0)
 773        (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
 774               collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
 775                             ,(* index 32))))))
 776
 777 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
 778   #!+sb-doc
 779   "Unix-select examines the sets of descriptors passed as arguments
 780    to see whether they are ready for reading and writing. See the UNIX
 781    Programmers Manual for more information."
 782   (declare (type (integer 0 #.FD-SETSIZE) nfds)
 783            (type unsigned-byte rdfds wrfds xpfds)
 784            (type (or (unsigned-byte 31) null) to-secs)
 785            (type (unsigned-byte 31) to-usecs)
 786            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
 787   (with-alien ((tv (struct timeval))
 788                (rdf (struct fd-set))
 789                (wrf (struct fd-set))
 790                (xpf (struct fd-set)))
 791     (when to-secs
 792       (setf (slot tv 'tv-sec) to-secs)
 793       (setf (slot tv 'tv-usec) to-usecs))
 794     (num-to-fd-set rdf rdfds)
 795     (num-to-fd-set wrf wrfds)
 796     (num-to-fd-set xpf xpfds)
 797     (macrolet ((frob (lispvar alienvar)
 798                  `(if (zerop ,lispvar)
 799                       (int-sap 0)
 800                       (alien-sap (addr ,alienvar)))))
 801       (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
 802                 (* (struct fd-set)) (* (struct timeval)))
 803                (values result
 804                        (fd-set-to-num nfds rdf)
 805                        (fd-set-to-num nfds wrf)
 806                        (fd-set-to-num nfds xpf))
 807                nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
 808                (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
 809 \f
 810 ;;;; sys/stat.h
 811
 812 ;;; FIXME: This is only used in this file, and needn't be in target Lisp
 813 ;;; runtime. It's also unclear why it needs to be a macro instead of a
 814 ;;; function. Perhaps it should become a FLET.
 815 (defmacro extract-stat-results (buf)
 816   `(values T
 817            #!+bsd
 818            (slot ,buf 'st-dev)
 819            #!+linux
 820            (+ (deref (slot ,buf 'st-dev) 0)
 821               (* (+ +max-u-long+  1)
 822                  (deref (slot ,buf 'st-dev) 1)))   ;;; let's hope this works..
 823            (slot ,buf 'st-ino)
 824            (slot ,buf 'st-mode)
 825            (slot ,buf 'st-nlink)
 826            (slot ,buf 'st-uid)
 827            (slot ,buf 'st-gid)
 828            #!+bsd
 829            (slot ,buf 'st-rdev)
 830            #!+linux
 831            (+ (deref (slot ,buf 'st-rdev) 0)
 832               (* (+ +max-u-long+  1)
 833                  (deref (slot ,buf 'st-rdev) 1)))   ;;; let's hope this works..
 834            #!+linux (slot ,buf 'st-size)
 835            #!+bsd
 836            (+ (slot ,buf 'st-size)
 837               (* (+ +max-u-long+ 1)
 838                  (slot ,buf 'st-sizeh)))
 839            #!+linux (slot ,buf 'st-atime)
 840            #!+bsd   (slot (slot ,buf 'st-atime) 'tv-sec)
 841            #!+linux (slot ,buf 'st-mtime)
 842            #!+bsd   (slot (slot ,buf 'st-mtime) 'tv-sec)
 843            #!+linux (slot ,buf 'st-ctime)
 844            #!+bsd   (slot (slot ,buf 'st-ctime) 'tv-sec)
 845            (slot ,buf 'st-blksize)
 846            #!+linux (slot ,buf 'st-blocks)
 847            #!+bsd
 848            (+ (slot ,buf 'st-blocks)
 849               (* (+ +max-u-long+ 1)
 850                  (slot ,buf 'st-blocksh)))
 851            ))
 852
 853 (defun unix-stat (name)
 854   #!+sb-doc
 855   "Unix-stat retrieves information about the specified
 856    file returning them in the form of multiple values.
 857    See the UNIX Programmer's Manual for a description
 858    of the values returned. If the call fails, then NIL
 859    and an error number is returned instead."
 860   (declare (type unix-pathname name))
 861   (when (string= name "")
 862     (setf name "."))
 863   (with-alien ((buf (struct stat)))
 864     (syscall ("stat" c-string (* (struct stat)))
 865              (extract-stat-results buf)
 866              name (addr buf))))
 867
 868 (defun unix-fstat (fd)
 869   #!+sb-doc
 870   "Unix-fstat is similar to unix-stat except the file is specified
 871    by the file descriptor fd."
 872   (declare (type unix-fd fd))
 873   (with-alien ((buf (struct stat)))
 874     (syscall ("fstat" int (* (struct stat)))
 875              (extract-stat-results buf)
 876              fd (addr buf))))
 877
 878 (defun unix-lstat (name)
 879   #!+sb-doc
 880   "Unix-lstat is similar to unix-stat except the specified
 881    file must be a symbolic link."
 882   (declare (type unix-pathname name))
 883   (with-alien ((buf (struct stat)))
 884     (syscall ("lstat" c-string (* (struct stat)))
 885              (extract-stat-results buf)
 886              name (addr buf))))
 887
 888 ;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
 889 ;;; corresponding directory with mode mode.
 890 (defun unix-mkdir (name mode)
 891   #!+sb-doc
 892   "Unix-mkdir creates a new directory with the specified name and mode.
 893    (Same as those for unix-fchmod.)  It returns T upon success, otherwise
 894    NIL and an error number."
 895   (declare (type unix-pathname name)
 896            (type unix-file-mode mode))
 897   (void-syscall ("mkdir" c-string int) name mode))
 898 \f
 899 ;;;; time.h
 900
 901 ;; POSIX.4 structure for a time value. This is like a `struct timeval' but
 902 ;; has nanoseconds instead of microseconds.
 903
 904 (def-alien-type nil
 905     (struct timespec
 906             (tv-sec long)   ;Seconds
 907             (tv-nsec long))) ;Nanoseconds
 908
 909 ;; Used by other time functions.
 910 (def-alien-type nil
 911     (struct tm
 912             (tm-sec int)   ; Seconds.   [0-60] (1 leap second)
 913             (tm-min int)   ; Minutes.   [0-59]
 914             (tm-hour int)  ; Hours.     [0-23]
 915             (tm-mday int)  ; Day.               [1-31]
 916             (tm-mon int)   ;  Month.    [0-11]
 917             (tm-year int)  ; Year       - 1900.
 918             (tm-wday int)  ; Day of week.       [0-6]
 919             (tm-yday int)  ; Days in year.[0-365]
 920             (tm-isdst int) ;  DST.              [-1/0/1]
 921             (tm-gmtoff long)    ;  Seconds east of UTC.
 922             (tm-zone c-string)))        ; Timezone abbreviation.
 923
 924 (def-alien-routine get-timezone sb!c-call:void
 925   (when sb!c-call:long :in)
 926   (minutes-west sb!c-call:int :out)
 927   (daylight-savings-p sb!alien:boolean :out))
 928
 929 (defun unix-get-minutes-west (secs)
 930   (multiple-value-bind (ignore minutes dst) (get-timezone secs)
 931     (declare (ignore ignore) (ignore dst))
 932     (values minutes)))
 933
 934 (defun unix-get-timezone (secs)
 935   (multiple-value-bind (ignore minutes dst) (get-timezone secs)
 936     (declare (ignore ignore) (ignore minutes))
 937     (values (deref unix-tzname (if dst 1 0)))))
 938
 939 \f
 940 ;;;; sys/time.h
 941
 942 ;;; Structure crudely representing a timezone. KLUDGE: This is
 943 ;;; obsolete and should never be used.
 944 (def-alien-type nil
 945   (struct timezone
 946     (tz-minuteswest int)                ; minutes west of Greenwich
 947     (tz-dsttime int)))                  ; type of dst correction
 948
 949 #!-sb-fluid (declaim (inline unix-gettimeofday))
 950 (defun unix-gettimeofday ()
 951   #!+sb-doc
 952   "If it works, unix-gettimeofday returns 5 values: T, the seconds and
 953    microseconds of the current time of day, the timezone (in minutes west
 954    of Greenwich), and a daylight-savings flag. If it doesn't work, it
 955    returns NIL and the errno."
 956   (with-alien ((tv (struct timeval))
 957                (tz (struct timezone)))
 958     (syscall* ("gettimeofday" (* (struct timeval))
 959                               (* (struct timezone)))
 960               (values T
 961                       (slot tv 'tv-sec)
 962                       (slot tv 'tv-usec)
 963                       (slot tz 'tz-minuteswest)
 964                       (slot tz 'tz-dsttime))
 965               (addr tv)
 966               (addr tz))))
 967 \f
 968 ;;;; asm/errno.h
 969
 970 #|
 971 (def-unix-error ESUCCESS 0 "Successful")
 972 (def-unix-error EPERM 1 "Operation not permitted")
 973 |#
 974 (def-unix-error ENOENT 2 "No such file or directory")
 975 #|
 976 (def-unix-error ESRCH 3 "No such process")
 977 |#
 978 (def-unix-error EINTR 4 "Interrupted system call")
 979 (def-unix-error EIO 5 "I/O error")
 980 #|
 981 (def-unix-error ENXIO 6 "No such device or address")
 982 (def-unix-error E2BIG 7 "Arg list too long")
 983 (def-unix-error ENOEXEC 8 "Exec format error")
 984 (def-unix-error EBADF 9 "Bad file number")
 985 (def-unix-error ECHILD 10 "No children")
 986 (def-unix-error EAGAIN 11 "Try again")
 987 (def-unix-error ENOMEM 12 "Out of memory")
 988 |#
 989 (def-unix-error EACCES 13 "Permission denied")
 990 #|
 991 (def-unix-error EFAULT 14 "Bad address")
 992 (def-unix-error ENOTBLK 15 "Block device required")
 993 (def-unix-error EBUSY 16 "Device or resource busy")
 994 |#
 995 (def-unix-error EEXIST 17 "File exists")
 996 #|
 997 (def-unix-error EXDEV 18 "Cross-device link")
 998 (def-unix-error ENODEV 19 "No such device")
 999 |#
1000 (def-unix-error ENOTDIR 20 "Not a directory")
1001 #|
1002 (def-unix-error EISDIR 21 "Is a directory")
1003 (def-unix-error EINVAL 22 "Invalid argument")
1004 (def-unix-error ENFILE 23 "File table overflow")
1005 (def-unix-error EMFILE 24 "Too many open files")
1006 (def-unix-error ENOTTY 25 "Not a typewriter")
1007 (def-unix-error ETXTBSY 26 "Text file busy")
1008 (def-unix-error EFBIG 27 "File too large")
1009 (def-unix-error ENOSPC 28 "No space left on device")
1010 |#
1011 (def-unix-error ESPIPE 29 "Illegal seek")
1012 #|
1013 (def-unix-error EROFS 30 "Read-only file system")
1014 (def-unix-error EMLINK 31 "Too many links")
1015 (def-unix-error EPIPE 32 "Broken pipe")
1016 |#
1017
1018 #|
1019 ;;; Math
1020 (def-unix-error EDOM 33 "Math argument out of domain")
1021 (def-unix-error ERANGE 34 "Math result not representable")
1022 (def-unix-error  EDEADLK         35     "Resource deadlock would occur")
1023 (def-unix-error  ENAMETOOLONG    36     "File name too long")
1024 (def-unix-error  ENOLCK   37     "No record locks available")
1025 (def-unix-error  ENOSYS   38     "Function not implemented")
1026 (def-unix-error  ENOTEMPTY       39     "Directory not empty")
1027 (def-unix-error  ELOOP     40     "Too many symbolic links encountered")
1028 |#
1029 (def-unix-error  EWOULDBLOCK     11     "Operation would block")
1030 (/show0 "unix.lisp 3192")
1031 #|
1032 (def-unix-error  ENOMSG   42     "No message of desired type")
1033 (def-unix-error  EIDRM     43     "Identifier removed")
1034 (def-unix-error  ECHRNG   44     "Channel number out of range")
1035 (def-unix-error  EL2NSYNC       45     "Level 2 not synchronized")
1036 (def-unix-error  EL3HLT   46     "Level 3 halted")
1037 (def-unix-error  EL3RST   47     "Level 3 reset")
1038 (def-unix-error  ELNRNG   48     "Link number out of range")
1039 (def-unix-error  EUNATCH         49     "Protocol driver not attached")
1040 (def-unix-error  ENOCSI   50     "No CSI structure available")
1041 (def-unix-error  EL2HLT   51     "Level 2 halted")
1042 (def-unix-error  EBADE     52     "Invalid exchange")
1043 (def-unix-error  EBADR     53     "Invalid request descriptor")
1044 (def-unix-error  EXFULL   54     "Exchange full")
1045 (def-unix-error  ENOANO   55     "No anode")
1046 (def-unix-error  EBADRQC         56     "Invalid request code")
1047 (def-unix-error  EBADSLT         57     "Invalid slot")
1048 (def-unix-error  EDEADLOCK       EDEADLK     "File locking deadlock error")
1049 (def-unix-error  EBFONT   59     "Bad font file format")
1050 (def-unix-error  ENOSTR   60     "Device not a stream")
1051 (def-unix-error  ENODATA         61     "No data available")
1052 (def-unix-error  ETIME     62     "Timer expired")
1053 (def-unix-error  ENOSR     63     "Out of streams resources")
1054 (def-unix-error  ENONET   64     "Machine is not on the network")
1055 (def-unix-error  ENOPKG   65     "Package not installed")
1056 (def-unix-error  EREMOTE         66     "Object is remote")
1057 (def-unix-error  ENOLINK         67     "Link has been severed")
1058 (def-unix-error  EADV       68     "Advertise error")
1059 (def-unix-error  ESRMNT   69     "Srmount error")
1060 (def-unix-error  ECOMM     70     "Communication error on send")
1061 (def-unix-error  EPROTO   71     "Protocol error")
1062 (def-unix-error  EMULTIHOP       72     "Multihop attempted")
1063 (def-unix-error  EDOTDOT         73     "RFS specific error")
1064 (def-unix-error  EBADMSG         74     "Not a data message")
1065 (def-unix-error  EOVERFLOW       75     "Value too large for defined data type")
1066 (def-unix-error  ENOTUNIQ       76     "Name not unique on network")
1067 (def-unix-error  EBADFD   77     "File descriptor in bad state")
1068 (def-unix-error  EREMCHG         78     "Remote address changed")
1069 (def-unix-error  ELIBACC         79     "Can not access a needed shared library")
1070 (def-unix-error  ELIBBAD         80     "Accessing a corrupted shared library")
1071 (def-unix-error  ELIBSCN         81     ".lib section in a.out corrupted")
1072 (def-unix-error  ELIBMAX         82     "Attempting to link in too many shared libraries")
1073 (def-unix-error  ELIBEXEC       83     "Cannot exec a shared library directly")
1074 (def-unix-error  EILSEQ   84     "Illegal byte sequence")
1075 (def-unix-error  ERESTART       85     "Interrupted system call should be restarted ")
1076 (def-unix-error  ESTRPIPE       86     "Streams pipe error")
1077 (def-unix-error  EUSERS   87     "Too many users")
1078 (def-unix-error  ENOTSOCK       88     "Socket operation on non-socket")
1079 (def-unix-error  EDESTADDRREQ    89     "Destination address required")
1080 (def-unix-error  EMSGSIZE       90     "Message too long")
1081 (def-unix-error  EPROTOTYPE      91     "Protocol wrong type for socket")
1082 (def-unix-error  ENOPROTOOPT     92     "Protocol not available")
1083 (def-unix-error  EPROTONOSUPPORT 93     "Protocol not supported")
1084 (def-unix-error  ESOCKTNOSUPPORT 94     "Socket type not supported")
1085 (def-unix-error  EOPNOTSUPP      95     "Operation not supported on transport endpoint")
1086 (def-unix-error  EPFNOSUPPORT    96     "Protocol family not supported")
1087 (def-unix-error  EAFNOSUPPORT    97     "Address family not supported by protocol")
1088 (def-unix-error  EADDRINUSE      98     "Address already in use")
1089 (def-unix-error  EADDRNOTAVAIL   99     "Cannot assign requested address")
1090 (def-unix-error  ENETDOWN       100    "Network is down")
1091 (def-unix-error  ENETUNREACH     101    "Network is unreachable")
1092 (def-unix-error  ENETRESET       102    "Network dropped connection because of reset")
1093 (def-unix-error  ECONNABORTED    103    "Software caused connection abort")
1094 (def-unix-error  ECONNRESET      104    "Connection reset by peer")
1095 (def-unix-error  ENOBUFS         105    "No buffer space available")
1096 (def-unix-error  EISCONN         106    "Transport endpoint is already connected")
1097 (def-unix-error  ENOTCONN       107    "Transport endpoint is not connected")
1098 (def-unix-error  ESHUTDOWN       108    "Cannot send after transport endpoint shutdown")
1099 (def-unix-error  ETOOMANYREFS    109    "Too many references: cannot splice")
1100 (def-unix-error  ETIMEDOUT       110    "Connection timed out")
1101 (def-unix-error  ECONNREFUSED    111    "Connection refused")
1102 (def-unix-error  EHOSTDOWN       112    "Host is down")
1103 (def-unix-error  EHOSTUNREACH    113    "No route to host")
1104 (def-unix-error  EALREADY       114    "Operation already in progress")
1105 (def-unix-error  EINPROGRESS     115    "Operation now in progress")
1106 (def-unix-error  ESTALE   116    "Stale NFS file handle")
1107 (def-unix-error  EUCLEAN         117    "Structure needs cleaning")
1108 (def-unix-error  ENOTNAM         118    "Not a XENIX named type file")
1109 (def-unix-error  ENAVAIL         119    "No XENIX semaphores available")
1110 (def-unix-error  EISNAM   120    "Is a named type file")
1111 (def-unix-error  EREMOTEIO       121    "Remote I/O error")
1112 (def-unix-error  EDQUOT   122    "Quota exceeded")
1113 |#
1114
1115 ;;; And now for something completely different ...
1116 (emit-unix-errors)
1117 \f
1118 ;;;; support routines for dealing with unix pathnames
1119
1120 (defun unix-file-kind (name &optional check-for-links)
1121   #!+sb-doc
1122   "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
1123   (declare (simple-string name))
1124   (multiple-value-bind (res dev ino mode)
1125       (if check-for-links (unix-lstat name) (unix-stat name))
1126     (declare (type (or fixnum null) mode)
1127              (ignore dev ino))
1128     (when res
1129       (let ((kind (logand mode s-ifmt)))
1130         (cond ((eql kind s-ifdir) :directory)
1131               ((eql kind s-ifreg) :file)
1132               ((eql kind s-iflnk) :link)
1133               (t :special))))))
1134
1135 (defun unix-maybe-prepend-current-directory (name)
1136   (declare (simple-string name))
1137   (if (and (> (length name) 0) (char= (schar name 0) #\/))
1138       name
1139       (multiple-value-bind (win dir) (unix-current-directory)
1140         (if win
1141             (concatenate 'simple-string dir "/" name)
1142             name))))
1143
1144 (defun unix-resolve-links (pathname)
1145   #!+sb-doc
1146   "Returns the pathname with all symbolic links resolved."
1147   (declare (simple-string pathname))
1148   (let ((len (length pathname))
1149         (pending pathname))
1150     (declare (fixnum len) (simple-string pending))
1151     (if (zerop len)
1152         pathname
1153         (let ((result (make-string 1024 :initial-element (code-char 0)))
1154               (fill-ptr 0)
1155               (name-start 0))
1156           (loop
1157             (let* ((name-end (or (position #\/ pending :start name-start) len))
1158                    (new-fill-ptr (+ fill-ptr (- name-end name-start))))
1159               (replace result pending
1160                        :start1 fill-ptr
1161                        :end1 new-fill-ptr
1162                        :start2 name-start
1163                        :end2 name-end)
1164               (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t)))
1165                 (unless kind (return nil))
1166                 (cond ((eq kind :link)
1167                        (multiple-value-bind (link err) (unix-readlink result)
1168                          (unless link
1169                            (error "error reading link ~S: ~S"
1170                                   (subseq result 0 fill-ptr)
1171                                   (get-unix-error-msg err)))
1172                          (cond ((or (zerop (length link))
1173                                     (char/= (schar link 0) #\/))
1174                                 ;; It's a relative link.
1175                                 (fill result (code-char 0)
1176                                       :start fill-ptr
1177                                       :end new-fill-ptr))
1178                                ((string= result "/../" :end1 4)
1179                                 ;; It's across the super-root.
1180                                 (let ((slash (or (position #\/ result :start 4)
1181                                                  0)))
1182                                   (fill result (code-char 0)
1183                                         :start slash
1184                                         :end new-fill-ptr)
1185                                   (setf fill-ptr slash)))
1186                                (t
1187                                 ;; It's absolute.
1188                                 (and (> (length link) 0)
1189                                      (char= (schar link 0) #\/))
1190                                 (fill result (code-char 0) :end new-fill-ptr)
1191                                 (setf fill-ptr 0)))
1192                          (setf pending
1193                                (if (= name-end len)
1194                                    link
1195                                    (concatenate 'simple-string
1196                                                 link
1197                                                 (subseq pending name-end))))
1198                          (setf len (length pending))
1199                          (setf name-start 0)))
1200                       ((= name-end len)
1201                        (return (subseq result 0 new-fill-ptr)))
1202                       ((eq kind :directory)
1203                        (setf (schar result new-fill-ptr) #\/)
1204                        (setf fill-ptr (1+ new-fill-ptr))
1205                        (setf name-start (1+ name-end)))
1206                       (t
1207                        (return nil))))))))))
1208
1209 (defun unix-simplify-pathname (src)
1210   (declare (simple-string src))
1211   (let* ((src-len (length src))
1212          (dst (make-string src-len))
1213          (dst-len 0)
1214          (dots 0)
1215          (last-slash nil))
1216     (macrolet ((deposit (char)
1217                         `(progn
1218                            (setf (schar dst dst-len) ,char)
1219                            (incf dst-len))))
1220       (dotimes (src-index src-len)
1221         (let ((char (schar src src-index)))
1222           (cond ((char= char #\.)
1223                  (when dots
1224                    (incf dots))
1225                  (deposit char))
1226                 ((char= char #\/)
1227                  (case dots
1228                    (0
1229                     ;; Either ``/...' or ``...//...'
1230                     (unless last-slash
1231                       (setf last-slash dst-len)
1232                       (deposit char)))
1233                    (1
1234                     ;; Either ``./...'' or ``..././...''
1235                     (decf dst-len))
1236                    (2
1237                     ;; We've found ..
1238                     (cond
1239                      ((and last-slash (not (zerop last-slash)))
1240                       ;; There is something before this ..
1241                       (let ((prev-prev-slash
1242                              (position #\/ dst :end last-slash :from-end t)))
1243                         (cond ((and (= (+ (or prev-prev-slash 0) 2)
1244                                        last-slash)
1245                                     (char= (schar dst (- last-slash 2)) #\.)
1246                                     (char= (schar dst (1- last-slash)) #\.))
1247                                ;; The something before this .. is another ..
1248                                (deposit char)
1249                                (setf last-slash dst-len))
1250                               (t
1251                                ;; The something is some directory or other.
1252                                (setf dst-len
1253                                      (if prev-prev-slash
1254                                          (1+ prev-prev-slash)
1255                                          0))
1256                                (setf last-slash prev-prev-slash)))))
1257                      (t
1258                       ;; There is nothing before this .., so we need to keep it
1259                       (setf last-slash dst-len)
1260                       (deposit char))))
1261                    (t
1262                     ;; Something other than a dot between slashes.
1263                     (setf last-slash dst-len)
1264                     (deposit char)))
1265                  (setf dots 0))
1266                 (t
1267                  (setf dots nil)
1268                  (setf (schar dst dst-len) char)
1269                  (incf dst-len))))))
1270     (when (and last-slash (not (zerop last-slash)))
1271       (case dots
1272         (1
1273          ;; We've got  ``foobar/.''
1274          (decf dst-len))
1275         (2
1276          ;; We've got ``foobar/..''
1277          (unless (and (>= last-slash 2)
1278                       (char= (schar dst (1- last-slash)) #\.)
1279                       (char= (schar dst (- last-slash 2)) #\.)
1280                       (or (= last-slash 2)
1281                           (char= (schar dst (- last-slash 3)) #\/)))
1282            (let ((prev-prev-slash
1283                   (position #\/ dst :end last-slash :from-end t)))
1284              (if prev-prev-slash
1285                  (setf dst-len (1+ prev-prev-slash))
1286                  (return-from unix-simplify-pathname "./")))))))
1287     (cond ((zerop dst-len)
1288            "./")
1289           ((= dst-len src-len)
1290            dst)
1291           (t
1292            (subseq dst 0 dst-len)))))
1293 \f
1294 ;;;; stuff not yet found in the header files
1295 ;;;;
1296 ;;;; Abandon all hope who enters here...
1297
1298 ;;; not checked for linux...
1299 (defmacro fd-set (offset fd-set)
1300   (let ((word (gensym))
1301         (bit (gensym)))
1302     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1303        (setf (deref (slot ,fd-set 'fds-bits) ,word)
1304              (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
1305                      (deref (slot ,fd-set 'fds-bits) ,word))))))
1306
1307 ;;; not checked for linux...
1308 (defmacro fd-clr (offset fd-set)
1309   (let ((word (gensym))
1310         (bit (gensym)))
1311     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1312        (setf (deref (slot ,fd-set 'fds-bits) ,word)
1313              (logand (deref (slot ,fd-set 'fds-bits) ,word)
1314                      (sb!kernel:32bit-logical-not
1315                       (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
1316
1317 ;;; not checked for linux...
1318 (defmacro fd-isset (offset fd-set)
1319   (let ((word (gensym))
1320         (bit (gensym)))
1321     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
1322        (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
1323
1324 ;;; not checked for linux...
1325 (defmacro fd-zero (fd-set)
1326   `(progn
1327      ,@(loop for index upfrom 0 below (/ fd-setsize 32)
1328          collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
1329
1330 (/show0 "unix.lisp 3555")