Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: f957ba84 by Raymond Toy at 2015-05-10T09:58:38Z Both unix.lisp and unix-glibc2.lisp have unix-rmdir. - - - - - 9a9c5377 by Raymond Toy at 2015-05-10T10:29:34Z Add a few comments. - - - - - b7436b55 by Raymond Toy at 2015-05-10T10:29:50Z Remove the things that are already in code/unix-glibc2. - - - - - 3 changed files: - src/code/exports.lisp - src/code/unix-glibc2.lisp - src/contrib/unix/unix-glibc2.lisp Changes: ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -224,6 +224,7 @@ "UNIX-GETTIMEOFDAY" "UNIX-ISATTY" "UNIX-MKDIR" + "UNIX-RMDIR" "UNIX-UNLINK" "TIMEZONE" "TIMEVAL" @@ -303,11 +304,9 @@ ;; Tests "UNIX-SYMLINK" - ) #-linux - (:export "UNIX-RMDIR" - "TCHARS" + (:export "TCHARS" "LTCHARS" "D-NAMLEN" @@ -662,8 +661,7 @@ "X_OK" ) #+linux - (:export "UNIX-RMDIR" - "TCHARS" + (:export "TCHARS" "LTCHARS" "D-NAMLEN" ===================================== src/code/unix-glibc2.lisp ===================================== --- a/src/code/unix-glibc2.lisp +++ b/src/code/unix-glibc2.lisp @@ -122,6 +122,7 @@ (values (not (zerop (sap-int (alien-sap result)))) (%file->name (cast buf c-call:c-string)))))) +;;; fcntlbits.h (defconstant o_read o_rdonly _N"Open for reading") (defconstant o_write o_wronly _N"Open for writing") @@ -873,6 +874,8 @@ (declare (type unix-fd fd1 fd2)) (void-syscall ("dup2" int int) fd1 fd2)) +;;; Unix-exit terminates a program. + (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 @@ -965,6 +968,10 @@ (declare (type unix-pathname name)) (void-syscall ("unlink" c-string) (%name->file name))) +;;; fcntl.h +;;; +;;; POSIX Standard: 6.5 File Control Operations <fcntl.h> + (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") @@ -1107,6 +1114,8 @@ ;;; TTY ioctl commands. +(eval-when (compile load eval) + (defconstant iocparm-mask #x3fff) (defconstant ioc_void #x00000000) (defconstant ioc_out #x40000000) @@ -1135,6 +1144,9 @@ (setf code `(logior ,dir ,code)))) `(eval-when (eval load compile) (defconstant ,name ,code)))) +) + +;;; TTY ioctl commands. (define-ioctl-command TIOCGWINSZ #\T #x13) (define-ioctl-command TIOCSWINSZ #\T #x14) @@ -1498,6 +1510,7 @@ (def-alien-routine ("getpid" unix-getpid) int _N"Unix-getpid returns the process-id of the current process.") +;;;; User and group database structures: <pwd.h> and <grp.h> (defstruct user-info (name "" :type string) (password "" :type string) @@ -1622,6 +1635,8 @@ (cast (slot utsname 'domainname) c-string)) (addr utsname)))) +;;; sys/ioctl.h + (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 @@ -1642,6 +1657,8 @@ (type unix-file-mode mode)) (void-syscall ("mkdir" c-string int) (%name->file name) mode)) +;;; timebits.h + ;; A time value that is accurate to the nearest ;; microsecond but also has a range of years. (def-alien-type nil @@ -1725,6 +1742,8 @@ which (alien-sap (addr itvn))(alien-sap (addr itvo))))))  +;;; termbits.h + (def-alien-type cc-t unsigned-char) (def-alien-type speed-t unsigned-int) (def-alien-type tcflag-t unsigned-int) ===================================== src/contrib/unix/unix-glibc2.lisp ===================================== --- a/src/contrib/unix/unix-glibc2.lisp +++ b/src/contrib/unix/unix-glibc2.lisp @@ -60,13 +60,6 @@ (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 @@ -203,44 +196,8 @@ 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) - (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))) - ;;;; Common machine independent structures. -(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*))))) - -) - (defmacro def-enum (inc cur &rest names) (flet ((defform (name) (prog1 (when name `(defconstant ,name ,cur)) @@ -298,35 +255,8 @@ (type (signed-byte 32) flags)) (syscall ("msync" system-area-pointer size-t int) t addr length flags)) -(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)) - - ;;;; User and group database structures: <pwd.h> and <grp.h> -(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)) - (defstruct group-info (name "" :type string) (password "" :type string) @@ -334,92 +264,25 @@ (members nil :type list)) ; list of logins as strings (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 - -(def-alien-type nil (struct group (gr-name (* char)) ; name of the group (gr-passwd (* char)) ; encrypted group password (gr-gid gid-t) ; numerical group ID (gr-mem (* (* char))))) ; vector of pointers to member names - -;;;; 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)) - ;;; From stdio.h -;;; 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))) - ;;; From sys/types.h ;;; and ;;; gnu/types.h (defconstant +max-s-long+ 2147483647) -(defconstant +max-u-long+ 4294967295) (def-alien-type quad-t #+alpha long #-alpha (array long 2)) -(def-alien-type uquad-t #+alpha unsigned-long - #-alpha (array unsigned-long 2)) (def-alien-type qaddr-t (* quad-t)) (def-alien-type daddr-t int) (def-alien-type caddr-t (* char)) (def-alien-type swblk-t long) -(def-alien-type size-t #-alpha unsigned-int #+alpha long) -(def-alien-type time-t long) (def-alien-type clock-t long) (def-alien-type uid-t unsigned-int) (def-alien-type ssize-t #-alpha int #+alpha long) @@ -429,20 +292,8 @@ (def-alien-type int16-t short) (def-alien-type u-int16-t unsigned-short) (def-alien-type int32-t int) -(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 register-t #-alpha int #+alpha long) -(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) (def-alien-type fsblkcnt-t u-int64-t) (def-alien-type fsfilcnt-t u-int64-t) (def-alien-type pid-t int) @@ -450,239 +301,26 @@ (def-alien-type fsid-t (array int 2)) -(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))))) - (def-alien-type key-t int) (def-alien-type ipc-pid-t unsigned-short) -;;; 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 -;;; dirent.h - -;;; Operations on Unix Directories. - -(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) ;;; dlfcn.h -> in foreign.lisp -;;; fcntl.h -;;; -;;; POSIX Standard: 6.5 File Control Operations <fcntl.h> - -(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)) - -(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)) - (defun unix-getdtablesize () _N"Unix-getdtablesize returns the maximum size of the file descriptor table. (i.e. the maximum number of descriptors that can exist at one time.)" (int-syscall ("getdtablesize"))) -;;; 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)) - -;;; Unix-creat accepts a file name and a mode. It creates a new file -;;; with name and sets it mode to mode (as for chmod). - -(defun unix-creat (name mode) - _N"Unix-creat accepts a file name and a mode (same as those for - unix-chmod) and creates a file by that name with the specified - permission mode. It returns a file descriptor on success, - or NIL and an error number otherwise. - - This interface is made obsolete by UNIX-OPEN." - - (declare (type unix-pathname name) - (type unix-file-mode mode)) - (int-syscall ("creat64" c-string int) (%name->file name) mode)) - ;;; fcntlbits.h -(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")) (defconstant f-dupfd 0 _N"Duplicate a file descriptor") (defconstant f-getfd 1 _N"Get file desc. flags") (defconstant f-setfd 2 _N"Set file desc. flags") -(defconstant f-getfl 3 _N"Get file flags") -(defconstant f-setfl 4 _N"Set file flags") - -#-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") @@ -714,16 +352,6 @@ (l-len off-t) (l-pid pid-t))) -;;; 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") - - ;;; grp.h ;;; POSIX Standard: 9.2.1 Group Database Access <grp.h> @@ -751,13 +379,6 @@ ;;; ioctl-types.h -(def-alien-type nil - (struct winsize - (ws-row unsigned-short) ; rows, in characters - (ws-col unsigned-short) ; columns, in characters - (ws-xpixel unsigned-short) ; horizontal size, pixels - (ws-ypixel unsigned-short))) ; veritical size, pixels - (defconstant +NCC+ 8 _N"Size of control character vector.") @@ -1213,20 +834,6 @@ length LEN and type TYPE." ai)) -;;; 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))) - #+(or) (defun unix-forkpty (amaster name termp winp) _N"Create child process and establish the slave pseudo terminal as the @@ -1265,29 +872,6 @@ length LEN and type TYPE." (rlim-cur long) ; current (soft) limit (rlim-max long))); maximum value for rlim-cur -(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))) ; involuntary " - ;; Priority limits. (defconstant prio-min -20 _N"Minimum priority a process can have") @@ -1447,58 +1031,6 @@ length LEN and type TYPE." _N"Unlock password file." (void-syscall ("ulckpwdf"))) -;;; 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))) - -;; 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.") - ;; Protection bits. (defconstant s-isuid #o0004000 _N"Set user ID on execution.") @@ -1526,48 +1058,10 @@ length LEN and type TYPE." ;;; termbits.h -(def-alien-type cc-t unsigned-char) -(def-alien-type speed-t unsigned-int) -(def-alien-type tcflag-t unsigned-int) -(defconstant +NCCS+ 32 - _N"Size of control character vector.") - -(def-alien-type nil - (struct termios - (c-iflag tcflag-t) - (c-oflag tcflag-t) - (c-cflag tcflag-t) - (c-lflag tcflag-t) - (c-line cc-t) - (c-cc (array cc-t #.+NCCS+)) - (c-ispeed speed-t) - (c-ospeed speed-t))) - -;; c_cc characters - -(def-enum + 0 vintr vquit verase - vkill veof vtime - vmin vswtc vstart - vstop vsusp veol - vreprint vdiscard vwerase - vlnext veol2) -(defvar vdsusp vsusp) (def-enum + 0 tciflush tcoflush tcioflush) -(def-enum + 0 tcsanow tcsadrain tcsaflush) - -;; c_iflag bits -(def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck - tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc - tty-ixon tty-ixany tty-ixoff - tty-imaxbel) - -;; c_oflag bits -(def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr - tty-onlret tty-ofill tty-ofdel tty-nldly) - (defconstant tty-nl0 0) (defconstant tty-nl1 #o400) @@ -1631,13 +1125,6 @@ length LEN and type TYPE." (defconstant tty-cibaud #o002003600000) ; input baud rate (not used) (defconstant tty-crtscts #o020000000000) ;flow control -;; c_lflag bits -(def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe - tty-echok tty-echonl tty-noflsh - tty-tostop tty-echoctl tty-echoprt - tty-echoke tty-flusho - tty-pendin tty-iexten) - ;;; tcflow() and TCXONC use these (def-enum + 0 tty-tcooff tty-tcoon tty-tcioff tty-tcion) @@ -1649,14 +1136,6 @@ length LEN and type TYPE." ;;; termios.h -(defun unix-cfgetospeed (termios) - _N"Get terminal output speed." - (multiple-value-bind (speed errno) - (int-syscall ("cfgetospeed" (* (struct termios))) termios) - (if speed - (values (svref terminal-speeds speed) 0) - (values speed errno)))) - (defun unix-cfsetospeed (termios speed) _N"Set terminal output speed." (let ((baud (or (position speed terminal-speeds) @@ -1677,16 +1156,6 @@ length LEN and type TYPE." (error _"Bogus baud rate ~S" speed)))) (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud))) -(defun unix-tcgetattr (fd termios) - _N"Get terminal attributes." - (declare (type unix-fd fd)) - (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) - -(defun unix-tcsetattr (fd opt termios) - _N"Set terminal attributes." - (declare (type unix-fd fd)) - (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios)) - (defun unix-tcsendbreak (fd duration) _N"Send break" (declare (type unix-fd fd)) @@ -1709,13 +1178,6 @@ length LEN and type TYPE." ;;; timebits.h -;; 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 - ;;; unistd.h (defun sub-unix-execve (program arg-list env-list) @@ -1774,123 +1236,6 @@ length LEN and type TYPE." (defmacro round-bytes-to-words (n) `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) -;; 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-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-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))))) - - (defun unix-chown (path uid gid) _N"Given a file path, an integer user-id, and an integer group-id, unix-chown changes the owner of the file and the group of the @@ -1913,65 +1258,6 @@ length LEN and type TYPE." (type (or unix-gid (integer -1 -1)) gid)) (void-syscall ("fchown" int int int) fd uid gid)) -;;; 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))) - -(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)))))) - - -;;; 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)) - -;;; Unix-exit terminates a program. - -(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)) - #+(or) (defun unix-pathconf (path name) _N"Get file-specific configuration information about PATH." @@ -1994,9 +1280,6 @@ length LEN and type TYPE." (cast buf c-string)))) -(def-alien-routine ("getpid" unix-getpid) int - _N"Unix-getpid returns the process-id of the current process.") - (def-alien-routine ("getppid" unix-getppid) int _N"Unix-getppid returns the process-id of the parent of the current process.") @@ -2038,10 +1321,6 @@ length LEN and type TYPE." _N"Return the session ID of the given process." (int-syscall ( "getsid"))) -(def-alien-routine ("getuid" unix-getuid) int - _N"Unix-getuid returns the real user-id associated with the - current process.") - #+(or) (def-alien-routine ("geteuid" unix-getuid) int _N"Get the effective user ID of the calling process.") @@ -2131,14 +1410,6 @@ length LEN and type TYPE." (name c-call:c-string) _N"Removes the variable Name from the environment") -(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)) - ;;; Unix-link creates a hard link from name2 to name1. (defun unix-link (name1 name2) @@ -2148,52 +1419,6 @@ length LEN and type TYPE." (void-syscall ("link" c-string c-string) (%name->file name1) (%name->file name2))) -(defun unix-symlink (name1 name2) - _N"Unix-symlink creates a symbolic link named name2 to the file - named name1. NIL and an error number is returned if the call - is unsuccessful." - (declare (type unix-pathname name1 name2)) - (void-syscall ("symlink" c-string c-string) - (%name->file name1) (%name->file name2))) - -(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))) - -;;; Unix-rmdir accepts a name and removes the associated directory. - -(defun unix-rmdir (name) - _N"Unix-rmdir attempts to remove the directory name. NIL and - an error number is returned if an error occured." - (declare (type unix-pathname name)) - (void-syscall ("rmdir" c-string) (%name->file name))) - (defun tcgetpgrp (fd) _N"Get the tty-process-group for the unix file-descriptor FD." (alien:with-alien ((alien-pgrp c-call:int)) @@ -2261,35 +1486,6 @@ length LEN and type TYPE." nil result))) -(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-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))) #+(or) (defun unix-sethostname (name len) @@ -2336,10 +1532,6 @@ length LEN and type TYPE." This call is restricted to the super-user." (int-syscall ("chroot" c-string) (%name->file path))) -(def-alien-routine ("gethostid" unix-gethostid) unsigned-long - _N"Unix-gethostid returns a 32-bit integer which provides unique - identification for the host machine.") - ;;; Unix-sync writes all information in core memory which has been modified ;;; to permanent storage (i.e. disk). @@ -2349,12 +1541,6 @@ length LEN and type TYPE." occured." (void-syscall ("sync"))) -;;; 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"))) - ;;; Unix-truncate accepts a file name and a new length. The file is ;;; truncated to the new length. @@ -2412,27 +1598,6 @@ length LEN and type TYPE." (actime time-t) ; Access time. (modtime time-t))) ; Modification time. -;;; Unix-utimes changes the accessed and updated times on UNIX -;;; files. The first argument is the filename (a string) and -;;; the second argument is a list of the 4 times- accessed and -;;; updated seconds and microseconds. - -(defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec) - _N"Unix-utimes sets the 'last-accessed' and 'last-updated' - times on a specified file. NIL and an error number is - returned if the call is unsuccessful." - (declare (type unix-pathname file) - (type (alien unsigned-long) - atime-sec atime-usec - mtime-sec mtime-usec)) - (with-alien ((tvp (array (struct timeval) 2))) - (setf (slot (deref tvp 0) 'tv-sec) atime-sec) - (setf (slot (deref tvp 0) 'tv-usec) atime-usec) - (setf (slot (deref tvp 1) 'tv-sec) mtime-sec) - (setf (slot (deref tvp 1) 'tv-usec) mtime-usec) - (void-syscall ("utimes" c-string (* (struct timeval))) - file - (cast tvp (* (struct timeval)))))) ;;; waitflags.h ;; Bits in the third argument to `waitpid'. @@ -2442,16 +1607,6 @@ length LEN and type TYPE." (defconstant waitpid-wclone #x80000000 _N"Wait for cloned process.") -;;; sys/ioctl.h - -(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)) - ;;; sys/fsuid.h @@ -2528,50 +1683,6 @@ in at a time in poll.") (void-syscall ("setrlimit" int (* (struct rlimit))) resource (addr rlimits)))) -(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)))) #+(or) (defun unix-ulimit (cmd newlimit) @@ -2600,291 +1711,12 @@ in at a time in poll.") (int-syscall ("setpriority" int int) which who)) -;;; sys/socket.h - -;;;; 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)))))) - -;;; 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))) - -(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)))) - -;;; 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)) - -;;; Unix-fchmod accepts a file descriptor ("fd") and a file protection mode -;;; ("mode") and changes the protection of the file described by "fd" to -;;; "mode". - -(defun unix-fchmod (fd mode) - _N"Given an integer file descriptor and a mode (the same as those - used for unix-chmod), unix-fchmod changes the permission mode - for that file to the one specified. T is returned if the call - was successful." - (declare (type unix-fd fd) - (type unix-file-mode mode)) - (void-syscall ("fchmod" int int) fd mode)) - (defun unix-umask (mask) _N"Set the file creation mask of the current process to MASK, and return the old creation mask." (int-syscall ("umask" mode-t) mask)) -;;; 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)) - #+(or) (defun unix-makedev (path mode dev) _N"Create a device file named PATH, with permission and special bits MODE @@ -2991,35 +1823,6 @@ in at a time in poll.") (declare (ignore ignore) (ignore minutes)) (values (deref unix-tzname (if dst 1 0))))) -;;; 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 - - -(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)))) - - ;/* Set the current time of day and timezone information. ; This call is restricted to the super-user. */ ;extern int __settimeofday __P ((__const struct timeval *__tv, @@ -3037,72 +1840,6 @@ in at a time in poll.") ; struct timeval *__olddelta)); -;; 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)))))) - ;;; sys/timeb.h ;; Structure returned by the `ftime' function. @@ -3164,188 +1901,11 @@ in at a time in poll.") (int-syscall ("waitpit" pid-t (* int) int) pid status options)) -;;; asm/errno.h - -(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) - ;;; the ioctl's. ;;; ;;; I've deleted all the stuff that wasn't in the header files. ;;; This is what survived. -;; 0x54 is just a magic number to make these relatively unique ('T') - -(eval-when (compile load eval) - -(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)))) - -) - -;;; TTY ioctl commands. - -(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) - -;;; File ioctl commands. -(define-ioctl-command FIONREAD #\T #x1B) ;;; asm/sockios.h @@ -3366,7 +1926,6 @@ in at a time in poll.") (defconstant setgidexec #o2000 _N"Set group ID on execution") (defconstant savetext #o1000 _N"Save text image after execution") (defconstant readown #o400 _N"Read by owner") -(defconstant writeown #o200 _N"Write by owner") (defconstant execown #o100 _N"Execute (search directory) by owner") (defconstant readgrp #o40 _N"Read by group") (defconstant writegrp #o20 _N"Write by group") @@ -3384,191 +1943,6 @@ in at a time in poll.") (export '(unix-file-kind unix-maybe-prepend-current-directory unix-resolve-links unix-simplify-pathname)) -(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)))) - -(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))))) - ;;; ;;; STRING-LIST-TO-C-STRVEC -- Internal ;;; @@ -3635,41 +2009,6 @@ in at a time in poll.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Abandon all hope who enters here... - -;; 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-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-zero (fd-set) - `(progn - ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) - collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) - - -  ;;;; User and group database access, POSIX Standard 9.2.2 @@ -3703,36 +2042,6 @@ in at a time in poll.") :dir (string (cast (slot result 'pw-dir) c-call:c-string)) :shell (string (cast (slot result 'pw-shell) c-call:c-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))))))) - (defun unix-getgrnam (name) _N"Return a GROUP-INFO structure for the group identified by NAME, or NIL if not found." (declare (type simple-string name)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/8a9a7ae2a692430b069b307a0...