src/syscalls/ffi-functions-unix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- *UNIX foreign function definitions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;; Needed for clock_gettime() and friends.
   9 (eval-when (:compile-toplevel :load-toplevel :execute)
  10   (define-foreign-library librt
  11     (:linux "librt.so"))
  12   (use-foreign-library librt))
  13 \f
  14
  15 ;;;-------------------------------------------------------------------------
  16 ;;; ERRNO-related functions
  17 ;;;-------------------------------------------------------------------------
  18
  19 (defentrypoint (setf errno) (value)
  20   "Set errno value."
  21   (%set-errno value))
  22
  23 (defsyscall (%strerror-r (#+linux "__xpg_strerror_r" "strerror_r"))
  24     :int
  25   (errnum :int)
  26   (buf    :pointer)
  27   (buflen size-t))
  28
  29 (defentrypoint strerror (&optional (err (errno)))
  30   "Look up the error message string for ERRNO (reentrant)."
  31   (let ((errno
  32          (if (keywordp err)
  33              (foreign-enum-value 'errno-values err)
  34              err)))
  35     (with-foreign-pointer-as-string ((buf bufsiz) 1024)
  36       (%strerror-r errno buf bufsiz))))
  37
  38 (defmethod print-object ((e syscall-error) s)
  39   (with-slots (syscall code identifier message handle handle2) e
  40     (if message
  41         (format s "~A" message)
  42         (print-unreadable-object (e s :type nil :identity nil)
  43           (format s "Syscall ~S signalled error ~A(~S) ~S"
  44                   syscall identifier (or code "[No code]")
  45                   (or (strerror code) "[Can't get error string.]"))
  46           (when handle (format s " FD=~A" handle))
  47           (when handle2 (format s " FD2=~A" handle2))))))
  48 \f
  49
  50 ;;;-------------------------------------------------------------------------
  51 ;;; Memory manipulation
  52 ;;;-------------------------------------------------------------------------
  53
  54 (defcfun* (memset "memset") :pointer
  55   "Fill the first COUNT bytes of BUFFER with the constant VALUE."
  56   (buffer :pointer)
  57   (value  :int)
  58   (count  size-t))
  59
  60 (defentrypoint bzero (buffer count)
  61   "Fill the first COUNT bytes of BUFFER with zeros."
  62   (memset buffer 0 count))
  63
  64 (defcfun* (memcpy "memcpy") :pointer
  65   "Copy COUNT octets from SRC to DEST.
  66 The two memory areas must not overlap."
  67   (dest :pointer)
  68   (src  :pointer)
  69   (count size-t))
  70
  71 (defcfun* (memmove "memmove") :pointer
  72   "Copy COUNT octets from SRC to DEST.
  73 The two memory areas may overlap."
  74   (dest :pointer)
  75   (src  :pointer)
  76   (count size-t))
  77 \f
  78
  79 ;;;-------------------------------------------------------------------------
  80 ;;; I/O
  81 ;;;-------------------------------------------------------------------------
  82
  83 (defsyscall (read "read")
  84     (ssize-t :restart t :handle fd)
  85   "Read at most COUNT bytes from FD into the foreign area BUF."
  86   (fd    :int)
  87   (buf   :pointer)
  88   (count size-t))
  89
  90 (defsyscall (write "write")
  91     (ssize-t :restart t :handle fd)
  92   "Write at most COUNT bytes to FD from the foreign area BUF."
  93   (fd    :int)
  94   (buf   :pointer)
  95   (count size-t))
  96
  97 (defsyscall (readv "readv")
  98     (ssize-t :restart t :handle fd)
  99   "Read from FD into the first IOVCNT buffers of the IOV array."
 100   (fd     :int)
 101   (iov    :pointer)
 102   (iovcnt :int))
 103
 104 (defsyscall (writev "writev")
 105     (ssize-t :restart t :handle fd)
 106   "Writes to FD the first IOVCNT buffers of the IOV array."
 107   (fd     :int)
 108   (iov    :pointer)
 109   (iovcnt :int))
 110
 111 (defsyscall (pread (#+linux "pread64" "pread"))
 112     (ssize-t :restart t :handle fd)
 113   "Read at most COUNT bytes from FD at offset OFFSET into the foreign area BUF."
 114   (fd     :int)
 115   (buf    :pointer)
 116   (count  size-t)
 117   (offset off-t))
 118
 119 (defsyscall (pwrite (#+linux "pwrite64" "pwrite"))
 120     (ssize-t :restart t :handle fd)
 121   "Write at most COUNT bytes to FD at offset OFFSET from the foreign area BUF."
 122   (fd     :int)
 123   (buf    :pointer)
 124   (count  size-t)
 125   (offset off-t))
 126 \f
 127
 128 ;;;-------------------------------------------------------------------------
 129 ;;; Files
 130 ;;;-------------------------------------------------------------------------
 131
 132 (defsyscall (%open (#+linux "open64" "open"))
 133     (:int :restart t)
 134   (path  sstring)
 135   (flags :int)
 136   (mode  mode-t))
 137
 138 (defvar *default-open-mode* #o666)
 139
 140 (defentrypoint open (path flags &optional (mode *default-open-mode*))
 141   "Open a file descriptor for PATH using FLAGS and permissions MODE
 142 \(default value is *DEFAULT-OPEN-MODE* - #o666)."
 143   (%open path flags mode))
 144
 145 (defsyscall (creat (#+linux "creat64" "creat"))
 146     (:int :restart t)
 147   "Create file PATH with permissions MODE and return the new FD."
 148   (path sstring)
 149   (mode mode-t))
 150
 151 (defsyscall (%pipe "pipe") :int
 152   (fds :pointer))
 153
 154 (defentrypoint pipe ()
 155   "Create pipe, returns two values with the new FDs."
 156   (with-foreign-object (fds :int 2)
 157     (%pipe fds)
 158     (values (mem-aref fds :int 0)
 159             (mem-aref fds :int 1))))
 160
 161 (defsyscall (mkfifo "mkfifo") :int
 162   "Create a FIFO (named pipe) with name PATH and permissions MODE."
 163   (path sstring)
 164   (mode mode-t))
 165
 166 (defsyscall (umask "umask") mode-t
 167   "Sets the umask to NEW-MODE and returns the old one."
 168   (new-mode mode-t))
 169
 170 (defsyscall (lseek (#+linux "lseek64" "lseek"))
 171     (off-t :handle fd)
 172   "Reposition the offset of the open file associated with the file descriptor FD
 173 to the argument OFFSET according to the directive WHENCE."
 174   (fd     :int)
 175   (offset off-t)
 176   (whence :int))
 177
 178 (defsyscall (access "access") :int
 179   "Check whether the file PATH can be accessed using mode MODE."
 180   (path sstring)
 181   (mode :int))
 182
 183 (defsyscall (truncate (#+linux "truncate64" "truncate"))
 184     (:int :restart t)
 185   "Truncate the file PATH to a size of precisely LENGTH octets."
 186   (path   sstring)
 187   (length off-t))
 188
 189 (defsyscall (ftruncate (#+linux "ftruncate64" "ftruncate"))
 190     (:int :restart t :handle fd)
 191   "Truncate the file referenced by FD to a size of precisely LENGTH octets."
 192   (fd     :int)
 193   (length off-t))
 194
 195 (defsyscall (rename "rename") :int
 196   "Rename file named by OLDPATH to NEWPATH."
 197   (oldpath sstring)
 198   (newpath sstring))
 199
 200 (defsyscall (link "link") :int
 201   "Create a hard link from file OLDPATH to NEWPATH."
 202   (oldpath sstring)
 203   (newpath sstring))
 204
 205 (defsyscall (symlink "symlink") :int
 206   "Create a symbolic link from file OLDPATH to NEWPATH."
 207   (oldpath sstring)
 208   (newpath sstring))
 209
 210 (defsyscall (%readlink "readlink") ssize-t
 211   (path    sstring)
 212   (buf     :pointer)
 213   (bufsize size-t))
 214
 215 (defentrypoint readlink (path)
 216   "Read the file name pointed by the symbolic link PATH."
 217   (with-foreign-pointer (buf +cstring-path-max+ bufsize)
 218     (let ((count (%readlink path buf bufsize)))
 219       (cstring-to-sstring buf count))))
 220
 221 (defsyscall (%realpath "realpath") sstring
 222   (path          sstring)
 223   (resolved-path :pointer))
 224
 225 (defentrypoint realpath (path)
 226   "Read the file name pointed by the symbolic link PATH."
 227   (with-foreign-pointer (buf +cstring-path-max+)
 228     (%realpath path buf)))
 229
 230 (defsyscall (unlink "unlink") :int
 231   "Delete the file PATH from the file system."
 232   (path sstring))
 233
 234 (defsyscall (chown "chown")
 235     (:int :restart t)
 236   "Change ownership of file PATH to uid OWNER and gid GROUP(dereferences symlinks)."
 237   (path  sstring)
 238   (owner uid-t)
 239   (group uid-t))
 240
 241 (defsyscall (fchown "fchown")
 242     (:int :restart t :handle fd)
 243   "Change ownership of an open file referenced by FD to uid OWNER and gid GROUP."
 244   (fd    :int)
 245   (owner uid-t)
 246   (group uid-t))
 247
 248 (defsyscall (lchown "lchown")
 249     (:int :restart t)
 250   "Change ownership of a file PATH to uid OWNER and gid GROUP(does not dereference symlinks)."
 251   (path  sstring)
 252   (owner uid-t)
 253   (group uid-t))
 254
 255 (defsyscall (chmod "chmod")
 256     (:int :restart t)
 257   "Change permissions of file PATH to mode MODE."
 258   (path sstring)
 259   (mode mode-t))
 260
 261 (defsyscall (fchmod "fchmod")
 262     (:int :restart t :handle fd)
 263   "Change permissions of open file referenced by FD to mode MODE."
 264   (fd   :int)
 265   (mode mode-t))
 266 \f
 267
 268 ;;;-------------------------------------------------------------------------
 269 ;;; Stat()
 270 ;;;-------------------------------------------------------------------------
 271
 272 (define-c-struct-wrapper stat ())
 273
 274 (defsyscall (%stat (#+linux "__xstat64" "stat"))
 275     :int
 276   #+linux
 277   (version   :int)
 278   (file-name sstring)
 279   (buf       :pointer))
 280
 281 (defsyscall (%fstat (#+linux "__fxstat64" "fstat"))
 282     (:int :handle fd)
 283   #+linux
 284   (version :int)
 285   (fd      :int)
 286   (buf     :pointer))
 287
 288 (defsyscall (%lstat (#+linux "__lxstat64" "lstat"))
 289     :int
 290   #+linux
 291   (version   :int)
 292   (file-name sstring)
 293   (buf       :pointer))
 294
 295 ;;; If necessary for performance reasons, we can add an optional
 296 ;;; argument to this function and use that to reuse a wrapper object.
 297 (defentrypoint funcall-stat (fn arg)
 298   (with-foreign-object (buf 'stat)
 299     (funcall fn #+linux +stat-version+ arg buf)
 300     (make-instance 'stat :pointer buf)))
 301
 302 (defentrypoint stat (path)
 303   "Get information about file PATH(dereferences symlinks)."
 304   (funcall-stat #'%stat path))
 305
 306 (defentrypoint fstat (fd)
 307   "Get information about file descriptor FD."
 308   (funcall-stat #'%fstat fd))
 309
 310 (defentrypoint lstat (path)
 311   "Get information about file PATH(does not dereference symlinks)."
 312   (funcall-stat #'%lstat path))
 313
 314 (defsyscall (sync "sync") :void
 315   "Schedule all file system buffers to be written to disk.")
 316
 317 (defsyscall (fsync "fsync")
 318     (:int :restart t)
 319   "Schedule a file's buffers to be written to disk."
 320   (fd :int))
 321
 322 (defsyscall (%mkstemp (#+linux "mkstemp64" "mkstemp")) :int
 323   (template :pointer))
 324
 325 (defentrypoint mkstemp (&optional (template ""))
 326   "Generate a unique temporary filename from TEMPLATE.
 327 Return two values: the file descriptor and the path of the temporary file."
 328   (let ((template (concatenate 'string template "XXXXXX")))
 329     (with-sstring-to-cstring (ptr template)
 330       (values (%mkstemp ptr) (cstring-to-sstring ptr)))))
 331 \f
 332
 333 ;;;-------------------------------------------------------------------------
 334 ;;; Directories
 335 ;;;-------------------------------------------------------------------------
 336
 337 (defsyscall (mkdir "mkdir") :int
 338   "Create directory PATH with permissions MODE."
 339   (path sstring)
 340   (mode mode-t))
 341
 342 (defsyscall (rmdir "rmdir") :int
 343   "Delete directory PATH."
 344   (path sstring))
 345
 346 (defsyscall (chdir "chdir") :int
 347   "Change the current working directory to PATH."
 348   (path sstring))
 349
 350 (defsyscall (fchdir "fchdir")
 351     (:int :restart t :handle fd)
 352   "Change the current working directory to the directory referenced by FD."
 353   (fd :int))
 354
 355 (defsyscall (%getcwd "getcwd") :pointer
 356   (buf :pointer)
 357   (size size-t))
 358
 359 (defentrypoint getcwd ()
 360   "Return the current working directory as a string."
 361   (with-cstring-to-sstring (buf +cstring-path-max+ bufsize)
 362     (%getcwd buf bufsize)))
 363
 364 (defsyscall (%mkdtemp "mkdtemp") sstring
 365   (template sstring))
 366
 367 (defentrypoint mkdtemp (&optional (template ""))
 368   "Generate a unique temporary filename from TEMPLATE."
 369   (let ((template (concatenate 'string template "XXXXXX")))
 370     (%mkdtemp template)))
 371 \f
 372
 373 ;;;-------------------------------------------------------------------------
 374 ;;; File Descriptors
 375 ;;;-------------------------------------------------------------------------
 376
 377 (defsyscall (close "close")
 378     (:int :handle fd)
 379   "Close open file descriptor FD."
 380   (fd :int))
 381
 382 (defsyscall (dup "dup")
 383     (:int :handle fd)
 384   "Duplicate file descriptor FD."
 385   (fd :int))
 386
 387 (defsyscall (dup2 "dup2")
 388     (:int :restart t :handle oldfd :handle2 newfd)
 389   "Make NEWFD be the copy of OLDFD, closing NEWFD first if necessary."
 390   (oldfd :int)
 391   (newfd :int))
 392
 393 (defsyscall (%fcntl/noarg "fcntl")
 394     (:int :handle fd)
 395   (fd  :int)
 396   (cmd :int))
 397
 398 ;;; FIXME: Linux/glibc says ARG's type is long, POSIX says it's int.
 399 ;;; Is this an issue?
 400 (defsyscall (%fcntl/int "fcntl")
 401     (:int :handle fd)
 402   (fd  :int)
 403   (cmd :int)
 404   (arg :int))
 405
 406 (defsyscall (%fcntl/pointer "fcntl")
 407     (:int :handle fd)
 408   (fd  :int)
 409   (cmd :int)
 410   (arg :pointer))
 411
 412 (defentrypoint fcntl (fd cmd &optional (arg nil argp))
 413   (cond
 414     ((not argp)     (%fcntl/noarg   fd cmd))
 415     ((integerp arg) (%fcntl/int     fd cmd arg))
 416     ((pointerp arg) (%fcntl/pointer fd cmd arg))
 417     ;; FIXME: signal a type error
 418     (t (error "Wrong argument to fcntl: ~S" arg))))
 419
 420 (defentrypoint fd-nonblock (fd)
 421   (let ((current-flags (fcntl fd f-getfl)))
 422     (logtest o-nonblock current-flags)))
 423
 424 (defentrypoint (setf fd-nonblock) (newmode fd)
 425   (let* ((current-flags (fcntl fd f-getfl))
 426          (new-flags (if newmode
 427                         (logior current-flags o-nonblock)
 428                         (logandc2 current-flags o-nonblock))))
 429     (when (/= new-flags current-flags)
 430       (fcntl fd f-setfl new-flags))
 431     newmode))
 432
 433 (defsyscall (%ioctl/noarg "ioctl")
 434     (:int :restart t :handle fd)
 435   "Send request REQUEST to file referenced by FD."
 436   (fd      :int)
 437   (request :int))
 438
 439 (defsyscall (%ioctl/pointer "ioctl")
 440     (:int :restart t :handle fd)
 441   "Send request REQUEST to file referenced by FD using argument ARG."
 442  (fd      :int)
 443  (request :int)
 444  (arg     :pointer))
 445
 446 (defentrypoint ioctl (fd request &optional (arg nil argp))
 447   "Control an I/O device."
 448   (cond
 449     ((not argp)     (%ioctl/noarg   fd request))
 450     ((pointerp arg) (%ioctl/pointer fd request arg))
 451     ;; FIXME: signal a type error
 452     (t (error "Wrong argument to ioctl: ~S" arg))))
 453
 454 (defentrypoint fd-open-p (fd)
 455   (handler-case
 456       (progn (fstat fd) t)
 457     (ebadf () nil)))
 458 \f
 459
 460 ;;;-------------------------------------------------------------------------
 461 ;;; TTYs
 462 ;;;-------------------------------------------------------------------------
 463
 464 (defsyscall (posix-openpt "posix_openpt") :int
 465   (flags :int))
 466
 467 (defsyscall (grantpt "grantpt")
 468     (:int :handle fd)
 469   (fd :int))
 470
 471 (defsyscall (unlockpt "unlockpt")
 472     (:int :handle fd)
 473   (fd :int))
 474
 475 (defsyscall (ptsname "ptsname")
 476     (:string :handle fd)
 477   (fd :int))
 478 \f
 479
 480 ;;;-------------------------------------------------------------------------
 481 ;;; File descriptor polling
 482 ;;;-------------------------------------------------------------------------
 483
 484 (defsyscall (select "select") :int
 485   "Scan for I/O activity on multiple file descriptors."
 486   (nfds      :int)
 487   (readfds   :pointer)
 488   (writefds  :pointer)
 489   (exceptfds :pointer)
 490   (timeout   :pointer))
 491
 492 (defentrypoint fd-zero (fd-set)
 493   (bzero fd-set size-of-fd-set)
 494   (values fd-set))
 495
 496 (defentrypoint copy-fd-set (from to)
 497   (memcpy to from size-of-fd-set)
 498   (values to))
 499
 500 (deftype select-file-descriptor ()
 501   `(mod #.fd-setsize))
 502
 503 (defentrypoint fd-isset (fd fd-set)
 504   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 505     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 506       (logbitp bit-off oldval))))
 507
 508 (defentrypoint fd-clr (fd fd-set)
 509   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 510     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 511       (setf (mem-aref fd-set :uint8 byte-off)
 512             (logandc2 oldval (ash 1 bit-off)))))
 513   (values fd-set))
 514
 515 (defentrypoint fd-set (fd fd-set)
 516   (multiple-value-bind (byte-off bit-off) (floor fd 8)
 517     (let ((oldval (mem-aref fd-set :uint8 byte-off)))
 518       (setf (mem-aref fd-set :uint8 byte-off)
 519             (logior oldval (ash 1 bit-off)))))
 520   (values fd-set))
 521
 522 ;;; FIXME: Until a way to autodetect platform features is implemented
 523 (eval-when (:compile-toplevel :load-toplevel :execute)
 524   (unless (boundp 'pollrdhup)
 525     (defconstant pollrdhup 0)))
 526
 527 (defsyscall (poll "poll") :int
 528   "Scan for I/O activity on multiple file descriptors."
 529   (fds     :pointer)
 530   (nfds    nfds-t)
 531   (timeout :int))
 532
 533 #+linux
 534 (progn
 535   (defsyscall (epoll-create "epoll_create") :int
 536     "Open an epoll file descriptor."
 537     (size :int))
 538
 539   (defsyscall (epoll-ctl "epoll_ctl")
 540       (:int :handle epfd :handle2 fd)
 541     "Control interface for an epoll descriptor."
 542     (epfd  :int)
 543     (op    :int)
 544     (fd    :int)
 545     (event :pointer))
 546
 547   (defsyscall (epoll-wait "epoll_wait")
 548       (:int :handle epfd)
 549     "Wait for an I/O event on an epoll file descriptor."
 550     (epfd      :int)
 551     (events    :pointer)
 552     (maxevents :int)
 553     (timeout   :int)))
 554
 555 #+bsd
 556 (progn
 557   (defsyscall (kqueue "kqueue") :int
 558     "Open a kernel event queue.")
 559
 560   (defsyscall (kevent "kevent")
 561       (:int :handle fd)
 562     "Control interface for a kernel event queue."
 563     (fd         :int)
 564     (changelist :pointer)               ; const struct kevent *
 565     (nchanges   :int)
 566     (eventlist  :pointer)               ; struct kevent *
 567     (nevents    :int)
 568     (timeout    :pointer))              ; const struct timespec *
 569
 570   (defentrypoint ev-set (%kev %ident %filter %flags %fflags %data %udata)
 571     (with-foreign-slots ((ident filter flags fflags data udata) %kev kevent)
 572       (setf ident %ident filter %filter flags %flags
 573             fflags %fflags data %data udata %udata))))
 574 \f
 575
 576 ;;;-------------------------------------------------------------------------
 577 ;;; Directory walking
 578 ;;;-------------------------------------------------------------------------
 579
 580 (defsyscall (opendir "opendir") :pointer
 581   "Open directory PATH for listing of its contents."
 582   (path sstring))
 583
 584 #-bsd
 585 (defsyscall (fdopendir "fdopendir") :pointer
 586   "Open directory denoted by descriptor FD for listing of its contents."
 587   (fd :int))
 588
 589 (defsyscall (closedir "closedir") :int
 590   "Close directory DIR when done listing its contents."
 591   (dirp :pointer))
 592
 593 (defsyscall (%readdir-r (#+linux "readdir64_r" "readdir_r"))
 594     (:int
 595      :error-predicate plusp
 596      :error-location :return)
 597   (dirp   :pointer)
 598   (entry  :pointer)
 599   (result :pointer))
 600
 601 (defentrypoint readdir (dir)
 602   "Reads an item from the listing of directory DIR (reentrant)."
 603   (with-foreign-objects ((entry 'dirent) (result :pointer))
 604     (%readdir-r dir entry result)
 605     (if (null-pointer-p (mem-ref result :pointer))
 606         nil
 607         (with-foreign-slots ((name type fileno) entry dirent)
 608           (values (cstring-to-sstring name) type fileno)))))
 609
 610 (defsyscall (rewinddir "rewinddir") :void
 611   "Rewind directory DIR."
 612   (dirp :pointer))
 613
 614 (defsyscall (seekdir "seekdir") :void
 615   "Seek into directory DIR to position POS(as returned by TELLDIR)."
 616   (dirp :pointer)
 617   (pos  :long))
 618
 619 ;;; FIXME: According to POSIX docs "no errors are defined" for
 620 ;;; telldir() but Linux manpages specify a possible EBADF.
 621 (defsyscall (telldir "telldir") off-t
 622   "Return the current location in directory DIR."
 623   (dirp :pointer))
 624 \f
 625
 626 ;;;-------------------------------------------------------------------------
 627 ;;; Memory mapping
 628 ;;;-------------------------------------------------------------------------
 629
 630 (defsyscall (mmap (#+linux "mmap64" "mmap"))
 631     (:pointer :handle fd)
 632   "Map file referenced by FD at offset OFFSET into address space of the
 633 calling process at address ADDR and length LENGTH.
 634 PROT describes the desired memory protection of the mapping.
 635 FLAGS determines whether updates to the mapping are visible to other
 636 processes mapping the same region."
 637   (addr   :pointer)
 638   (length size-t)
 639   (prot   :int)
 640   (flags  :int)
 641   (fd     :int)
 642   (offset off-t))
 643
 644 (defsyscall (munmap "munmap") :int
 645   "Unmap pages of memory starting at address ADDR with length LENGTH."
 646   (addr   :pointer)
 647   (length size-t))
 648 \f
 649
 650 ;;;-------------------------------------------------------------------------
 651 ;;; Process creation and info
 652 ;;;-------------------------------------------------------------------------
 653
 654 (defsyscall (fork "fork") pid-t
 655   "Create a child process.")
 656
 657 (defsyscall (execv "execv") :int
 658   (path :string)
 659   (argv :pointer))
 660
 661 (defsyscall (execvp "execvp") :int
 662   (file :string)
 663   (argv :pointer))
 664
 665 (defsyscall (waitpid "waitpid") pid-t
 666   (pid     pid-t)
 667   (status  :pointer)
 668   (options :int))
 669
 670 (defsyscall (getpid "getpid") pid-t
 671   "Returns the process id of the current process")
 672
 673 (defsyscall (getppid "getppid") pid-t
 674   "Returns the process id of the current process's parent")
 675
 676 #+linux
 677 (defentrypoint gettid ()
 678   (foreign-funcall "syscall" :int sys-gettid :int))
 679
 680 (defsyscall (getuid "getuid") uid-t
 681   "Get real user id of the current process.")
 682
 683 (defsyscall (setuid "setuid") :int
 684   "Set real user id of the current process to UID."
 685   (uid uid-t))
 686
 687 (defsyscall (geteuid "geteuid") uid-t
 688   "Get effective user id of the current process.")
 689
 690 (defsyscall (seteuid "seteuid") :int
 691   "Set effective user id of the current process to UID."
 692   (uid uid-t))
 693
 694 (defsyscall (getgid "getgid") gid-t
 695   "Get real group id of the current process.")
 696
 697 (defsyscall (setgid "setgid") :int
 698   "Set real group id of the current process to GID."
 699   (gid gid-t))
 700
 701 (defsyscall (getegid "getegid") gid-t
 702   "Get effective group id of the current process.")
 703
 704 (defsyscall (setegid "setegid") :int
 705   "Set effective group id of the current process to GID."
 706   (gid gid-t))
 707
 708 (defsyscall (setreuid "setreuid") :int
 709   "Set real and effective user id of the current process to RUID and EUID."
 710   (ruid uid-t)
 711   (euid uid-t))
 712
 713 (defsyscall (setregid "setregid") :int
 714   "Set real and effective group id of the current process to RGID and EGID."
 715   (rgid gid-t)
 716   (egid gid-t))
 717
 718 (defsyscall (getpgid "getpgid") pid-t
 719   "Get process group id of process PID."
 720   (pid pid-t))
 721
 722 (defsyscall (setpgid "setpgid") :int
 723   "Set process group id of process PID to value PGID."
 724   (pid  pid-t)
 725   (pgid pid-t))
 726
 727 (defsyscall (getpgrp "getpgrp") pid-t
 728   "Get process group id of the current process.")
 729
 730 (defsyscall (setpgrp "setpgrp") pid-t
 731   "Set process group id of the current process.")
 732
 733 (defsyscall (setsid "setsid") pid-t
 734   "Create session and set process group id of the current process.")
 735
 736 (defsyscall (%getrlimit (#+linux "getrlimit64" "getrlimit"))
 737     :int
 738   (resource :int)
 739   (rlimit   :pointer))
 740
 741 (defentrypoint getrlimit (resource)
 742   "Return soft and hard limit of system resource RESOURCE."
 743   (with-foreign-object (rl 'rlimit)
 744     (with-foreign-slots ((cur max) rl rlimit)
 745       (%getrlimit resource rl)
 746       (values cur max))))
 747
 748 (defsyscall (%setrlimit (#+linux "setrlimit64" "setrlimit"))
 749     :int
 750   (resource :int)
 751   (rlimit   :pointer))
 752
 753 (defentrypoint setrlimit (resource soft-limit hard-limit)
 754   "Set SOFT-LIMIT and HARD-LIMIT of system resource RESOURCE."
 755   (with-foreign-object (rl 'rlimit)
 756     (with-foreign-slots ((cur max) rl rlimit)
 757       (setf cur soft-limit
 758             max hard-limit)
 759       (%setrlimit resource rl))))
 760
 761 (defsyscall (%getrusage "getrusage") :int
 762   (who   :int)
 763   (usage :pointer))
 764
 765 ;;; TODO: it might be more convenient to return a wrapper object here
 766 ;;; instead like we do in STAT.
 767 (defentrypoint getrusage (who)
 768   "Return resource usage measures of WHO."
 769   (with-foreign-object (ru 'rusage)
 770     (%getrusage who ru)
 771     (with-foreign-slots ((maxrss ixrss idrss isrss minflt majflt nswap inblock
 772                           oublock msgsnd msgrcv nsignals nvcsw nivcsw)
 773                          ru rusage)
 774       (values (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 775                                   'timeval 'sec)
 776               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'utime)
 777                                   'timeval 'usec)
 778               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 779                                   'timeval 'sec)
 780               (foreign-slot-value (foreign-slot-pointer ru 'rusage 'stime)
 781                                   'timeval 'usec)
 782               maxrss ixrss idrss isrss minflt majflt
 783               nswap inblock oublock msgsnd
 784               msgrcv nsignals nvcsw nivcsw))))
 785
 786 (defsyscall (getpriority "getpriority") :int
 787   "Get the scheduling priority of a process, process group, or user,
 788 as indicated by WHICH and WHO."
 789   (which :int)
 790   (who   :int))
 791
 792 (defsyscall (setpriority "setpriority") :int
 793   "Set the scheduling priority of a process, process group, or user,
 794 as indicated by WHICH and WHO to VALUE."
 795   (which :int)
 796   (who   :int)
 797   (value :int))
 798
 799 (defentrypoint nice (&optional (increment 0))
 800   "Get or set process priority."
 801   ;; FIXME: race condition. might need WITHOUT-INTERRUPTS on some impl.s
 802   (setf (errno) 0)
 803   (let ((retval (foreign-funcall "nice" :int increment :int))
 804         (errno (errno)))
 805     (if (and (= retval -1) (/= errno 0))
 806         (signal-syscall-error errno)
 807         retval)))
 808
 809 (defsyscall (exit "_exit") :void
 810   "terminate the calling process"
 811   (status :int))
 812
 813 \f
 814
 815 ;;;-------------------------------------------------------------------------
 816 ;;; Signals
 817 ;;;-------------------------------------------------------------------------
 818
 819 (defsyscall (kill "kill") :int
 820   "Send signal SIG to process PID."
 821   (pid    pid-t)
 822   (signum :int))
 823
 824 (defsyscall (sigaction "sigaction") :int
 825   (signum :int)
 826   (act    :pointer)
 827   (oldact :pointer))
 828 \f
 829
 830 ;;;-------------------------------------------------------------------------
 831 ;;; Time
 832 ;;;-------------------------------------------------------------------------
 833
 834 (defsyscall (usleep "usleep") :int
 835   "Suspend execution for USECONDS microseconds."
 836   (useconds useconds-t))
 837
 838 (defsyscall (%time "time") time-t
 839   (tloc :pointer))
 840
 841 (defentrypoint time ()
 842   "Get time in seconds."
 843   (%time (null-pointer)))
 844
 845 (defsyscall (%gettimeofday "gettimeofday") :int
 846   (tp  :pointer)
 847   (tzp :pointer))
 848
 849 (defentrypoint gettimeofday ()
 850   "Return the time in seconds and microseconds."
 851   (with-foreign-object (tv 'timeval)
 852     (with-foreign-slots ((sec usec) tv timeval)
 853       (%gettimeofday tv (null-pointer))
 854       (values sec usec))))
 855
 856 #-darwin
 857 (progn
 858   (defsyscall (%clock-getres "clock_getres") :int
 859     "Returns the resolution of the clock CLOCKID."
 860     (clockid clockid-t)
 861     (res     :pointer))
 862
 863   (defentrypoint clock-getres (clock-id)
 864     (with-foreign-object (ts 'timespec)
 865       (with-foreign-slots ((sec nsec) ts timespec)
 866         (%clock-getres clock-id ts)
 867         (values sec nsec))))
 868
 869   (defsyscall (%clock-gettime "clock_gettime") :int
 870     (clockid clockid-t)
 871     (tp      :pointer))
 872
 873   (defentrypoint clock-gettime (clock-id)
 874     "Returns the time of the clock CLOCKID."
 875     (with-foreign-object (ts 'timespec)
 876       (with-foreign-slots ((sec nsec) ts timespec)
 877         (%clock-gettime clock-id ts)
 878         (values sec nsec))))
 879
 880   (defsyscall (%clock-settime "clock_settime") :int
 881     (clockid clockid-t)
 882     (tp      :pointer))
 883
 884   (defentrypoint clock-settime (clock-id)
 885     "Sets the time of the clock CLOCKID."
 886     (with-foreign-object (ts 'timespec)
 887       (with-foreign-slots ((sec nsec) ts timespec)
 888         (%clock-settime clock-id ts)
 889         (values sec nsec)))))
 890
 891 ;;; FIXME: or we can implement this through the MACH functions.
 892 #+darwin
 893 (progn
 894   (defctype kern-return-t :int)
 895   (defctype clock-res-t :int)
 896   (defctype clock-id-t :int)
 897   (defctype port-t :unsigned-int)         ; not sure
 898   (defctype clock-serv-t port-t)
 899
 900   (defconstant kern-success 0)
 901
 902   (defconstant system-clock 0)
 903   (defconstant calendar-clock 1)
 904   (defconstant realtime-clock 0)
 905
 906   (defsyscall (mach-host-self "mach_host_self") port-t)
 907
 908   (defsyscall (%host-get-clock-service "host_get_clock_service") kern-return-t
 909     (host       port-t)
 910     (id         clock-id-t)
 911     (clock-name :pointer))
 912
 913   (defentrypoint host-get-clock-service (id &optional (host (mach-host-self)))
 914     (with-foreign-object (clock 'clock-serv-t)
 915       (%host-get-clock-service host id clock)
 916       (mem-ref clock :int)))
 917
 918   (defsyscall (%clock-get-time "clock_get_time") kern-return-t
 919     (clock-serv clock-serv-t)
 920     (cur-time   timespec))
 921
 922   (defentrypoint clock-get-time (clock-service)
 923     (with-foreign-object (time 'timespec)
 924       (%clock-get-time clock-service time)
 925       (with-foreign-slots ((sec nsec) time timespec)
 926         (values sec nsec)))))
 927
 928 (defentrypoint get-monotonic-time ()
 929   "Gets current time in seconds from a system's monotonic clock."
 930   (multiple-value-bind (seconds nanoseconds)
 931       #-darwin (clock-gettime clock-monotonic)
 932       #+darwin (clock-get-time (host-get-clock-service system-clock))
 933     (+ seconds (/ nanoseconds 1d9))))
 934 \f
 935
 936 ;;;-------------------------------------------------------------------------
 937 ;;; Environement
 938 ;;;-------------------------------------------------------------------------
 939
 940 (defcvar ("environ" :read-only t) (:pointer :string))
 941
 942 (defentrypoint getenv (name)
 943   "Returns the value of environment variable NAME."
 944   (when (and (pointerp name) (null-pointer-p name))
 945     (setf (errno) einval)
 946     (signal-syscall-error))
 947   (foreign-funcall "getenv" :string name :string))
 948
 949 (defsyscall (setenv "setenv") :int
 950   "Changes the value of environment variable NAME to VALUE.
 951 The environment variable is overwritten only if overwrite is not NIL."
 952   (name      :string)
 953   (value     :string)
 954   (overwrite bool-designator))
 955
 956 (defsyscall (unsetenv "unsetenv") :int
 957   "Removes the binding of environment variable NAME."
 958   (name :string))
 959
 960 (defentrypoint clearenv ()
 961   "Remove all name-value pairs from the environment and set the external
 962 variable *environ* to NULL."
 963   (let ((envptr *environ*))
 964     (unless (null-pointer-p envptr)
 965       (loop :for i :from 0 :by 1
 966             :for string := (mem-aref envptr :string i)
 967             :for name := (subseq string 0 (position #\= string))
 968             :while name :do (unsetenv name))
 969       (setf (mem-ref envptr :pointer) (null-pointer)))
 970     (values)))
 971 \f
 972
 973 ;;;-------------------------------------------------------------------------
 974 ;;; Hostname info
 975 ;;;-------------------------------------------------------------------------
 976
 977 (defsyscall (%gethostname "gethostname") :int
 978   (name    :pointer)
 979   (namelen size-t))
 980
 981 (defentrypoint gethostname ()
 982   "Return the host name of the current machine."
 983   (with-foreign-pointer-as-string ((cstr size) 256)
 984     (%gethostname cstr size)))
 985
 986 (defsyscall (%getdomainname "getdomainname") :int
 987   (name    :pointer)
 988   (namelen size-t))
 989
 990 (defentrypoint getdomainname ()
 991   "Return the domain name of the current machine."
 992   (with-foreign-pointer-as-string ((cstr size) 256)
 993     (%getdomainname cstr size)))
 994
 995 (defsyscall (%uname "uname") :int
 996   (buf :pointer))
 997
 998 (defentrypoint uname ()
 999   "Get name and information about current kernel."
1000   (with-foreign-object (buf 'utsname)
1001     (bzero buf size-of-utsname)
1002     (%uname buf)
1003     (macrolet ((utsname-slot (name)
1004                  `(foreign-string-to-lisp
1005                    (foreign-slot-pointer buf 'utsname ',name))))
1006       (values (utsname-slot sysname)
1007               (utsname-slot nodename)
1008               (utsname-slot release)
1009               (utsname-slot version)
1010               (utsname-slot machine)))))
1011 \f
1012
1013 ;;;-------------------------------------------------------------------------
1014 ;;; User info
1015 ;;;-------------------------------------------------------------------------
1016
1017 (defsyscall (%getpwuid-r "getpwuid_r")
1018     (:int
1019      :error-predicate plusp
1020      :error-location :return)
1021   (uid     uid-t)
1022   (pwd     :pointer)
1023   (buffer  :pointer)
1024   (bufsize size-t)
1025   (result  :pointer))
1026
1027 (defsyscall (%getpwnam-r "getpwnam_r")
1028     (:int
1029      :error-predicate plusp
1030      :error-location :return)
1031   (name    :string)
1032   (pwd     :pointer)
1033   (buffer  :pointer)
1034   (bufsize size-t)
1035   (result  :pointer))
1036
1037 (defun funcall-getpw (fn arg)
1038   (with-foreign-objects ((pw 'passwd-entry) (pwp :pointer))
1039     (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1040       (with-foreign-slots ((name passwd uid gid gecos dir shell) pw passwd-entry)
1041         (funcall fn arg pw buf bufsize pwp)
1042         (if (null-pointer-p (mem-ref pwp :pointer))
1043             nil
1044             (values name passwd uid gid gecos dir shell))))))
1045
1046 (defentrypoint getpwuid (uid)
1047   "Gets the password-entry of a user, by user id (reentrant)."
1048   (funcall-getpw #'%getpwuid-r uid))
1049
1050 (defentrypoint getpwnam (name)
1051   "Gets the password-entry of a user, by username (reentrant)."
1052   (funcall-getpw #'%getpwnam-r name))
1053 \f
1054
1055 ;;;-------------------------------------------------------------------------
1056 ;;; Group info
1057 ;;;-------------------------------------------------------------------------
1058
1059 (defsyscall (%getgrgid-r "getgrgid_r")
1060     (:int
1061      :error-predicate plusp
1062      :error-location :return)
1063   (uid     uid-t)
1064   (grp     :pointer)
1065   (buffer  :pointer)
1066   (bufsize size-t)
1067   (result  :pointer))
1068
1069 (defsyscall (%getgrnam-r "getgrnam_r")
1070     (:int
1071      :error-predicate plusp
1072      :error-location :return)
1073   (name    :string)
1074   (grp     :pointer)
1075   (buffer  :pointer)
1076   (bufsize size-t)
1077   (result  :pointer))
1078
1079 ;; FIXME: return group members too
1080 (defun funcall-getgr (fn arg)
1081   (with-foreign-objects ((gr 'group-entry) (grp :pointer))
1082     (with-foreign-pointer (buf +cstring-path-max+ bufsize)
1083       (with-foreign-slots ((name passwd gid) gr group-entry)
1084         (funcall fn arg gr buf bufsize grp)
1085         (if (null-pointer-p (mem-ref grp :pointer))
1086             nil
1087             (values name passwd gid))))))
1088
1089 (defentrypoint getgrgid (gid)
1090   "Gets a group-entry, by group id (reentrant)."
1091   (funcall-getgr #'%getgrgid-r gid))
1092
1093 (defentrypoint getgrnam (name)
1094   "Gets a group-entry, by group name (reentrant)."
1095   (funcall-getgr #'%getgrnam-r name))