From d6b8e1885f59bc36936107272881475db73c85db Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Sun, 3 May 2015 22:48:18 -0700 Subject: [PATCH] Small version of unix-glibc2.lisp that will compile lisp. This is enough to get do a full build of cmucl, but not motif. More work needed; I didn't yet check build logs for warnings or errors. --- src/code/unix-glibc2.lisp | 1738 +++++++++++++++++++++++++++++++++++++ 1 file changed, 1738 insertions(+) create mode 100644 src/code/unix-glibc2.lisp diff --git a/src/code/unix-glibc2.lisp b/src/code/unix-glibc2.lisp new file mode 100644 index 000000000..7aa7e1e0a --- /dev/null +++ b/src/code/unix-glibc2.lisp @@ -0,0 +1,1738 @@ +;;; -*- Package: UNIX -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/unix-glibc2.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the UNIX low-level support for glibc2. Based +;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998). +;;; Alpha support by Julian Dolby, 1999. +;;; +;;; All the functions with #+(or) in front are work in progress, +;;; and mostly don't work. +;;; +;; Todo: #+(or)'ed stuff and ioctl's +;; +;; +;; Large File Support (LFS) added by Pierre Mai and Eric Marsden, Feb +;; 2003. This is necessary to be able to read/write/stat files that +;; are larger than 2GB on a 32-bit system. From a C program, defining +;; a preprocessor macro _LARGEFILE64_SOURCE makes the preproccessor +;; replace a call to open() by open64(), and similarly for stat, +;; fstat, lstat, lseek, readdir and friends. Furthermore, certain data +;; types, that are normally 32 bits wide, are replaced by 64-bit wide +;; equivalents: off_t -> off64_t etc. The libc.so fiddles around with +;; weak symbols to support this mess. +;; +;; From CMUCL, we make FFI calls to the xxx64 functions, and use the +;; 64-bit wide versions of the data structures. The most ugly aspect +;; is that some of the stat functions are not available via dlsym, so +;; we reference them explicitly from linux-stubs.S. Another amusing +;; fact is that on glibc 2.2, stat64() returns a struct stat with a +;; 32-bit ino_t, whereas readdir64() returns a struct dirent that +;; contains a 64-bit ino_t. On glibc 2.1, OTOH, both stat64 and +;; readdir64 use structs with 32-bit ino_t. +;; +;; The current version deals with this by going with the glibc 2.2 +;; definitions, unless the keyword :glibc2.1 also occurs on *features*, +;; in addition to :glibc2, in which case we go with the glibc 2.1 +;; definitions. Note that binaries compiled against glibc 2.1 do in +;; fact work fine on glibc 2.2, because readdir64 is available in both +;; glibc 2.1 and glibc 2.2 versions in glibc 2.2, disambiguated through +;; ELF symbol versioning. We use an entry for readdir64 in linux-stubs.S +;; in order to force usage of the correct version of readdir64 at runtime. +;; +;; So in order to compile for glibc 2.2 and newer, just compile CMUCL +;; on a glibc 2.2 system, and make sure that :glibc2.1 doesn't appear +;; on the *features* list. In order to compile for glibc 2.1 and newer, +;; compile CMUCL on a glibc 2.1 system, and make sure that :glibc2.1 does +;; appear on the *features* list. + +(in-package "UNIX") +(use-package "ALIEN") +(use-package "C-CALL") +(use-package "SYSTEM") +(use-package "EXT") +(intl:textdomain "cmucl-unix-glibc2") + +;; Check the G_BROKEN_FILENAMES environment variable; if set the encoding +;; is locale-dependent...else use :utf-8 on Unicode Lisps. On 8 bit Lisps +;; it must be set to :iso8859-1 (or left as NIL), making files with +;; non-Latin-1 characters "mojibake", but otherwise they'll be inaccessible. +;; Must be set to NIL initially to enable building Lisp! +(defvar *filename-encoding* nil) + +(export '( + daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t + blkcnt-t fsblkcnt-t fsfilcnt-t + unix-lockf f_ulock f_lock f_tlock f_test + timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime + itimerval it-interval it-value tchars t-intrc t-quitc t-startc + t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc + t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill + sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel + direct d-off d-ino d-reclen d-name + stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size + st-atime st-mtime st-ctime st-blksize st-blocks + s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock + s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec + ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss + ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock + ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw + rlimit rlim-cur rlim-max sc-onstack sc-mask sc-pc + unix-errno get-unix-error-msg + prot_read prot_write prot_exec prot_none + map_shared map_private map_fixed map_anonymous + ms_async ms_sync ms_invalidate + unix-mmap unix-munmap unix-msync unix-mprotect + unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid + unix-setitimer unix-getitimer + unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec + setgidexec savetext readown writeown execown readgrp writegrp + execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown + unix-getdtablesize unix-close unix-creat unix-dup unix-dup2 + unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown + fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek + l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr + o_ndelay + o_noctty + o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink + unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr + fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate + unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl + unix-uname utsname + tcsetpgrp tcgetpgrp tty-process-group + terminal-speeds tty-raw tty-crmod tty-echo tty-lcase + tty-cbreak + termios + c-lflag + c-iflag + c-oflag + tty-icrnl + tty-ocrnl + veof + vintr + vquit + vstart + vstop + vsusp + c-cflag + c-cc + tty-icanon + vmin + vtime + tty-ixon + tcsanow + tcsadrain + tciflush + tcoflush + tcioflush + tcsaflush + unix-tcgetattr + unix-tcsetattr + tty-ignbrk + tty-brkint + tty-ignpar + tty-parmrk + tty-inpck + tty-istrip + tty-inlcr + tty-igncr + tty-iuclc + tty-ixany + tty-ixoff + tty-imaxbel + tty-opost + tty-olcuc + tty-onlcr + tty-onocr + tty-onlret + tty-ofill + tty-ofdel + tty-isig + tty-xcase + tty-echoe + tty-echok + tty-echonl + tty-noflsh + tty-iexten + tty-tostop + tty-echoctl + tty-echoprt + tty-echoke + tty-pendin + tty-cstopb + tty-cread + tty-parenb + tty-parodd + tty-hupcl + tty-clocal + vintr + verase + vkill + veol + veol2 + TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC + TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ + TIOCSIGSEND + + KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK + KBDSCLICK FIONREAD unix-exit unix-stat unix-lstat unix-fstat + unix-getrusage unix-fast-getrusage rusage_self rusage_children + unix-gettimeofday + unix-utimes unix-sched-yield unix-setreuid + unix-setregid + unix-getpid unix-getppid + unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid + unix-getpagesize unix-gethostname unix-gethostid unix-fork + unix-getenv unix-setenv unix-putenv unix-unsetenv + unix-current-directory unix-isatty unix-ttyname unix-execve + unix-socket unix-connect unix-bind unix-listen unix-accept + unix-recv unix-send unix-getpeername unix-getsockname + unix-getsockopt unix-setsockopt unix-openpty + + unix-recvfrom unix-sendto unix-shutdown + + unix-getpwnam unix-getpwuid unix-getgrnam unix-getgrgid + user-info user-info-name user-info-password user-info-uid + user-info-gid user-info-gecos user-info-dir user-info-shell + group-info group-info-name group-info-gid group-info-members)) + +(pushnew :unix *features*) +(pushnew :glibc2 *features*) + +;; needed for bootstrap +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro %name->file (string) + `(if *filename-encoding* + (string-encode ,string *filename-encoding*) + ,string)) + (defmacro %file->name (string) + `(if *filename-encoding* + (string-decode ,string *filename-encoding*) + ,string))) + +(defconstant +max-u-long+ 4294967295) + +(def-alien-type size-t #-alpha unsigned-int #+alpha long) +(def-alien-type time-t long) + +(def-alien-type uquad-t #+alpha unsigned-long + #-alpha (array unsigned-long 2)) +(def-alien-type u-int32-t unsigned-int) +(def-alien-type int64-t (signed 64)) +(def-alien-type u-int64-t (unsigned 64)) + +(def-alien-type dev-t #-amd64 uquad-t #+amd64 u-int64-t) +(def-alien-type uid-t unsigned-int) +(def-alien-type gid-t unsigned-int) +(def-alien-type ino-t #-amd64 u-int32-t #+amd64 u-int64-t) +(def-alien-type ino64-t u-int64-t) +(def-alien-type mode-t u-int32-t) +(def-alien-type nlink-t #-amd64 unsigned-int #+amd64 u-int64-t) +(def-alien-type off-t int64-t) +(def-alien-type blkcnt-t u-int64-t) + +;;;; Common machine independent structures. + + +;; Needed early in bootstrap. +(defun unix-current-directory () + _N"Put the absolute pathname of the current working directory in BUF. + If successful, return BUF. If not, put an error message in + BUF and return NULL. BUF should be at least PATH_MAX bytes long." + ;; 5120 is some randomly selected maximum size for the buffer for getcwd. + (with-alien ((buf (array c-call:char 5120))) + (let ((result (alien-funcall + (extern-alien "getcwd" + (function (* c-call:char) + (* c-call:char) c-call:int)) + (cast buf (* c-call:char)) + 5120))) + + (values (not (zerop (sap-int (alien-sap result)))) + (%file->name (cast buf c-call:c-string)))))) + +(defconstant o_read o_rdonly _N"Open for reading") +(defconstant o_write o_wronly _N"Open for writing") + +(defconstant o_rdonly 0 _N"Read-only flag.") +(defconstant o_wronly 1 _N"Write-only flag.") +(defconstant o_rdwr 2 _N"Read-write flag.") +(defconstant o_accmode 3 _N"Access mode mask.") + +#-alpha +(progn + (defconstant o_creat #o100 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_excl #o200 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o400 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_trunc #o1000 _N"Truncate flag. (not fcntl)") + (defconstant o_append #o2000 _N"Append flag.") + (defconstant o_ndelay #o4000 _N"Non-blocking I/O") + (defconstant o_nonblock #o4000 _N"Non-blocking I/O") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o10000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) +#+alpha +(progn + (defconstant o_creat #o1000 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_trunc #o2000 _N"Truncate flag. (not fcntl)") + (defconstant o_excl #o4000 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o10000 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_nonblock #o4 _N"Non-blocking I/O") + (defconstant o_append #o10 _N"Append flag.") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o40000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) + +#-alpha +(progn + (defconstant f-getlk 5 _N"Get lock") + (defconstant f-setlk 6 _N"Set lock") + (defconstant f-setlkw 7 _N"Set lock, wait for release") + (defconstant f-setown 8 _N"Set owner (for sockets)") + (defconstant f-getown 9 _N"Get owner (for sockets)")) +#+alpha +(progn + (defconstant f-getlk 7 _N"Get lock") + (defconstant f-setlk 8 _N"Set lock") + (defconstant f-setlkw 9 _N"Set lock, wait for release") + (defconstant f-setown 5 _N"Set owner (for sockets)") + (defconstant f-getown 6 _N"Get owner (for sockets)")) + +(defconstant F-CLOEXEC 1 _N"for f-getfl and f-setfl") +(defun unix-open (path flags mode) + _N"Unix-open opens the file whose pathname is specified by PATH + for reading and/or writing as specified by the FLAGS argument. + Returns an integer file descriptor. + The flags argument can be: + + o_rdonly Read-only flag. + o_wronly Write-only flag. + o_rdwr Read-and-write flag. + o_append Append flag. + o_creat Create-if-nonexistant flag. + o_trunc Truncate-to-size-0 flag. + o_excl Error if the file already exists + o_noctty Don't assign controlling tty + o_ndelay Non-blocking I/O + o_sync Synchronous I/O + o_async Asynchronous I/O + + If the o_creat flag is specified, then the file is created with + a permission of argument MODE if the file doesn't exist." + (declare (type unix-pathname path) + (type fixnum flags) + (type unix-file-mode mode)) + (int-syscall ("open64" c-string int int) (%name->file path) flags mode)) + +;;; asm/errno.h +(eval-when (compile eval) + +(defparameter *compiler-unix-errors* nil) + +(defmacro def-unix-error (name number description) + `(progn + (eval-when (compile eval) + (push (cons ,number ,description) *compiler-unix-errors*)) + (defconstant ,name ,number ,description) + (export ',name))) + +(defmacro emit-unix-errors () + (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) + (array (make-array (1+ max) :initial-element nil))) + (dolist (error *compiler-unix-errors*) + (setf (svref array (car error)) (cdr error))) + `(progn + (defvar *unix-errors* ',array) + (declaim (simple-vector *unix-errors*))))) + +) + +(def-unix-error ESUCCESS 0 _N"Successful") +(def-unix-error EPERM 1 _N"Operation not permitted") +(def-unix-error ENOENT 2 _N"No such file or directory") +(def-unix-error ESRCH 3 _N"No such process") +(def-unix-error EINTR 4 _N"Interrupted system call") +(def-unix-error EIO 5 _N"I/O error") +(def-unix-error ENXIO 6 _N"No such device or address") +(def-unix-error E2BIG 7 _N"Arg list too long") +(def-unix-error ENOEXEC 8 _N"Exec format error") +(def-unix-error EBADF 9 _N"Bad file number") +(def-unix-error ECHILD 10 _N"No children") +(def-unix-error EAGAIN 11 _N"Try again") +(def-unix-error ENOMEM 12 _N"Out of memory") +(def-unix-error EACCES 13 _N"Permission denied") +(def-unix-error EFAULT 14 _N"Bad address") +(def-unix-error ENOTBLK 15 _N"Block device required") +(def-unix-error EBUSY 16 _N"Device or resource busy") +(def-unix-error EEXIST 17 _N"File exists") +(def-unix-error EXDEV 18 _N"Cross-device link") +(def-unix-error ENODEV 19 _N"No such device") +(def-unix-error ENOTDIR 20 _N"Not a director") +(def-unix-error EISDIR 21 _N"Is a directory") +(def-unix-error EINVAL 22 _N"Invalid argument") +(def-unix-error ENFILE 23 _N"File table overflow") +(def-unix-error EMFILE 24 _N"Too many open files") +(def-unix-error ENOTTY 25 _N"Not a typewriter") +(def-unix-error ETXTBSY 26 _N"Text file busy") +(def-unix-error EFBIG 27 _N"File too large") +(def-unix-error ENOSPC 28 _N"No space left on device") +(def-unix-error ESPIPE 29 _N"Illegal seek") +(def-unix-error EROFS 30 _N"Read-only file system") +(def-unix-error EMLINK 31 _N"Too many links") +(def-unix-error EPIPE 32 _N"Broken pipe") +;;; +;;; Math +(def-unix-error EDOM 33 _N"Math argument out of domain") +(def-unix-error ERANGE 34 _N"Math result not representable") +;;; +(def-unix-error EDEADLK 35 _N"Resource deadlock would occur") +(def-unix-error ENAMETOOLONG 36 _N"File name too long") +(def-unix-error ENOLCK 37 _N"No record locks available") +(def-unix-error ENOSYS 38 _N"Function not implemented") +(def-unix-error ENOTEMPTY 39 _N"Directory not empty") +(def-unix-error ELOOP 40 _N"Too many symbolic links encountered") +(def-unix-error EWOULDBLOCK 11 _N"Operation would block") +(def-unix-error ENOMSG 42 _N"No message of desired type") +(def-unix-error EIDRM 43 _N"Identifier removed") +(def-unix-error ECHRNG 44 _N"Channel number out of range") +(def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized") +(def-unix-error EL3HLT 46 _N"Level 3 halted") +(def-unix-error EL3RST 47 _N"Level 3 reset") +(def-unix-error ELNRNG 48 _N"Link number out of range") +(def-unix-error EUNATCH 49 _N"Protocol driver not attached") +(def-unix-error ENOCSI 50 _N"No CSI structure available") +(def-unix-error EL2HLT 51 _N"Level 2 halted") +(def-unix-error EBADE 52 _N"Invalid exchange") +(def-unix-error EBADR 53 _N"Invalid request descriptor") +(def-unix-error EXFULL 54 _N"Exchange full") +(def-unix-error ENOANO 55 _N"No anode") +(def-unix-error EBADRQC 56 _N"Invalid request code") +(def-unix-error EBADSLT 57 _N"Invalid slot") +(def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error") +(def-unix-error EBFONT 59 _N"Bad font file format") +(def-unix-error ENOSTR 60 _N"Device not a stream") +(def-unix-error ENODATA 61 _N"No data available") +(def-unix-error ETIME 62 _N"Timer expired") +(def-unix-error ENOSR 63 _N"Out of streams resources") +(def-unix-error ENONET 64 _N"Machine is not on the network") +(def-unix-error ENOPKG 65 _N"Package not installed") +(def-unix-error EREMOTE 66 _N"Object is remote") +(def-unix-error ENOLINK 67 _N"Link has been severed") +(def-unix-error EADV 68 _N"Advertise error") +(def-unix-error ESRMNT 69 _N"Srmount error") +(def-unix-error ECOMM 70 _N"Communication error on send") +(def-unix-error EPROTO 71 _N"Protocol error") +(def-unix-error EMULTIHOP 72 _N"Multihop attempted") +(def-unix-error EDOTDOT 73 _N"RFS specific error") +(def-unix-error EBADMSG 74 _N"Not a data message") +(def-unix-error EOVERFLOW 75 _N"Value too large for defined data type") +(def-unix-error ENOTUNIQ 76 _N"Name not unique on network") +(def-unix-error EBADFD 77 _N"File descriptor in bad state") +(def-unix-error EREMCHG 78 _N"Remote address changed") +(def-unix-error ELIBACC 79 _N"Can not access a needed shared library") +(def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library") +(def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted") +(def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries") +(def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly") +(def-unix-error EILSEQ 84 _N"Illegal byte sequence") +(def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N") +(def-unix-error ESTRPIPE 86 _N"Streams pipe error") +(def-unix-error EUSERS 87 _N"Too many users") +(def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket") +(def-unix-error EDESTADDRREQ 89 _N"Destination address required") +(def-unix-error EMSGSIZE 90 _N"Message too long") +(def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket") +(def-unix-error ENOPROTOOPT 92 _N"Protocol not available") +(def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported") +(def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported") +(def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint") +(def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported") +(def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol") +(def-unix-error EADDRINUSE 98 _N"Address already in use") +(def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address") +(def-unix-error ENETDOWN 100 _N"Network is down") +(def-unix-error ENETUNREACH 101 _N"Network is unreachable") +(def-unix-error ENETRESET 102 _N"Network dropped connection because of reset") +(def-unix-error ECONNABORTED 103 _N"Software caused connection abort") +(def-unix-error ECONNRESET 104 _N"Connection reset by peer") +(def-unix-error ENOBUFS 105 _N"No buffer space available") +(def-unix-error EISCONN 106 _N"Transport endpoint is already connected") +(def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected") +(def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown") +(def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice") +(def-unix-error ETIMEDOUT 110 _N"Connection timed out") +(def-unix-error ECONNREFUSED 111 _N"Connection refused") +(def-unix-error EHOSTDOWN 112 _N"Host is down") +(def-unix-error EHOSTUNREACH 113 _N"No route to host") +(def-unix-error EALREADY 114 _N"Operation already in progress") +(def-unix-error EINPROGRESS 115 _N"Operation now in progress") +(def-unix-error ESTALE 116 _N"Stale NFS file handle") +(def-unix-error EUCLEAN 117 _N"Structure needs cleaning") +(def-unix-error ENOTNAM 118 _N"Not a XENIX named type file") +(def-unix-error ENAVAIL 119 _N"No XENIX semaphores available") +(def-unix-error EISNAM 120 _N"Is a named type file") +(def-unix-error EREMOTEIO 121 _N"Remote I/O error") +(def-unix-error EDQUOT 122 _N"Quota exceeded") + +;;; And now for something completely different ... +(emit-unix-errors) + +(def-alien-type nil + (struct passwd + (pw-name (* char)) ; user's login name + (pw-passwd (* char)) ; no longer used + (pw-uid uid-t) ; user id + (pw-gid gid-t) ; group id + (pw-gecos (* char)) ; typically user's full name + (pw-dir (* char)) ; user's home directory + (pw-shell (* char)))) ; user's login shell + +;;;; System calls. + +(def-alien-routine ("os_get_errno" unix-get-errno) int) +(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int)) +(defun unix-errno () (unix-get-errno)) +(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue)) + +;;; GET-UNIX-ERROR-MSG -- public. +;;; +(defun get-unix-error-msg (&optional (error-number (unix-errno))) + _N"Returns a string describing the error number which was returned by a + UNIX system call." + (declare (type integer error-number)) + + (if (array-in-bounds-p *unix-errors* error-number) + (svref *unix-errors* error-number) + (format nil (intl:gettext "Unknown error [~d]") error-number))) + +(defmacro syscall ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (values nil (unix-errno)) + ,success-form))) + +;;; Like syscall, but if it fails, signal an error instead of returning error +;;; codes. Should only be used for syscalls that will never really get an +;;; error. +;;; +(defmacro syscall* ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (error (intl:gettext "Syscall ~A failed: ~A") ,name (get-unix-error-msg)) + ,success-form))) + +(defmacro void-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values t 0) ,@args)) + +(defmacro int-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values result 0) ,@args)) + +;;; Unix-write accepts a file descriptor, a buffer, an offset, and the +;;; length to write. It attempts to write len bytes to the device +;;; associated with fd from the the buffer starting at offset. It returns +;;; the actual number of bytes written. + +(defun unix-write (fd buf offset len) + _N"Unix-write attempts to write a character buffer (buf) of length + len to the file described by the file descriptor fd. NIL and an + error is returned if the call is unsuccessful." + (declare (type unix-fd fd) + (type (unsigned-byte 32) offset len)) + (int-syscall ("write" int (* char) int) + fd + (with-alien ((ptr (* char) (etypecase buf + ((simple-array * (*)) + (vector-sap buf)) + (system-area-pointer + buf)))) + (addr (deref ptr offset))) + len)) + +(defun unix-pipe () + _N"Unix-pipe sets up a unix-piping mechanism consisting of + an input pipe and an output pipe. Unix-Pipe returns two + values: if no error occurred the first value is the pipe + to be read from and the second is can be written to. If + an error occurred the first value is NIL and the second + the unix error code." + (with-alien ((fds (array int 2))) + (syscall ("pipe" (* int)) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int))))) + +;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. +;;; It attempts to read len bytes from the device associated with fd +;;; and store them into the buffer. It returns the actual number of +;;; bytes read. + +(defun unix-read (fd buf len) + _N"UNIX-READ attempts to read from the file described by fd into + the buffer buf until it is full. Len is the length of the buffer. + The number of bytes actually read is returned or NIL and an error + number if an error occured." + (declare (type unix-fd fd) + (type (unsigned-byte 32) len)) + #+gencgc + ;; With gencgc, the collector tries to keep raw objects like strings + ;; in separate pages that are not write-protected. However, this + ;; isn't always true. Thus, BUF will sometimes be write-protected + ;; and the kernel doesn't like writing to write-protected pages. So + ;; go through and touch each page to give the segv handler a chance + ;; to unprotect the pages. (This is taken from unix.lisp.) + (without-gcing + (let* ((page-size (get-page-size)) + (1-page-size (1- page-size)) + (sap (etypecase buf + (system-area-pointer buf) + (vector (vector-sap buf)))) + (end (sap+ sap len))) + (declare (type (and fixnum unsigned-byte) page-size 1-page-size) + (type system-area-pointer sap end) + (optimize (speed 3) (safety 0))) + ;; Touch the beginning of every page + (do ((sap (int-sap (logand (sap-int sap) + (logxor 1-page-size (ldb (byte 32 0) -1)))) + (sap+ sap page-size))) + ((sap>= sap end)) + (declare (type system-area-pointer sap)) + (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0))))) + (int-syscall ("read" int (* char) int) fd buf len)) + +;;; Unix-getpagesize returns the number of bytes in the system page. + +(defun unix-getpagesize () + _N"Unix-getpagesize returns the number of bytes in a system page." + (int-syscall ("getpagesize"))) + +;;; sys/stat.h + +(defmacro extract-stat-results (buf) + `(values T + #+(or alpha amd64) + (slot ,buf 'st-dev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-dev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-ino) + (slot ,buf 'st-mode) + (slot ,buf 'st-nlink) + (slot ,buf 'st-uid) + (slot ,buf 'st-gid) + #+(or alpha amd64) + (slot ,buf 'st-rdev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-rdev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-size) + (slot ,buf 'st-atime) + (slot ,buf 'st-mtime) + (slot ,buf 'st-ctime) + (slot ,buf 'st-blksize) + (slot ,buf 'st-blocks))) + +;;; bits/stat.h + +(def-alien-type nil + (struct stat + (st-dev dev-t) + #-(or alpha amd64) (st-pad1 unsigned-short) + (st-ino ino-t) + #+alpha (st-pad1 unsigned-int) + #-amd64 (st-mode mode-t) + (st-nlink nlink-t) + #+amd64 (st-mode mode-t) + (st-uid uid-t) + (st-gid gid-t) + (st-rdev dev-t) + #-alpha (st-pad2 unsigned-short) + (st-size off-t) + #-alpha (st-blksize unsigned-long) + #-alpha (st-blocks blkcnt-t) + (st-atime time-t) + #-alpha (unused-1 unsigned-long) + (st-mtime time-t) + #-alpha (unused-2 unsigned-long) + (st-ctime time-t) + #+alpha (st-blocks int) + #+alpha (st-pad2 unsigned-int) + #+alpha (st-blksize unsigned-int) + #+alpha (st-flags unsigned-int) + #+alpha (st-gen unsigned-int) + #+alpha (st-pad3 unsigned-int) + #+alpha (unused-1 unsigned-long) + #+alpha (unused-2 unsigned-long) + (unused-3 unsigned-long) + (unused-4 unsigned-long) + #-alpha (unused-5 unsigned-long))) + +(defun unix-stat (name) + _N"UNIX-STAT retrieves information about the specified + file returning them in the form of multiple values. + See the UNIX Programmer's Manual for a description + of the values returned. If the call fails, then NIL + and an error number is returned instead." + (declare (type unix-pathname name)) + (when (string= name "") + (setf name ".")) + (with-alien ((buf (struct stat))) + (syscall ("stat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) + +(defun unix-fstat (fd) + _N"UNIX-FSTAT is similar to UNIX-STAT except the file is specified + by the file descriptor FD." + (declare (type unix-fd fd)) + (with-alien ((buf (struct stat))) + (syscall ("fstat64" int (* (struct stat))) + (extract-stat-results buf) + fd (addr buf)))) + +(defun unix-lstat (name) + _N"UNIX-LSTAT is similar to UNIX-STAT except the specified + file must be a symbolic link." + (declare (type unix-pathname name)) + (with-alien ((buf (struct stat))) + (syscall ("lstat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) + +;; Encoding of the file mode. + +(defconstant s-ifmt #o0170000 _N"These bits determine file type.") + +;; File types. + +(defconstant s-ififo #o0010000 _N"FIFO") +(defconstant s-ifchr #o0020000 _N"Character device") +(defconstant s-ifdir #o0040000 _N"Directory") +(defconstant s-ifblk #o0060000 _N"Block device") +(defconstant s-ifreg #o0100000 _N"Regular file") + +;; These don't actually exist on System V, but having them doesn't hurt. + +(defconstant s-iflnk #o0120000 _N"Symbolic link.") +(defconstant s-ifsock #o0140000 _N"Socket.") +(defun unix-file-kind (name &optional check-for-links) + _N"Returns either :file, :directory, :link, :special, or NIL." + (declare (simple-string name)) + (multiple-value-bind (res dev ino mode) + (if check-for-links + (unix-lstat name) + (unix-stat name)) + (declare (type (or fixnum null) mode) + (ignore dev ino)) + (when res + (let ((kind (logand mode s-ifmt))) + (cond ((eql kind s-ifdir) :directory) + ((eql kind s-ifreg) :file) + ((eql kind s-iflnk) :link) + (t :special)))))) + +(defun unix-maybe-prepend-current-directory (name) + (declare (simple-string name)) + (if (and (> (length name) 0) (char= (schar name 0) #\/)) + name + (multiple-value-bind (win dir) (unix-current-directory) + (if win + (concatenate 'simple-string dir "/" name) + name)))) + +;; Values for the second argument to access. + +;;; Unix-access accepts a path and a mode. It returns two values the +;;; first is T if the file is accessible and NIL otherwise. The second +;;; only has meaning in the second case and is the unix errno value. + +(defun unix-access (path mode) + _N"Given a file path (a string) and one of four constant modes, + unix-access returns T if the file is accessible with that + mode and NIL if not. It also returns an errno value with + NIL which determines why the file was not accessible. + + The access modes are: + r_ok Read permission. + w_ok Write permission. + x_ok Execute permission. + f_ok Presence of file." + (declare (type unix-pathname path) + (type (mod 8) mode)) + (void-syscall ("access" c-string int) (%name->file path) mode)) + +(defconstant l_set 0 _N"set the file pointer") +(defconstant l_incr 1 _N"increment the file pointer") +(defconstant l_xtnd 2 _N"extend the file size") + +(defun unix-lseek (fd offset whence) + _N"UNIX-LSEEK accepts a file descriptor and moves the file pointer ahead + a certain OFFSET for that file. WHENCE can be any of the following: + + l_set Set the file pointer. + l_incr Increment the file pointer. + l_xtnd Extend the file size. + " + (declare (type unix-fd fd) + (type (signed-byte 64) offset) + (type (integer 0 2) whence)) + (let ((result (alien-funcall + (extern-alien "lseek64" (function off-t int off-t int)) + fd offset whence))) + (if (minusp result) + (values nil (unix-errno)) + (values result 0)))) +;;; Unix-close accepts a file descriptor and attempts to close the file +;;; associated with it. + +(defun unix-close (fd) + _N"Unix-close takes an integer file descriptor as an argument and + closes the file associated with it. T is returned upon successful + completion, otherwise NIL and an error number." + (declare (type unix-fd fd)) + (void-syscall ("close" int) fd)) + +(defun unix-resolve-links (pathname) + _N"Returns the pathname with all symbolic links resolved." + (declare (simple-string pathname)) + (let ((len (length pathname)) + (pending pathname)) + (declare (fixnum len) (simple-string pending)) + (if (zerop len) + pathname + (let ((result (make-string 100 :initial-element (code-char 0))) + (fill-ptr 0) + (name-start 0)) + (loop + (let* ((name-end (or (position #\/ pending :start name-start) len)) + (new-fill-ptr (+ fill-ptr (- name-end name-start)))) + ;; grow the result string, if necessary. the ">=" (instead of + ;; using ">") allows for the trailing "/" if we find this + ;; component is a directory. + (when (>= new-fill-ptr (length result)) + (let ((longer (make-string (* 3 (length result)) + :initial-element (code-char 0)))) + (replace longer result :end1 fill-ptr) + (setq result longer))) + (replace result pending + :start1 fill-ptr + :end1 new-fill-ptr + :start2 name-start + :end2 name-end) + (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t))) + (unless kind (return nil)) + (cond ((eq kind :link) + (multiple-value-bind (link err) (unix-readlink result) + (unless link + (error (intl:gettext "Error reading link ~S: ~S") + (subseq result 0 fill-ptr) + (get-unix-error-msg err))) + (cond ((or (zerop (length link)) + (char/= (schar link 0) #\/)) + ;; It's a relative link + (fill result (code-char 0) + :start fill-ptr + :end new-fill-ptr)) + ((string= result "/../" :end1 4) + ;; It's across the super-root. + (let ((slash (or (position #\/ result :start 4) + 0))) + (fill result (code-char 0) + :start slash + :end new-fill-ptr) + (setf fill-ptr slash))) + (t + ;; It's absolute. + (and (> (length link) 0) + (char= (schar link 0) #\/)) + (fill result (code-char 0) :end new-fill-ptr) + (setf fill-ptr 0))) + (setf pending + (if (= name-end len) + link + (concatenate 'simple-string + link + (subseq pending name-end)))) + (setf len (length pending)) + (setf name-start 0))) + ((= name-end len) + (when (eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (incf new-fill-ptr)) + (return (subseq result 0 new-fill-ptr))) + ((eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (setf fill-ptr (1+ new-fill-ptr)) + (setf name-start (1+ name-end))) + (t + (return nil)))))))))) + +(defun unix-simplify-pathname (src) + (declare (simple-string src)) + (let* ((src-len (length src)) + (dst (make-string src-len)) + (dst-len 0) + (dots 0) + (last-slash nil)) + (macrolet ((deposit (char) + `(progn + (setf (schar dst dst-len) ,char) + (incf dst-len)))) + (dotimes (src-index src-len) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((char= char #\/) + (case dots + (0 + ;; Either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; Either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some random dir. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; Something other than a dot between slashes. + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len)))))) + (when (and last-slash (not (zerop last-slash))) + (case dots + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (char= (schar dst (- last-slash 3)) #\/))) + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from unix-simplify-pathname "./"))))))) + (cond ((zerop dst-len) + "./") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len))))) + +(defun unix-gethostname () + _N"Unix-gethostname returns the name of the host machine as a string." + (with-alien ((buf (array char 256))) + (syscall* ("gethostname" (* char) int) + (cast buf c-string) + (cast buf (* char)) 256))) + +;;; Unix-dup returns a duplicate copy of the existing file-descriptor +;;; passed as an argument. + +(defun unix-dup (fd) + _N"Unix-dup duplicates an existing file descriptor (given as the + argument) and return it. If FD is not a valid file descriptor, NIL + and an error number are returned." + (declare (type unix-fd fd)) + (int-syscall ("dup" int) fd)) + +;;; Unix-dup2 makes the second file-descriptor describe the same file +;;; as the first. If the second file-descriptor points to an open +;;; file, it is first closed. In any case, the second should have a +;;; value which is a valid file-descriptor. + +(defun unix-dup2 (fd1 fd2) + _N"Unix-dup2 duplicates an existing file descriptor just as unix-dup + does only the new value of the duplicate descriptor may be requested + through the second argument. If a file already exists with the + requested descriptor number, it will be closed and the number + assigned to the duplicate." + (declare (type unix-fd fd1 fd2)) + (void-syscall ("dup2" int int) fd1 fd2)) + +(defun unix-exit (&optional (code 0)) + _N"Unix-exit terminates the current process with an optional + error code. If successful, the call doesn't return. If + unsuccessful, the call returns NIL and an error number." + (declare (type (signed-byte 32) code)) + (void-syscall ("exit" int) code)) + +;;; Unix-chdir accepts a directory name and makes that the +;;; current working directory. + +(defun unix-chdir (path) + _N"Given a file path string, unix-chdir changes the current working + directory to the one specified." + (declare (type unix-pathname path)) + (void-syscall ("chdir" c-string) (%name->file path))) + +;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode. + +(defun unix-chmod (path mode) + _N"Given a file path string and a constant mode, unix-chmod changes the + permission mode for that file to the one specified. The new mode + can be created by logically OR'ing the following: + + setuidexec Set user ID on execution. + setgidexec Set group ID on execution. + savetext Save text image after execution. + readown Read by owner. + writeown Write by owner. + execown Execute (search directory) by owner. + readgrp Read by group. + writegrp Write by group. + execgrp Execute (search directory) by group. + readoth Read by others. + writeoth Write by others. + execoth Execute (search directory) by others. + + Thus #o444 and (logior unix:readown unix:readgrp unix:readoth) + are equivalent for 'mode. The octal-base is familar to Unix users. + + It returns T on successfully completion; NIL and an error number + otherwise." + (declare (type unix-pathname path) + (type unix-file-mode mode)) + (void-syscall ("chmod" c-string int) (%name->file path) mode)) + +(defun unix-readlink (path) + _N"Unix-readlink invokes the readlink system call on the file name + specified by the simple string path. It returns up to two values: + the contents of the symbolic link if the call is successful, or + NIL and the Unix error number." + (declare (type unix-pathname path)) + (with-alien ((buf (array char 1024))) + (syscall ("readlink" c-string (* char) int) + (let ((string (make-string result))) + #-unicode + (kernel:copy-from-system-area + (alien-sap buf) 0 + string (* vm:vector-data-offset vm:word-bits) + (* result vm:byte-bits)) + #+unicode + (let ((sap (alien-sap buf))) + (dotimes (k result) + (setf (aref string k) (code-char (sap-ref-8 sap k))))) + (%file->name string)) + (%name->file path) (cast buf (* char)) 1024))) + +;;; Unix-unlink accepts a name and deletes the directory entry for that +;;; name and the file if this is the last link. + +(defun unix-unlink (name) + _N"Unix-unlink removes the directory entry for the named file. + NIL and an error code is returned if the call fails." + (declare (type unix-pathname name)) + (void-syscall ("unlink" c-string) (%name->file name))) + +(defconstant r_ok 4 _N"Test for read permission") +(defconstant w_ok 2 _N"Test for write permission") +(defconstant x_ok 1 _N"Test for execute permission") +(defconstant f_ok 0 _N"Test for presence of file") + +(defun unix-fcntl (fd cmd arg) + _N"Unix-fcntl manipulates file descriptors accoridng to the + argument CMD which can be one of the following: + + F-DUPFD Duplicate a file descriptor. + F-GETFD Get file descriptor flags. + F-SETFD Set file descriptor flags. + F-GETFL Get file flags. + F-SETFL Set file flags. + F-GETOWN Get owner. + F-SETOWN Set owner. + + The flags that can be specified for F-SETFL are: + + FNDELAY Non-blocking reads. + FAPPEND Append on each write. + FASYNC Signal pgrp when data ready. + FCREAT Create if nonexistant. + FTRUNC Truncate to zero length. + FEXCL Error if already created. + " + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd) + (type (unsigned-byte 32) arg)) + (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg)) + +;;;; Memory-mapped files + +(defconstant +null+ (sys:int-sap 0)) + +(defconstant prot_read 1) +(defconstant prot_write 2) +(defconstant prot_exec 4) +(defconstant prot_none 0) + +;;; Unix-rename accepts two files names and renames the first to the second. + +(defun unix-rename (name1 name2) + _N"Unix-rename renames the file with string name1 to the string + name2. NIL and an error code is returned if an error occured." + (declare (type unix-pathname name1 name2)) + (void-syscall ("rename" c-string c-string) + (%name->file name1) (%name->file name2))) + +(def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int) + +(defconstant fd-setsize 1024) +(defconstant nfdbits 32) + +(def-alien-type nil + (struct fd-set + (fds-bits (array fd-mask #.(/ fd-setsize nfdbits))))) + +;; not checked for linux... +(defmacro fd-clr (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logand (deref (slot ,fd-set 'fds-bits) ,word) + (32bit-logical-not + (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) + +;; not checked for linux... +(defmacro fd-isset (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) + +;; not checked for linux... +(defmacro fd-set (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) + (deref (slot ,fd-set 'fds-bits) ,word)))))) + +;; not checked for linux... +(defmacro fd-zero (fd-set) + `(progn + ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) + +;;; TTY ioctl commands. + +(defconstant iocparm-mask #x3fff) +(defconstant ioc_void #x00000000) +(defconstant ioc_out #x40000000) +(defconstant ioc_in #x80000000) +(defconstant ioc_inout (logior ioc_in ioc_out)) + +(defmacro define-ioctl-command (name dev cmd &optional arg parm-type) + _N"Define an ioctl command. If the optional ARG and PARM-TYPE are given + then ioctl argument size and direction are included as for ioctls defined + by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type + is the characters code, else DEV may be an integer giving the type." + (let* ((type (if (characterp dev) + (char-code dev) + dev)) + (code (logior (ash type 8) cmd))) + (when arg + (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask) + 16) + ,code))) + (when parm-type + (let ((dir (ecase parm-type + (:void ioc_void) + (:in ioc_in) + (:out ioc_out) + (:inout ioc_inout)))) + (setf code `(logior ,dir ,code)))) + `(eval-when (eval load compile) + (defconstant ,name ,code)))) + +(define-ioctl-command TIOCGWINSZ #\T #x13) +(define-ioctl-command TIOCSWINSZ #\T #x14) +(define-ioctl-command TIOCNOTTY #\T #x22) +(define-ioctl-command TIOCSPGRP #\T #x10) +(define-ioctl-command TIOCGPGRP #\T #x0F) + +(defconstant f-getfl 3 _N"Get file flags") +(defconstant f-setfl 4 _N"Set file flags") + +;;; Define some more compatibility macros to be backward compatible with +;;; BSD systems which did not managed to hide these kernel macros. + +(defconstant FAPPEND o_append _N"depricated stuff") +(defconstant FFSYNC o_fsync _N"depricated stuff") +(defconstant FASYNC o_async _N"depricated stuff") +(defconstant FNONBLOCK o_nonblock _N"depricated stuff") +(defconstant FNDELAY o_ndelay _N"depricated stuff") + +(defun unix-mprotect (addr length prot) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length) + (type (integer 1 7) prot)) + (syscall ("mprotect" system-area-pointer size-t int) + t addr length prot)) + +;;;; Lisp types used by syscalls. + +(deftype unix-pathname () 'simple-string) +(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) + +(deftype unix-file-mode () '(unsigned-byte 32)) +(deftype unix-pid () '(unsigned-byte 32)) +(deftype unix-uid () '(unsigned-byte 32)) +(deftype unix-gid () '(unsigned-byte 32)) + +;;; Operations on Unix Directories. + +;;; direntry.h + +(def-alien-type nil + (struct dirent + #+glibc2.1 + (d-ino ino-t) ; inode number of entry + #-glibc2.1 + (d-ino ino64-t) ; inode number of entry + (d-off off-t) ; offset of next disk directory entry + (d-reclen unsigned-short) ; length of this record + (d_type unsigned-char) + (d-name (array char 256)))) ; name must be no longer than this + +(export '(open-dir read-dir close-dir)) + +(defstruct (%directory + (:constructor make-directory) + (:conc-name directory-) + (:print-function %print-directory)) + name + (dir-struct (required-argument) :type system-area-pointer)) + +(defun %print-directory (dir stream depth) + (declare (ignore depth)) + (format stream "#<Directory ~S>" (directory-name dir))) + +(defun open-dir (pathname) + (declare (type unix-pathname pathname)) + (when (string= pathname "") + (setf pathname ".")) + (let ((kind (unix-file-kind pathname))) + (case kind + (:directory + (let ((dir-struct + (alien-funcall (extern-alien "opendir" + (function system-area-pointer + c-string)) + (%name->file pathname)))) + (if (zerop (sap-int dir-struct)) + (values nil (unix-errno)) + (make-directory :name pathname :dir-struct dir-struct)))) + ((nil) + (values nil enoent)) + (t + (values nil enotdir))))) + +(defun read-dir (dir) + (declare (type %directory dir)) + (let ((daddr (alien-funcall (extern-alien "readdir64" + (function system-area-pointer + system-area-pointer)) + (directory-dir-struct dir)))) + (declare (type system-area-pointer daddr)) + (if (zerop (sap-int daddr)) + nil + (with-alien ((dirent (* (struct dirent)) daddr)) + (values (%file->name (cast (slot dirent 'd-name) c-string)) + (slot dirent 'd-ino)))))) + +(defun close-dir (dir) + (declare (type %directory dir)) + (alien-funcall (extern-alien "closedir" + (function void system-area-pointer)) + (directory-dir-struct dir)) + nil) + +(defconstant rusage_self 0 _N"The calling process.") +(defconstant rusage_children -1 _N"Terminated child processes.") +(defconstant rusage_both -2) + +(def-alien-type nil + (struct rusage + (ru-utime (struct timeval)) ; user time used + (ru-stime (struct timeval)) ; system time used. + (ru-maxrss long) ; Maximum resident set size (in kilobytes) + (ru-ixrss long) ; integral shared memory size + (ru-idrss long) ; integral unshared data " + (ru-isrss long) ; integral unshared stack " + (ru-minflt long) ; page reclaims + (ru-majflt long) ; page faults + (ru-nswap long) ; swaps + (ru-inblock long) ; block input operations + (ru-oublock long) ; block output operations + (ru-msgsnd long) ; messages sent + (ru-msgrcv long) ; messages received + (ru-nsignals long) ; signals received + (ru-nvcsw long) ; voluntary context switches + (ru-nivcsw long))) + +(declaim (inline unix-fast-getrusage)) +(defun unix-fast-getrusage (who) + _N"Like call getrusage, but return only the system and user time, and returns + the seconds and microseconds as separate values." + (declare (values (member t) + (unsigned-byte 31) (mod 1000000) + (unsigned-byte 31) (mod 1000000))) + (with-alien ((usage (struct rusage))) + (syscall* ("getrusage" int (* (struct rusage))) + (values t + (slot (slot usage 'ru-utime) 'tv-sec) + (slot (slot usage 'ru-utime) 'tv-usec) + (slot (slot usage 'ru-stime) 'tv-sec) + (slot (slot usage 'ru-stime) 'tv-usec)) + who (addr usage)))) + +(defun unix-getrusage (who) + _N"Unix-getrusage returns information about the resource usage + of the process specified by who. Who can be either the + current process (rusage_self) or all of the terminated + child processes (rusage_children). NIL and an error number + is returned if the call fails." + (with-alien ((usage (struct rusage))) + (syscall ("getrusage" int (* (struct rusage))) + (values t + (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000) + (slot (slot usage 'ru-utime) 'tv-usec)) + (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000) + (slot (slot usage 'ru-stime) 'tv-usec)) + (slot usage 'ru-maxrss) + (slot usage 'ru-ixrss) + (slot usage 'ru-idrss) + (slot usage 'ru-isrss) + (slot usage 'ru-minflt) + (slot usage 'ru-majflt) + (slot usage 'ru-nswap) + (slot usage 'ru-inblock) + (slot usage 'ru-oublock) + (slot usage 'ru-msgsnd) + (slot usage 'ru-msgrcv) + (slot usage 'ru-nsignals) + (slot usage 'ru-nvcsw) + (slot usage 'ru-nivcsw)) + who (addr usage)))) + +;;;; Socket support. + +;;; Looks a bit naked. + +(def-alien-routine ("socket" unix-socket) int + (domain int) + (type int) + (protocol int)) + +(def-alien-routine ("connect" unix-connect) int + (socket int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("bind" unix-bind) int + (socket int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("listen" unix-listen) int + (socket int) + (backlog int)) + +(def-alien-routine ("accept" unix-accept) int + (socket int) + (sockaddr (* t)) + (len int :in-out)) + +(def-alien-routine ("recv" unix-recv) int + (fd int) + (buffer c-string) + (length int) + (flags int)) + +(def-alien-routine ("send" unix-send) int + (fd int) + (buffer c-string) + (length int) + (flags int)) + +(def-alien-routine ("getpeername" unix-getpeername) int + (socket int) + (sockaddr (* t)) + (len (* unsigned))) + +(def-alien-routine ("getsockname" unix-getsockname) int + (socket int) + (sockaddr (* t)) + (len (* unsigned))) + +(def-alien-routine ("getsockopt" unix-getsockopt) int + (socket int) + (level int) + (optname int) + (optval (* t)) + (optlen unsigned :in-out)) + +(def-alien-routine ("setsockopt" unix-setsockopt) int + (socket int) + (level int) + (optname int) + (optval (* t)) + (optlen unsigned)) + +;; Datagram support + +(def-alien-routine ("recvfrom" unix-recvfrom) int + (fd int) + (buffer c-string) + (length int) + (flags int) + (sockaddr (* t)) + (len int :in-out)) + +(def-alien-routine ("sendto" unix-sendto) int + (fd int) + (buffer c-string) + (length int) + (flags int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("shutdown" unix-shutdown) int + (socket int) + (level int)) + +;;; sys/select.h + +;;; UNIX-FAST-SELECT -- public. +;;; +(defmacro unix-fast-select (num-descriptors + read-fds write-fds exception-fds + timeout-secs &optional (timeout-usecs 0)) + _N"Perform the UNIX select(2) system call." + (declare (type (integer 0 #.FD-SETSIZE) num-descriptors) + (type (or (alien (* (struct fd-set))) null) + read-fds write-fds exception-fds) + (type (or null (unsigned-byte 31)) timeout-secs) + (type (unsigned-byte 31) timeout-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + `(let ((timeout-secs ,timeout-secs)) + (with-alien ((tv (struct timeval))) + (when timeout-secs + (setf (slot tv 'tv-sec) timeout-secs) + (setf (slot tv 'tv-usec) ,timeout-usecs)) + (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + ,num-descriptors ,read-fds ,write-fds ,exception-fds + (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))) + + +;;; Unix-select accepts sets of file descriptors and waits for an event +;;; to happen on one of them or to time out. + +(defmacro num-to-fd-set (fdset num) + `(if (fixnump ,num) + (progn + (setf (deref (slot ,fdset 'fds-bits) 0) ,num) + ,@(loop for index upfrom 1 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0))) + (progn + ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) + (ldb (byte nfdbits ,(* index nfdbits)) ,num)))))) + +(defmacro fd-set-to-num (nfds fdset) + `(if (<= ,nfds nfdbits) + (deref (slot ,fdset 'fds-bits) 0) + (+ ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(ash (deref (slot ,fdset 'fds-bits) ,index) + ,(* index nfdbits)))))) + +(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) + _N"Unix-select examines the sets of descriptors passed as arguments + to see if they are ready for reading and writing. See the UNIX + Programmers Manual for more information." + (declare (type (integer 0 #.FD-SETSIZE) nfds) + (type unsigned-byte rdfds wrfds xpfds) + (type (or (unsigned-byte 31) null) to-secs) + (type (unsigned-byte 31) to-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (with-alien ((tv (struct timeval)) + (rdf (struct fd-set)) + (wrf (struct fd-set)) + (xpf (struct fd-set))) + (when to-secs + (setf (slot tv 'tv-sec) to-secs) + (setf (slot tv 'tv-usec) to-usecs)) + (num-to-fd-set rdf rdfds) + (num-to-fd-set wrf wrfds) + (num-to-fd-set xpf xpfds) + (macrolet ((frob (lispvar alienvar) + `(if (zerop ,lispvar) + (int-sap 0) + (alien-sap (addr ,alienvar))))) + (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + (values result + (fd-set-to-num nfds rdf) + (fd-set-to-num nfds wrf) + (fd-set-to-num nfds xpf)) + nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) + (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) + +(def-alien-routine ("gethostid" unix-gethostid) unsigned-long + _N"Unix-gethostid returns a 32-bit integer which provides unique + identification for the host machine.") + +(def-alien-routine ("getpid" unix-getpid) int + _N"Unix-getpid returns the process-id of the current process.") + +(defstruct user-info + (name "" :type string) + (password "" :type string) + (uid 0 :type unix-uid) + (gid 0 :type unix-gid) + (gecos "" :type string) + (dir "" :type string) + (shell "" :type string)) + +(defun unix-getpwuid (uid) + _N"Return a USER-INFO structure for the user identified by UID, or NIL if not found." + (declare (type unix-uid uid)) + (with-alien ((buf (array c-call:char 1024)) + (user-info (struct passwd)) + (result (* (struct passwd)))) + (let ((returned + (alien-funcall + (extern-alien "getpwuid_r" + (function c-call:int + c-call:unsigned-int + (* (struct passwd)) + (* c-call:char) + c-call:unsigned-int + (* (* (struct passwd))))) + uid + (addr user-info) + (cast buf (* c-call:char)) + 1024 + (addr result)))) + (when (zerop returned) + (make-user-info + :name (string (cast (slot result 'pw-name) c-call:c-string)) + :password (string (cast (slot result 'pw-passwd) c-call:c-string)) + :uid (slot result 'pw-uid) + :gid (slot result 'pw-gid) + :gecos (string (cast (slot result 'pw-gecos) c-call:c-string)) + :dir (string (cast (slot result 'pw-dir) c-call:c-string)) + :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))) + +(declaim (inline unix-gettimeofday)) +(defun unix-gettimeofday () + _N"If it works, unix-gettimeofday returns 5 values: T, the seconds and + microseconds of the current time of day, the timezone (in minutes west + of Greenwich), and a daylight-savings flag. If it doesn't work, it + returns NIL and the errno." + (with-alien ((tv (struct timeval)) + (tz (struct timezone))) + (syscall* ("gettimeofday" (* (struct timeval)) + (* (struct timezone))) + (values T + (slot tv 'tv-sec) + (slot tv 'tv-usec) + (slot tz 'tz-minuteswest) + (slot tz 'tz-dsttime)) + (addr tv) + (addr tz)))) + +(def-alien-routine ("ttyname" unix-ttyname) c-string + (fd int)) + +(def-alien-routine ("isatty" unix-isatty) boolean + _N"Accepts a Unix file descriptor and returns T if the device + associated with it is a terminal." + (fd int)) + +;;; pty.h + +(defun unix-openpty (name termp winp) + _N"Create pseudo tty master slave pair with NAME and set terminal + attributes according to TERMP and WINP and return handles for both + ends in AMASTER and ASLAVE." + (with-alien ((amaster int) + (aslave int)) + (values + (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios)) + (* (struct winsize))) + (addr amaster) (addr aslave) name termp winp) + amaster aslave))) + +(def-alien-type nil + (struct utsname + (sysname (array char 65)) + (nodename (array char 65)) + (release (array char 65)) + (version (array char 65)) + (machine (array char 65)) + (domainname (array char 65)))) + +(defun unix-uname () + _N"Unix-uname returns the name and information about the current kernel. The + values returned upon success are: sysname, nodename, release, version, + machine, and domainname. Upon failure, 'nil and the 'errno are returned." + (with-alien ((utsname (struct utsname))) + (syscall* ("uname" (* (struct utsname))) + (values (cast (slot utsname 'sysname) c-string) + (cast (slot utsname 'nodename) c-string) + (cast (slot utsname 'release) c-string) + (cast (slot utsname 'version) c-string) + (cast (slot utsname 'machine) c-string) + (cast (slot utsname 'domainname) c-string)) + (addr utsname)))) + +(defun unix-ioctl (fd cmd arg) + _N"Unix-ioctl performs a variety of operations on open i/o + descriptors. See the UNIX Programmer's Manual for more + information." + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd)) + (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) + + +;;; Unix-mkdir accepts a name and a mode and attempts to create the +;;; corresponding directory with mode mode. + +(defun unix-mkdir (name mode) + _N"Unix-mkdir creates a new directory with the specified name and mode. + (Same as those for unix-chmod.) It returns T upon success, otherwise + NIL and an error number." + (declare (type unix-pathname name) + (type unix-file-mode mode)) + (void-syscall ("mkdir" c-string int) (%name->file name) mode)) + +;; A time value that is accurate to the nearest +;; microsecond but also has a range of years. +(def-alien-type nil + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec time-t))) ; and microseconds + +;;; sys/time.h + +;; Structure crudely representing a timezone. +;; This is obsolete and should never be used. +(def-alien-type nil + (struct timezone + (tz-minuteswest int) ; minutes west of Greenwich + (tz-dsttime int))) ; type of dst correction + +;; Type of the second argument to `getitimer' and +;; the second and third arguments `setitimer'. +(def-alien-type nil + (struct itimerval + (it-interval (struct timeval)) ; timer interval + (it-value (struct timeval)))) ; current value + +(defconstant ITIMER-REAL 0) +(defconstant ITIMER-VIRTUAL 1) +(defconstant ITIMER-PROF 2) + +(defun unix-getitimer (which) + _N"Unix-getitimer returns the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). On success, + unix-getitimer returns 5 values, + T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." + (declare (type (member :real :virtual :profile) which) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itv (struct itimerval))) + (syscall* ("getitimer" int (* (struct itimerval))) + (values T + (slot (slot itv 'it-interval) 'tv-sec) + (slot (slot itv 'it-interval) 'tv-usec) + (slot (slot itv 'it-value) 'tv-sec) + (slot (slot itv 'it-value) 'tv-usec)) + which (alien-sap (addr itv)))))) + +(defun unix-setitimer (which int-secs int-usec val-secs val-usec) + _N" Unix-setitimer sets the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). A SIGALRM signal + will be delivered VALUE <seconds+microseconds> from now. INTERVAL, + when non-zero, is <seconds+microseconds> to be loaded each time + the timer expires. Setting INTERVAL and VALUE to zero disables + the timer. See the Unix man page for more details. On success, + unix-setitimer returns the old contents of the INTERVAL and VALUE + slots as in unix-getitimer." + (declare (type (member :real :virtual :profile) which) + (type (unsigned-byte 29) int-secs val-secs) + (type (integer 0 (1000000)) int-usec val-usec) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itvn (struct itimerval)) + (itvo (struct itimerval))) + (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs + (slot (slot itvn 'it-interval) 'tv-usec) int-usec + (slot (slot itvn 'it-value ) 'tv-sec ) val-secs + (slot (slot itvn 'it-value ) 'tv-usec) val-usec) + (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) + (values T + (slot (slot itvo 'it-interval) 'tv-sec) + (slot (slot itvo 'it-interval) 'tv-usec) + (slot (slot itvo 'it-value) 'tv-sec) + (slot (slot itvo 'it-value) 'tv-usec)) + which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + -- GitLab