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