src/syscalls/ffi-functions-unix.lisp

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