[Cmucl-cvs] [git] CMU Common Lisp branch rtoy-unix-core updated. snapshot-2014-11-16-ga71198a
Raymond Toy
rtoy at common-lisp.net
Mon Nov 17 04:20:34 UTC 2014
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, rtoy-unix-core has been updated
via a71198af3e574a22d6698870bd6f5755449c39cd (commit)
via 836d21bfe205b864201cc224144dde09c8fe1b43 (commit)
via fe8f398cd5effe5a17d3e8c2a82f26491fbd2df9 (commit)
via fdc539f91d35af5fa1a92e013330a5961a02e92f (commit)
from 9245bc06d60add3a924d8086332e4d8113933b3f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a71198af3e574a22d6698870bd6f5755449c39cd
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 16 20:20:23 2014 -0800
Fix indentation.
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index b7548d6..e314960 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -946,9 +946,9 @@
(int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
(defun unix-tcgetattr (fd termios)
- _N"Get terminal attributes."
- (declare (type unix-fd fd))
- (void-syscall ("tcgetattr" int (* (struct termios))) 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."
commit 836d21bfe205b864201cc224144dde09c8fe1b43
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 16 20:20:04 2014 -0800
Add more unix functions, for motif and hemlock.
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index e5221ee..3c2e492 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -283,6 +283,13 @@
"UNIX-MUNMAP"
"UNIX-MSYNC"
+ ;; Motif
+ "UNIX-GETUIO"
+
+ ;; Hemlock
+ "TERMIOS"
+ "UNIX-TCGETATTR"
+ "UNIX-TCSETATTR"
))
(defpackage "FORMAT")
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 1d5965f..b7548d6 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -945,6 +945,20 @@
(type (unsigned-byte 32) cmd))
(int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
+(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))
+
+(def-alien-routine ("getuid" unix-getuid) int
+ _N"Unix-getuid returns the real user-id associated with the
+ current process.")
+
;;; Unix-getpagesize returns the number of bytes in the system page.
(defun unix-getpagesize ()
@@ -971,6 +985,53 @@
(declare (type (signed-byte 32) code))
(void-syscall ("exit" int) code))
+;;; From sys/termios.h
+
+;;; NOTE: There is both a termio (SYSV) and termios (POSIX)
+;;; structure with similar but incompatible definitions. It may be that
+;;; the non-BSD variant of termios below is really a termio but I (pw)
+;;; can't verify. The BSD variant uses the Posix termios def. Some systems
+;;; (Ultrix and OSF1) seem to support both if used independently.
+;;; The 17f version of this seems a bit confused wrt the conditionals.
+;;; Please check these defs for your system.
+
+;;; TSM: from what I can tell looking at the 17f definition, my guess is that it
+;;; was originally a termio for sunos (nonsolaris) (because it had the c-line
+;;; member for sunos only), and then was mutated into the termios definition for
+;;; later systems. The definition here is definitely not an IRIX termio because
+;;; it doesn't have c-line. In any case, the functions tcgetattr, etc.,
+;;; definitely take a termios, and termios seems to be the more standard
+;;; standard now, so my suggestion is to just go with termios and forget about
+;;; termio. Note the SVID says NCCS not NCC for the constant here, so I've
+;;; changed it (which means you need to bootstrap it to avoid a reader error).
+
+;;; On top of all that, SGI decided to change the termios structure on irix
+;;; 6.[34] (but NOT 6.2), left the old routines named the same in the library,
+;;; but introduced static functions in termios.h to redirect new calls to the
+;;; new library--which means it's important not to #include termios.h before
+;;; undefineds.h when building lisp.
+
+(defconstant +NCCS+
+ #+hpux 16
+ #+irix 23
+ #+(or linux solaris) 19
+ #+(or bsd osf1) 20
+ #+(and sunos (not svr4)) 17
+ _N"Size of control character vector.")
+
+(def-alien-type nil
+ (struct termios
+ (c-iflag unsigned-int)
+ (c-oflag unsigned-int)
+ (c-cflag unsigned-int)
+ (c-lflag unsigned-int)
+ #+(or linux hpux (and sunos (not svr4)))
+ (c-reserved #-(or linux (and sunos (not svr4))) unsigned-int
+ #+(or linux (and sunos (not svr4))) unsigned-char)
+ (c-cc (array unsigned-char #.+NCCS+))
+ #+(or bsd osf1) (c-ispeed unsigned-int)
+ #+(or bsd osf1) (c-ospeed unsigned-int)))
+
;;; From sys/dir.h
;;;
;;; (For Solaris, this is not struct direct, but struct dirent!)
commit fe8f398cd5effe5a17d3e8c2a82f26491fbd2df9
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 16 14:49:08 2014 -0800
Add more unix stuff.
* asdf wants unix-rmdir
* Add some missing structs.
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index 71f6389..e5221ee 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -224,6 +224,7 @@
"UNIX-GETTIMEOFDAY"
"UNIX-ISATTY"
"UNIX-MKDIR"
+ "UNIX-RMDIR"
"UNIX-UNLINK"
"UNIX-SETITIMER"
"TIMEZONE"
@@ -269,15 +270,19 @@
"SGTTYB"
"TCHARS"
"UNIX-TTYNAME"
+ "WINSIZE"
+ "LTCHARS"
+ "TIMEVAL"
+ "CLOSE-DIR"
+ "OPEN-DIR"
+ "READ-DIR"
+ "D-NAMLEN"
;; Simple streams
"PROT_READ"
"UNIX-MMAP"
"UNIX-MUNMAP"
"UNIX-MSYNC"
- "CLOSE-DIR"
- "OPEN-DIR"
- "READ-DIR"
))
(defpackage "FORMAT")
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 15f0b1e..1d5965f 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -108,6 +108,11 @@
`(multiple-value-bind (,word ,bit) (floor ,offset 32)
(logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
+(def-alien-type nlink-t
+ #-(or svr4 netbsd) unsigned-short
+ #+netbsd unsigned-long
+ #+svr4 unsigned-long)
+
(defconstant fd-setsize
#-(or hpux alpha linux FreeBSD) 256
#+hpux 2048 #+alpha 4096 #+(or linux FreeBSD) 1024)
@@ -117,6 +122,17 @@
(struct fd-set
(fds-bits (array #-alpha unsigned-long #+alpha int #.(/ fd-setsize 32)))))
+(def-alien-type nil
+ (struct timeval
+ (tv-sec #-linux time-t #+linux int) ; seconds
+ (tv-usec int))) ; and microseconds
+
+#+(or linux BSD)
+(def-alien-type nil
+ (struct timespec-t
+ (ts-sec time-t)
+ (ts-nsec long)))
+
;;; From ioctl.h
(def-alien-type nil
(struct tchars
@@ -128,6 +144,17 @@
#-linux (t-eofc char) ; end-of-file
(t-brkc char))) ; input delimiter (like nl)
+;; not found (semi) linux
+(def-alien-type nil
+ (struct ltchars
+ #+linux (t-werasc char) ; word erase
+ (t-suspc char) ; stop process signal
+ (t-dsuspc char) ; delayed stop process signal
+ (t-rprntc char) ; reprint line
+ (t-flushc char) ; flush output (toggles)
+ #-linux (t-werasc char) ; word erase
+ (t-lnextc char))) ; literal next character
+
(def-alien-type nil
(struct sgttyb
#+linux (sg-flags #+mach short #-mach int) ; mode flags
@@ -140,6 +167,13 @@
#+linux (t (struct termios))
#+linux (check int)))
+(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
+
;;;; System calls.
@@ -672,6 +706,14 @@
(void-syscall ("rename" c-string c-string)
(%name->file name1) (%name->file name2)))
+;;; 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)))
+
;;; 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 buffer starting at offset. It returns
@@ -929,6 +971,48 @@
(declare (type (signed-byte 32) code))
(void-syscall ("exit" int) code))
+;;; From sys/dir.h
+;;;
+;;; (For Solaris, this is not struct direct, but struct dirent!)
+#-bsd
+(def-alien-type nil
+ (struct direct
+ #+(and sunos (not svr4)) (d-off long) ; offset of next disk directory entry
+ (d-ino ino-t); inode number of entry
+ #+(or linux svr4) (d-off long)
+ (d-reclen unsigned-short) ; length of this record
+ #-(or linux svr4)
+ (d-namlen unsigned-short) ; length of string in d-name
+ (d-name (array char 256)))) ; name must be no longer than this
+
+#+(and bsd (not netbsd))
+(def-alien-type nil
+ (struct direct
+ (d-fileno unsigned-long)
+ (d-reclen unsigned-short)
+ (d-type unsigned-char)
+ (d-namlen unsigned-char) ; length of string in d-name
+ (d-name (array char 256)))) ; name must be no longer than this
+
+#+netbsd
+(def-alien-type nil
+ (struct direct
+ (d-fileno ino-t)
+ (d-reclen unsigned-short)
+ (d-namlen unsigned-short)
+ (d-type unsigned-char)
+ (d-name (array char 512))))
+
+;;; The 64-bit version of struct dirent.
+#+solaris
+(def-alien-type nil
+ (struct dirent64
+ (d-ino ino64-t); inode number of entry
+ (d-off off64-t) ; offset of next disk directory entry
+ (d-reclen unsigned-short) ; length of this record
+ (d-name (array char 256)))) ; name must be no longer than this
+
+
#+(and bsd (not netbsd))
(def-alien-type nil
(struct stat
@@ -950,6 +1034,29 @@
(st-lspare long)
(st-qspare (array long 4))))
+(defmacro extract-stat-results (buf)
+ `(values T
+ (slot ,buf 'st-dev)
+ (slot ,buf 'st-ino)
+ (slot ,buf 'st-mode)
+ (slot ,buf 'st-nlink)
+ (slot ,buf 'st-uid)
+ (slot ,buf 'st-gid)
+ (slot ,buf 'st-rdev)
+ (slot ,buf 'st-size)
+ #-(or svr4 BSD) (slot ,buf 'st-atime)
+ #+svr4 (slot (slot ,buf 'st-atime) 'tv-sec)
+ #+BSD (slot (slot ,buf 'st-atime) 'ts-sec)
+ #-(or svr4 BSD)(slot ,buf 'st-mtime)
+ #+svr4 (slot (slot ,buf 'st-mtime) 'tv-sec)
+ #+BSD(slot (slot ,buf 'st-mtime) 'ts-sec)
+ #-(or svr4 BSD) (slot ,buf 'st-ctime)
+ #+svr4 (slot (slot ,buf 'st-ctime) 'tv-sec)
+ #+BSD(slot (slot ,buf 'st-ctime) 'ts-sec)
+ #+netbsd (slot (slot ,buf 'st-birthtime) 'ts-sec)
+ (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.
@@ -1899,6 +2006,35 @@
(dir "" :type string)
(shell "" :type string))
+;; see <pwd.h>
+#+solaris
+(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-age (* char)) ; password age (not used)
+ (pw-comment (* char)) ; not used
+ (pw-gecos (* char)) ; typically user's full name
+ (pw-dir (* char)) ; user's home directory
+ (pw-shell (* char)))) ; user's login shell
+
+#+bsd
+(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-change int) ; password change time
+ (pw-class (* char)) ; user access class
+ (pw-gecos (* char)) ; typically user's full name
+ (pw-dir (* char)) ; user's home directory
+ (pw-shell (* char)) ; user's login shell
+ (pw-expire int) ; account expiration
+ #+(or freebsd darwin)
+ (pw-fields int))) ; internal
;;;; Other random routines.
(def-alien-routine ("isatty" unix-isatty) boolean
@@ -1921,6 +2057,10 @@
(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-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
commit fdc539f91d35af5fa1a92e013330a5961a02e92f
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sun Nov 16 09:22:39 2014 -0800
Add more stuff to unix.lisp. Not yet enough to compile cmucl.
diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index 1d85aa0..71f6389 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -212,7 +212,73 @@
"UNIX-GETHOSTNAME"
"UNIX-LSEEK"
"UNIX-EXIT"
- "UNIX-CHDIR"))
+ "UNIX-CHDIR"
+ "UNIX-ACCESS"
+ "UNIX-DUP"
+ "UNIX-CHMOD"
+ "UNIX-READLINK"
+ "UNIX-RENAME"
+ "UNIX-SELECT"
+ "UNIX-FAST-GETRUSAGE"
+ "UNIX-GETRUSAGE"
+ "UNIX-GETTIMEOFDAY"
+ "UNIX-ISATTY"
+ "UNIX-MKDIR"
+ "UNIX-UNLINK"
+ "UNIX-SETITIMER"
+ "TIMEZONE"
+ "TIMEVAL"
+ "SIZE-T"
+ "OFF-T"
+ "INO-T"
+ "DEV-T"
+ "TIME-T"
+ "FD-SETSIZE"
+ "FD-ISSET"
+ "FD-CLR"
+ "TIME-T"
+ "USER-INFO-NAME"
+ "INT64-T"
+ "MODE-T"
+ "UNIX-FAST-SELECT"
+ "UNIX-IOCTL"
+ "UNIX-OPENPTY"
+ "UNIX-PIPE"
+ "UNIX-GETPID"
+ "UNIX-SOCKET"
+ "UNIX-CONNECT"
+ "UNIX-BIND"
+ "UNIX-LISTEN"
+ "UNIX-ACCEPT"
+ "UNIX-GETSOCKOPT"
+ "UNIX-SETSOCKOPT"
+ "UNIX-GETPEERNAME"
+ "UNIX-GETSOCKNAME"
+ "UNIX_RECV"
+ "UNIX-SEND"
+ "UNIX-RECVFROM"
+ "UNIX-SENDTO"
+ "UNIX-SHUTDOWN"
+ "UNIX-GETHOSTID"
+ "UNIX-FCNTL"
+ "UNIX-UID"
+ "UNIX-GID"
+ "UNIX-GETPWUID"
+ "UNIX-MPROTECT"
+ "GET-UNIX-ERROR-MSG"
+ "SGTTYB"
+ "TCHARS"
+ "UNIX-TTYNAME"
+ ;; Simple streams
+ "PROT_READ"
+ "UNIX-MMAP"
+ "UNIX-MUNMAP"
+ "UNIX-MSYNC"
+
+ "CLOSE-DIR"
+ "OPEN-DIR"
+ "READ-DIR"
+ ))
(defpackage "FORMAT")
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 6f12a1f..15f0b1e 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -35,8 +35,111 @@
(string-decode ,string *filename-encoding*)
,string)))
+
+;;;; Common machine independent structures.
+
+(def-alien-type int64-t (signed 64))
+
+(def-alien-type ino-t
+ #+netbsd u-int64-t
+ #+alpha unsigned-int
+ #-(or alpha netbsd) unsigned-long)
+
+(def-alien-type size-t
+ #-(or linux alpha) long
+ #+linux unsigned-int
+ #+alpha unsigned-long)
+
+(def-alien-type time-t
+ #-(or bsd linux alpha) unsigned-long
+ #+linux long
+ #+(and bsd (not netbsd)) long
+ #+(and bsd netbsd) int64-t
+ #+alpha unsigned-int)
+
+(def-alien-type dev-t
+ #-(or alpha svr4 bsd linux) short
+ #+linux unsigned-short
+ #+netbsd u-int64-t
+ #+alpha int
+ #+(and (not linux) (not netbsd) (or bsd svr4)) unsigned-long)
+
+#-BSD
+(progn
+ (deftype file-offset () '(signed-byte 32))
+ (def-alien-type off-t
+ #-alpha long
+ #+alpha unsigned-long) ;??? very dubious
+ (def-alien-type uid-t
+ #-(or alpha svr4) unsigned-short
+ #+alpha unsigned-int
+ #+svr4 long)
+ (def-alien-type gid-t
+ #-(or alpha svr4) unsigned-short
+ #+alpha unsigned-int
+ #+svr4 long))
+
+#+BSD
+(progn
+ (deftype file-offset () '(signed-byte 64))
+ (def-alien-type off-t int64-t)
+ (def-alien-type uid-t unsigned-long)
+ (def-alien-type gid-t unsigned-long))
+
+(def-alien-type mode-t
+ #-(or alpha svr4) unsigned-short
+ #+alpha unsigned-int
+ #+svr4 unsigned-long)
+
+;; not checked for linux...
+(defmacro fd-clr (offset fd-set)
+ (let ((word (gensym))
+ (bit (gensym)))
+ `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ (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 32)
+ (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
+
+(defconstant fd-setsize
+ #-(or hpux alpha linux FreeBSD) 256
+ #+hpux 2048 #+alpha 4096 #+(or linux FreeBSD) 1024)
+
+;; not checked for linux...
+(def-alien-type nil
+ (struct fd-set
+ (fds-bits (array #-alpha unsigned-long #+alpha int #.(/ fd-setsize 32)))))
+
+;;; From ioctl.h
+(def-alien-type nil
+ (struct tchars
+ (t-intrc char) ; interrupt
+ (t-quitc char) ; quit
+ #+linux (t-eofc char)
+ (t-startc char) ; start output
+ (t-stopc char) ; stop output
+ #-linux (t-eofc char) ; end-of-file
+ (t-brkc char))) ; input delimiter (like nl)
+
+(def-alien-type nil
+ (struct sgttyb
+ #+linux (sg-flags #+mach short #-mach int) ; mode flags
+ (sg-ispeed char) ; input speed.
+ (sg-ospeed char) ; output speed
+ (sg-erase char) ; erase character
+ #-linux (sg-kill char) ; kill character
+ #-linux (sg-flags #+mach short #-mach int) ; mode flags
+ #+linux (sg-kill char)
+ #+linux (t (struct termios))
+ #+linux (check int)))
-(export '())
;;;; System calls.
@@ -51,9 +154,162 @@
(defmacro syscall ((name &rest arg-types) success-form &rest args)
`(%syscall (,name (, at arg-types) int) ,success-form , at args))
+;;; Like syscall, but if it fails, signal an error instead of returing 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 , at arg-types))
+ , at args)))
+ (if (eql -1 result)
+ (error _"Syscall ~A failed: ~A" ,name (get-unix-error-msg))
+ ,success-form)))
+
(defmacro void-syscall ((name &rest arg-types) &rest args)
`(syscall (,name , at arg-types) (values t 0) , at args))
+(defmacro int-syscall ((name &rest arg-types) &rest args)
+ `(syscall (,name , at arg-types) (values result 0) , at args))
+
+(defmacro off-t-syscall ((name arg-types) &rest args)
+ `(%syscall (,name ,arg-types off-t) (values result 0) , at args))
+
+
+;;; Operations on Unix Directories.
+
+(export '(open-dir read-dir close-dir))
+
+(defstruct (%directory
+ (:conc-name directory-)
+ (:constructor make-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)))))
+
+#-(and bsd (not solaris))
+(defun read-dir (dir)
+ (declare (type %directory dir))
+ (let ((daddr (alien-funcall (extern-alien "readdir"
+ (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 ((direct (* (struct direct)) daddr))
+ #-(or linux svr4)
+ (let ((nlen (slot direct 'd-namlen))
+ (ino (slot direct 'd-ino)))
+ (declare (type (unsigned-byte 16) nlen))
+ (let ((string (make-string nlen)))
+ #-unicode
+ (kernel:copy-from-system-area
+ (alien-sap (addr (slot direct 'd-name))) 0
+ string (* vm:vector-data-offset vm:word-bits)
+ (* nlen vm:byte-bits))
+ #+unicode
+ (let ((sap (alien-sap (addr (slot direct 'd-name)))))
+ (dotimes (k nlen)
+ (setf (aref string k)
+ (code-char (sap-ref-8 sap k)))))
+ (values (%file->name string) ino)))
+ #+(or linux svr4)
+ (values (%file->name (cast (slot direct 'd-name) c-string))
+ (slot direct 'd-ino))))))
+
+;;; 64-bit readdir for Solaris
+#+solaris
+(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 ((direct (* (struct dirent64)) daddr))
+ #-(or linux svr4)
+ (let ((nlen (slot direct 'd-namlen))
+ (ino (slot direct 'd-ino)))
+ (declare (type (unsigned-byte 16) nlen))
+ (let ((string (make-string nlen)))
+ #-unicode
+ (kernel:copy-from-system-area
+ (alien-sap (addr (slot direct 'd-name))) 0
+ string (* vm:vector-data-offset vm:word-bits)
+ (* nlen vm:byte-bits))
+ #+unicode
+ (let ((sap (alien-sap (addr (slot direct 'd-name)))))
+ (dotimes (k nlen)
+ (setf (aref string k)
+ (code-char (sap-ref-8 sap k)))))
+ (values (%file->name string) ino)))
+ #+(or linux svr4)
+ (values (%file->name (cast (slot direct 'd-name) c-string))
+ (slot direct 'd-ino))))))
+
+#+(and bsd (not solaris))
+(defun read-dir (dir)
+ (declare (type %directory dir))
+ (let ((daddr (alien-funcall (extern-alien "readdir"
+ (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 ((direct (* (struct direct)) daddr))
+ (let ((nlen (slot direct 'd-namlen))
+ (fino (slot direct 'd-fileno)))
+ (declare (type (unsigned-byte #+netbsd 16 #-netbsd 8) nlen)
+ (type (unsigned-byte #+netbsd 64 #-netbsd 32) fino))
+ (let ((string (make-string nlen)))
+ #-unicode
+ (kernel:copy-from-system-area
+ (alien-sap (addr (slot direct 'd-name))) 0
+ string (* vm:vector-data-offset vm:word-bits)
+ (* nlen vm:byte-bits))
+ #+unicode
+ (let ((sap (alien-sap (addr (slot direct 'd-name)))))
+ (dotimes (k nlen)
+ (setf (aref string k)
+ (code-char (sap-ref-8 sap k)))))
+ (values (%file->name string) fino)))))))
+
+
+(defun close-dir (dir)
+ (declare (type %directory dir))
+ (alien-funcall (extern-alien "closedir"
+ (function void system-area-pointer))
+ (directory-dir-struct dir))
+ nil)
+
+
;; Use getcwd instead of getwd. But what should we do if the path
;; won't fit? Try again with a larger size? We don't do that right
;; now.
@@ -72,6 +328,30 @@
(sap-int (alien-sap result))))
(%file->name (cast buf c-call:c-string))))))
+;;; 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.
+
+(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-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))
+
;;; Unix-chdir accepts a directory name and makes that the
;;; current working directory.
@@ -81,6 +361,48 @@
(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.
+
+(defconstant setuidexec #o4000 _N"Set user ID on execution")
+(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")
+(defconstant execgrp #o10 _N"Execute (search directory) by group")
+(defconstant readoth #o4 _N"Read by others")
+(defconstant writeoth #o2 _N"Write by others")
+(defconstant execoth #o1 _N"Execute (search directory) by others")
+
+(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-lseek accepts a file descriptor, an offset, and whence value.
(defconstant l_set 0 _N"set the file pointer")
@@ -100,6 +422,26 @@
(type (integer 0 2) whence))
(off-t-syscall ("lseek" (int off-t int)) fd offset whence))
+;;; 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))
+
+;;; 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-open accepts a pathname (a simple string), flags, and mode and
;;; attempts to open file with name pathname.
@@ -167,6 +509,97 @@
;;; and store them into the buffer. It returns the actual number of
;;; bytes read.
+;;; 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-fcntl takes a file descriptor, an integer command
+;;; number, and optional command arguments. It performs
+;;; operations on the associated file and/or returns inform-
+;;; ation about the file.
+
+;;; Operations performed on file descriptors:
+
+(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")
+#-(or linux svr4)
+(defconstant F-GETOWN 5 _N"Get owner")
+#+svr4
+(defconstant F-GETOWN 23 _N"Get owner")
+#+linux
+(defconstant F-GETLK 5 _N"Get lock")
+#-(or linux svr4)
+(defconstant F-SETOWN 6 _N"Set owner")
+#+svr4
+(defconstant F-SETOWN 24 _N"Set owner")
+#+linux
+(defconstant F-SETLK 6 _N"Set lock")
+#+linux
+(defconstant F-SETLKW 7 _N"Set lock, wait for release")
+#+linux
+(defconstant F-SETOWN 8 _N"Set owner")
+
+;;; File flags for F-GETFL and F-SETFL:
+
+(defconstant FNDELAY #-osf1 #o0004 #+osf1 #o100000 _N"Non-blocking reads")
+(defconstant FAPPEND #-linux #o0010 #+linux #o2000 _N"Append on each write")
+(defconstant FASYNC #-(or linux svr4) #o0100 #+svr4 #o10000 #+linux #o20000
+ _N"Signal pgrp when data ready")
+;; doesn't exist in Linux ;-(
+#-linux (defconstant FCREAT #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400
+ _N"Create if nonexistant")
+#-linux (defconstant FTRUNC #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000
+ _N"Truncate to zero length")
+#-linux (defconstant FEXCL #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000
+ _N"Error if already created")
+
+(defun unix-fcntl (fd cmd arg)
+ _N"Unix-fcntl manipulates file descriptors according 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-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-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.
@@ -208,6 +641,37 @@
(setf (sap-ref-8 sap 0) (sap-ref-8 sap 0)))))
(int-syscall ("read" int (* char) int) fd buf len))
+(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-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)))
+
;;; 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 buffer starting at offset. It returns
@@ -228,6 +692,217 @@
buf))))
(addr (deref ptr offset)))
len))
+
+;;; Unix-ioctl is used to change parameters of devices in a device
+;;; dependent way.
+
+
+(defconstant terminal-speeds
+ '#(0 50 75 110 134 150 200 300 600 #+hpux 900 1200 1800 2400 #+hpux 3600
+ 4800 #+hpux 7200 9600 19200 38400 57600 115200 230400
+ #+hpux 460800))
+
+;;; from /usr/include/bsd/sgtty.h (linux)
+
+(defconstant tty-raw #-linux #o40 #+linux 1)
+(defconstant tty-crmod #-linux #o20 #+linux 4)
+#-(or hpux svr4 bsd linux) (defconstant tty-echo #o10) ;; 8
+(defconstant tty-lcase #-linux #o4 #+linux 2)
+#-hpux
+(defconstant tty-cbreak #-linux #o2 #+linux 64)
+#-(or linux hpux)
+(defconstant tty-tandem #o1)
+
+#+(or hpux svr4 bsd linux)
+(progn
+ (defmacro def-enum (inc cur &rest names)
+ (flet ((defform (name)
+ (prog1 (when name `(defconstant ,name ,cur))
+ (setf cur (funcall inc cur 1)))))
+ `(progn ,@(mapcar #'defform names))))
+
+ ;; Input modes. Linux: /usr/include/asm/termbits.h
+ (def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck
+ tty-istrip tty-inlcr tty-igncr tty-icrnl #-bsd tty-iuclc
+ tty-ixon #-bsd tty-ixany tty-ixoff #+bsd tty-ixany
+ #+hpux tty-ienqak #+bsd nil tty-imaxbel)
+
+ ;; output modes
+ #-bsd (def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr
+ tty-onlret tty-ofill tty-ofdel)
+ #+bsd (def-enum ash 1 tty-opost tty-onlcr)
+
+ ;; local modes
+ #-bsd (def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe
+ tty-echok tty-echonl tty-noflsh #+irix tty-iexten
+ #+(or sunos linux) tty-tostop tty-echoctl tty-echoprt
+ tty-echoke #+(or sunos svr4) tty-defecho tty-flusho
+ #+linux nil tty-pendin #+irix tty-tostop
+ #+(or sunos linux) tty-iexten)
+ #+bsd (def-enum ash 1 tty-echoke tty-echoe tty-echok tty-echo tty-echonl
+ tty-echoprt tty-echoctl tty-isig tty-icanon nil
+ tty-iexten)
+ #+bsd (defconstant tty-tostop #x00400000)
+ #+bsd (defconstant tty-flusho #x00800000)
+ #+bsd (defconstant tty-pendin #x20000000)
+ #+bsd (defconstant tty-noflsh #x80000000)
+ #+hpux (defconstant tty-tostop #o10000000000)
+ #+hpux (defconstant tty-iexten #o20000000000)
+
+ ;; control modes
+ (def-enum ash #-bsd #o100 #+bsd #x400 #+hpux nil tty-cstopb
+ tty-cread tty-parenb tty-parodd tty-hupcl tty-clocal
+ #+svr4 rcv1en #+svr4 xmt1en #+(or hpux svr4) tty-loblk)
+
+ ;; special control characters
+ #+(or hpux svr4 linux) (def-enum + 0 vintr vquit verase vkill veof
+ #-linux veol #-linux veol2)
+ #+bsd (def-enum + 0 veof veol veol2 verase nil vkill nil nil vintr vquit)
+ #+linux (defconstant veol 11)
+ #+linux (defconstant veol2 16)
+
+ (defconstant tciflush 0)
+ (defconstant tcoflush 1)
+ (defconstant tcioflush 2))
+
+#+bsd
+(progn
+ (defconstant vmin 16)
+ (defconstant vtime 17)
+ (defconstant vsusp 10)
+ (defconstant vstart 12)
+ (defconstant vstop 13)
+ (defconstant vdsusp 11))
+
+#+hpux
+(progn
+ (defconstant vmin 11)
+ (defconstant vtime 12)
+ (defconstant vsusp 13)
+ (defconstant vstart 14)
+ (defconstant vstop 15)
+ (defconstant vdsusp 21))
+
+#+(or hpux bsd linux)
+(progn
+ (defconstant tcsanow 0)
+ (defconstant tcsadrain 1)
+ (defconstant tcsaflush 2))
+
+#+(or linux svr4)
+(progn
+ #-linux (defconstant vdsusp 11)
+ (defconstant vstart 8)
+ (defconstant vstop 9)
+ (defconstant vsusp 10)
+ (defconstant vmin #-linux 4 #+linux 6)
+ (defconstant vtime 5))
+
+#+(or sunos svr4)
+(progn
+ ;; control modes
+ (defconstant tty-cbaud #o17)
+ (defconstant tty-csize #o60)
+ (defconstant tty-cs5 #o0)
+ (defconstant tty-cs6 #o20)
+ (defconstant tty-cs7 #o40)
+ (defconstant tty-cs8 #o60))
+
+#+bsd
+(progn
+ ;; control modes
+ (defconstant tty-csize #x300)
+ (defconstant tty-cs5 #x000)
+ (defconstant tty-cs6 #x100)
+ (defconstant tty-cs7 #x200)
+ (defconstant tty-cs8 #x300))
+
+#+svr4
+(progn
+ (defconstant tcsanow #x540e)
+ (defconstant tcsadrain #x540f)
+ (defconstant tcsaflush #x5410))
+
+(eval-when (compile load eval)
+
+#-(or (and svr4 (not irix)) linux)
+(progn
+ (defconstant iocparm-mask #x7f) ; Freebsd: #x1fff ?
+ (defconstant ioc_void #x20000000)
+ (defconstant ioc_out #x40000000)
+ (defconstant ioc_in #x80000000)
+ (defconstant ioc_inout (logior ioc_in ioc_out)))
+
+#-(or linux (and svr4 (not irix)))
+(defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
+ (let* ((ptype (ecase parm-type
+ (:void ioc_void)
+ (:in ioc_in)
+ (:out ioc_out)
+ (:inout ioc_inout)))
+ (code (logior (ash (char-code dev) 8) cmd ptype)))
+ (when arg
+ (setf code
+ `(logior (ash (logand (alien-size ,arg :bytes)
+ ,iocparm-mask)
+ 16)
+ ,code)))
+ `(eval-when (eval load compile)
+ (defconstant ,name ,code))))
+
+#+(and svr4 (not irix))
+(defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
+ (declare (ignore dev arg parm-type))
+ `(eval-when (eval load compile)
+ (defconstant ,name ,(logior (ash (char-code #\t) 8) cmd))))
+
+#+linux
+(defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
+ (declare (ignore arg parm-type))
+ `(eval-when (eval load compile)
+ (defconstant ,name ,(logior (ash (- (char-code dev) #x20) 8) cmd))))
+
+)
+
+;;; TTY ioctl commands.
+
+(define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x81 (struct sgttyb) :out)
+(define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x82 (struct sgttyb) :in)
+(define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x89 int :in)
+(define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x84 (struct tchars) :in)
+(define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x83 (struct tchars) :out)
+(define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize)
+ :out)
+(define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize)
+ :in)
+
+(define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x22 nil :void)
+#-hpux
+(progn
+ (define-ioctl-command TIOCSLTC #\t #-linux 117 #+linux #x84 (struct ltchars) :in)
+ (define-ioctl-command TIOCGLTC #\t #-linux 116 #+linux #x85 (struct ltchars) :out)
+ (define-ioctl-command TIOCSPGRP #\t #-svr4 118 #+svr4 21 int :in)
+ (define-ioctl-command TIOCGPGRP #\t #-svr4 119 #+svr4 20 int :out))
+#+hpux
+(progn
+ (define-ioctl-command TIOCSLTC #\T 23 (struct ltchars) :in)
+ (define-ioctl-command TIOCGLTC #\T 24 (struct ltchars) :out)
+ (define-ioctl-command TIOCSPGRP #\T 29 int :in)
+ (define-ioctl-command TIOCGPGRP #\T 30 int :out)
+ (define-ioctl-command TIOCSIGSEND #\t 93 nil))
+
+;;; File ioctl commands.
+(define-ioctl-command FIONREAD #\f #-linux 127 #+linux #x1B int :out)
+
+
+(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-getpagesize returns the number of bytes in the system page.
(defun unix-getpagesize ()
@@ -241,6 +916,10 @@
(cast buf c-string)
(cast buf (* char)) 256)))
+(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-exit terminates a program.
(defun unix-exit (&optional (code 0))
@@ -303,6 +982,73 @@
(extract-stat-results buf)
fd (addr buf))))
+(def-alien-type nil
+ (struct rusage
+ (ru-utime (struct timeval)) ; user time used
+ (ru-stime (struct timeval)) ; system time used.
+ (ru-maxrss long)
+ (ru-ixrss long) ; integral sharded memory size
+ (ru-idrss long) ; integral unsharded data "
+ (ru-isrss long) ; integral unsharded 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 "
+
+(defconstant rusage_self 0 _N"The calling process.")
+(defconstant rusage_children -1 _N"Terminated child processes.")
+
+(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* (#-netbsd "getrusage" #+netbsd "__getrusage50" 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 (#-netbsd "getrusage" #+netbsd "__getrusage50" 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))))
+
;;;; Support routines for dealing with unix pathnames.
(defconstant s-ifmt #o0170000)
@@ -814,3 +1560,452 @@
(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int))
(defun unix-errno () (unix-get-errno))
+;;; 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 _"Unknown error [~d]" error-number)))
+
+
+;;;; 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-uid () '(unsigned-byte 32))
+(deftype unix-gid () '(unsigned-byte 32))
+
+
+;;; 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 (#-netbsd "select" #+netbsd "__select50" 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 32)
+ collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
+ (progn
+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
+ (ldb (byte 32 ,(* index 32)) ,num))))))
+
+(defmacro fd-set-to-num (nfds fdset)
+ `(if (<= ,nfds 32)
+ (deref (slot ,fdset 'fds-bits) 0)
+ (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
+ ,(* index 32))))))
+
+;; not checked for linux...
+(defmacro fd-set (offset fd-set)
+ (let ((word (gensym))
+ (bit (gensym)))
+ `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ (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 32)
+ collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
+
+(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 (#-netbsd "select" #+netbsd "__select50" 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-type nil
+ (struct timeval
+ (tv-sec #-linux time-t #+linux int) ; seconds
+ (tv-usec int))) ; and microseconds
+
+(def-alien-type nil
+ (struct timezone
+ (tz-minuteswest int) ; minutes west of Greenwich
+ (tz-dsttime ; type of dst correction
+ #-linux (enum nil :none :usa :aust :wet :met :eet :can)
+ #+linux int)))
+
+(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))
+ #-(or svr4 netbsd) (tz (struct timezone)))
+ (syscall* (#-netbsd "gettimeofday"
+ #+netbsd "__gettimeofday50"
+ (* (struct timeval)) #-svr4 (* (struct timezone)))
+ (values T
+ (slot tv 'tv-sec)
+ (slot tv 'tv-usec)
+ #-(or svr4 netbsd) (slot tz 'tz-minuteswest)
+ #+svr4 (unix-get-minutes-west (slot tv 'tv-sec))
+ #-(or svr4 netbsd) (slot tz 'tz-dsttime)
+ #+svr4 (unix-get-timezone (slot tv 'tv-sec))
+ )
+ (addr tv)
+ #-(or svr4 netbsd) (addr tz) #+netbsd nil)))
+
+(def-alien-routine ("getpid" unix-getpid) int
+ _N"Unix-getpid returns the process-id of the current process.")
+
+
+;;;; Socket support.
+
+(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
+
+(defun unix-recvfrom (fd buffer length flags sockaddr len)
+ (with-alien ((l c-call:int len))
+ (values
+ (alien-funcall (extern-alien "recvfrom"
+ (function c-call:int
+ c-call:int
+ system-area-pointer
+ c-call:int
+ c-call:int
+ (* t)
+ (* c-call:int)))
+ fd
+ (system:vector-sap buffer)
+ length
+ flags
+ sockaddr
+ (addr l))
+ l)))
+
+#-unicode
+(def-alien-routine ("sendto" unix-sendto) int
+ (fd int)
+ (buffer c-string)
+ (length int)
+ (flags int)
+ (sockaddr (* t))
+ (len int))
+
+(defun unix-sendto (fd buffer length flags sockaddr len)
+ (alien-funcall (extern-alien "sendto"
+ (function c-call:int
+ c-call:int
+ system-area-pointer
+ c-call:int
+ c-call:int
+ (* t)
+ c-call:int))
+ fd
+ (system:vector-sap buffer)
+ length
+ flags
+ sockaddr
+ len))
+
+(def-alien-routine ("shutdown" unix-shutdown) int
+ (socket int)
+ (level int))
+
+
+;;;; Memory-mapped files
+
+(defconstant +null+ (sys:int-sap 0))
+
+(defconstant prot_read 1) ; Readable
+(defconstant prot_write 2) ; Writable
+(defconstant prot_exec 4) ; Executable
+(defconstant prot_none 0) ; No access
+
+(defconstant map_shared 1) ; Changes are shared
+(defconstant map_private 2) ; Changes are private
+(defconstant map_fixed 16) ; Fixed, user-defined address
+(defconstant map_noreserve #x40) ; Don't reserve swap space
+(defconstant map_anonymous
+ #+solaris #x100 ; Solaris
+ #+linux 32 ; Linux
+ #+bsd #x1000)
+
+(defconstant ms_async 1)
+(defconstant ms_sync 4)
+(defconstant ms_invalidate 2)
+
+;; The return value from mmap that means mmap failed.
+(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
+
+(defun unix-mmap (addr length prot flags fd offset)
+ (declare (type (or null system-area-pointer) addr)
+ (type (unsigned-byte 32) length)
+ (type (integer 1 7) prot)
+ (type (unsigned-byte 32) flags)
+ (type (or null unix-fd) fd)
+ (type file-offset offset))
+ ;; Can't use syscall, because the address that is returned could be
+ ;; "negative". Hence we explicitly check for mmap returning
+ ;; MAP_FAILED.
+ (let ((result
+ (alien-funcall (extern-alien "mmap" (function system-area-pointer
+ system-area-pointer
+ size-t int int int off-t))
+ (or addr +null+) length prot flags (or fd -1) offset)))
+ (if (sap= result map_failed)
+ (values nil (unix-errno))
+ (values result 0))))
+
+(defun unix-munmap (addr length)
+ (declare (type system-area-pointer addr)
+ (type (unsigned-byte 32) length))
+ (syscall ("munmap" system-area-pointer size-t) t addr length))
+
+(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))
+
+(defun unix-msync (addr length flags)
+ (declare (type system-area-pointer addr)
+ (type (unsigned-byte 32) length)
+ (type (signed-byte 32) flags))
+ (syscall ("msync" system-area-pointer size-t int) t addr length flags))
+
+
+;;;; User and group database structures
+
+(defstruct user-info
+ (name "" :type string)
+ (password "" :type string)
+ (uid 0 :type unix-uid)
+ (gid 0 :type unix-gid)
+ #+solaris (age "" :type string)
+ #+solaris (comment "" :type string)
+ #+freebsd (change -1 :type fixnum)
+ (gecos "" :type string)
+ (dir "" :type string)
+ (shell "" :type string))
+
+
+;;;; Other random routines.
+(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))
+
+(def-alien-routine ("ttyname" unix-ttyname) c-string
+ (fd int))
+
+(def-alien-routine ("openpty" unix-openpty) int
+ (amaster int :out)
+ (aslave int :out)
+ (name c-string)
+ (termp (* (struct termios)))
+ (winp (* (struct winsize))))
+
+(def-alien-type nil
+ (struct itimerval
+ (it-interval (struct timeval)) ; timer interval
+ (it-value (struct timeval)))) ; current value
+
+(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* (#-netbsd "setitimer" #+netbsd "__setitimer50" 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))))))
+
+
+;;;; User and group database access, POSIX Standard 9.2.2
+
+#+solaris
+(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)))
+ (let ((result
+ (alien-funcall
+ (extern-alien "getpwuid_r"
+ (function (* (struct passwd))
+ c-call:unsigned-int
+ (* (struct passwd))
+ (* c-call:char)
+ c-call:unsigned-int))
+ uid
+ (addr user-info)
+ (cast buf (* c-call:char))
+ 1024)))
+ (when (not (zerop (sap-int (alien-sap result))))
+ (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)
+ :age (string (cast (slot result 'pw-age) c-call:c-string))
+ :comment (string (cast (slot result 'pw-comment) c-call:c-string))
+ :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)))))))
+
+#+bsd
+(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))
+ (let ((result
+ (alien-funcall
+ (extern-alien "getpwuid"
+ (function (* (struct passwd))
+ c-call:unsigned-int))
+ uid)))
+ (when (not (zerop (sap-int (alien-sap result))))
+ (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))))))
+
-----------------------------------------------------------------------
Summary of changes:
src/code/exports.lisp | 80 ++-
src/code/unix.lisp | 1398 ++++++++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 1476 insertions(+), 2 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list