From 84500b84beb8a03298beaf731d36faee5323b4d5 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Sun, 13 Apr 2003 21:03:02 +0000 Subject: [PATCH] 0.pre8.57 Experimental first cut of SB-POSIX interface added. See contrib/sb-posix/README --- contrib/sb-grovel/def-to-lisp.lisp | 19 ++-- contrib/sb-posix/Makefile | 2 + contrib/sb-posix/README | 118 ++++++++++++++++++++++ contrib/sb-posix/TODO | 198 +++++++++++++++++++++++++++++++++++++ contrib/sb-posix/constants.lisp | 46 +++++++++ contrib/sb-posix/defpackage.lisp | 2 + contrib/sb-posix/designator.lisp | 24 +++++ contrib/sb-posix/interface.lisp | 75 ++++++++++++++ contrib/sb-posix/macros.lisp | 26 +++++ contrib/sb-posix/sb-posix.asd | 20 ++++ version.lisp-expr | 2 +- 11 files changed, 525 insertions(+), 7 deletions(-) create mode 100644 contrib/sb-posix/Makefile create mode 100644 contrib/sb-posix/README create mode 100644 contrib/sb-posix/TODO create mode 100644 contrib/sb-posix/constants.lisp create mode 100644 contrib/sb-posix/defpackage.lisp create mode 100644 contrib/sb-posix/designator.lisp create mode 100644 contrib/sb-posix/interface.lisp create mode 100644 contrib/sb-posix/macros.lisp create mode 100644 contrib/sb-posix/sb-posix.asd diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 3f82a5dd9..337d5c7c3 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -19,12 +19,13 @@ (defun c-for-function (stream lisp-name alien-defn) (destructuring-bind (c-name &rest definition) alien-defn (let ((*print-right-margin* nil)) - (format stream "printf(\"(declaim (inline ~A))\\n\");~%" + (format stream "printf(\"(cl:declaim (cl:inline ~A))\\n\");~%" lisp-name) (princ "printf(\"(sb-grovel::define-foreign-routine (" stream) (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream) (princ lisp-name stream) (princ " ) " stream) + (terpri stream) (dolist (d definition) (write d :length nil :right-margin nil :stream stream) @@ -35,22 +36,28 @@ (defun print-c-source (stream headers definitions package-name) (let ((*print-right-margin* nil)) + (format stream "#define SIGNEDP(x) (((x)-1)<0)~%") + (format stream "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")~%") (loop for i in headers do (format stream "#include <~A>~%" i)) (format stream "main() { ~% printf(\"(in-package ~S)\\\n\");~%" package-name) - (format stream "printf(\"(deftype int () '(signed-byte %d))\\\n\",8*sizeof (int));~%") - (format stream "printf(\"(deftype char () '(unsigned-byte %d))\\\n\",8*sizeof (char));~%") - (format stream "printf(\"(deftype long () '(unsigned-byte %d))\\\n\",8*sizeof (long));~%") + (format stream "printf(\"(cl:deftype int () '(%ssigned-byte %d))\\\n\",SIGNED_(int),8*sizeof (int));~%") + (format stream "printf(\"(cl:deftype char () '(unsigned-byte %d))\\\n\",SIGNED_(char),8*sizeof (char));~%") + (format stream "printf(\"(cl:deftype long () '(unsigned-byte %d))\\\n\",SIGNED_(long),8*sizeof (long));~%") (dolist (def definitions) (destructuring-bind (type lispname cname &optional doc) def (cond ((eq type :integer) (format stream - "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%" + "printf(\"(cl:defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%" lispname doc cname)) + ((eq type :type) + (format stream + "printf(\"(sb-alien:define-alien-type ~A (sb-alien:%ssigned %d))\\\n\",SIGNED_(~A),8*(sizeof(~A)));~%" + lispname cname cname)) ((eq type :string) (format stream - "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" + "printf(\"(cl:defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" lispname doc cname)) ((eq type :function) (c-for-function stream lispname cname)) diff --git a/contrib/sb-posix/Makefile b/contrib/sb-posix/Makefile new file mode 100644 index 000000000..8243a7697 --- /dev/null +++ b/contrib/sb-posix/Makefile @@ -0,0 +1,2 @@ +SYSTEM=sb-posix +include ../asdf-module.mk diff --git a/contrib/sb-posix/README b/contrib/sb-posix/README new file mode 100644 index 000000000..075a55240 --- /dev/null +++ b/contrib/sb-posix/README @@ -0,0 +1,118 @@ +-*- Text -*- + +* Scope + +The scope of this interface is "operating system calls on a typical +Unixlike platform". This is section 2 of the Unix manual, plus +section 3 calls that are (a) typically found in libc, but (b) not part +of the C standard. For example, we intend to provide support for +opendir() and readdir() , but not for printf() + +Some facilities are omitted where they offer absolutely no additional +use over some portable function, or would be actively dangerous to the +consistency of Lisp. Not all functions are available on all +platforms. [TBD: unavailable functions should (a) not exist, or (b) +exist but signal some kind of "not available on this platform" error] + +The general intent is for a low-level interface. There are three +reasons for this: it's easier to write a high-level interface given a +low-level one than vice versa, there are fewer philosophical +disagreements about what it should look like, and the work of +implementing it is easily parallelisable - and in fact, can be +attempted on an as-needed basis by the various people who want it. + +* Function names + +The package name for this interface is SB-POSIX. In this package +there is a Lisp function for each supported Unix function, and a +variable or constant for each supported unix constant. A symbol name +is derived from the C binding's name, by (a) uppercasing, then (b) +replacing underscore (#\_) characters with the hyphen (#\-) + +No other changes to "Lispify" symbol names are made, so creat() +becomes CREAT, not CREATE + +The user is encouraged not to (USE-PACKAGE :SB-POSIX) but instead to +use the SB-POSIX: prefix on all references, as some of our symbols +have the same name as CL symbols (OPEN, CLOSE, SIGNAL etc). + +[ Rationale: We use similar names to the C bindings so that unix +manual pages can be used for documentation. To avoid name clashes +with CL or other functions, the approaches considered were (a) prefix +the names of clashing symbols with "POSIX-" or similar, (b) prefix +_all_ symbols with "POSIX-", (c) use the packaging system to resolve +ambiguities. (a) was rejected as the set of symbols we may +potentially clash with is not fixed (for example, if new symbols are +added to SB-EXT) so symbols might have to be renamed over the lifetime +of SB-POSIX, which is not good. The choice between (b) and (c) was +made on the grounds that POSIX-OPEN is about as much typing as +SB-POSIX:OPEN anyway, and symbol munging is, the author feels, +slightly tacky, when there's a package system available to do it more +cleanly ] + + +* Parameters + +The calling convention is modelled after that of CMUCL's UNIX package: +in particular, it's like the C interface except + +a) length arguments are omitted or optional where the sensible value +is obvious. For example, + +(read fd buffer &optional (length (length buffer))) => bytes-read + +b) where C simulates "out" parameters using pointers (for instance, in +pipe() or socketpair()) we may use multiple return values instead. +This doesn't apply to data transfer functions that fill buffers. + +c) some functions accept objects such as filenames or file +descriptors. In the C bindings these are strings and small integers +respectively. For the Lisp programmer's convenience we introduce +"filename designators" and "file descriptor designator" concepts such +that CL pathnames or open streams can be passed to these functions. + +[ Rationale: Keeping exact 1:1 correspondence with C conventions is +less important here, as the function argument list can easily be +accessed to find out exactly what the arguments are. Designators +are primarily a convenience feature ] + +* Return values + +The return value is usually the same as for the C binding, except in +error cases: where the C function is defined as returning some +sentinel value and setting "errno" on error, we instead signal an +error of type SYSCALL-ERROR. The actual error value ("errno") is +stored in this condition and can be accessed with SYSCALL-ERRNO. +[TBA: some interface to strerror, to get the user-readable translation +of the error number] + +We do not automatically translate the returned value into "Lispy" +objects - for example, SB-POSIX:OPEN returns a small integer, not a +stream. + +[ Rationale: This is an interface to POSIX, not a high-level interface +that uses POSIX, and many people using it will actually want to mess +with the file descriptors directly. People needing Lispy interfaces +can implement them atop this - or indeed, use the existing COMMON-LISP +package, which already has many high-level constructs built on top of +the operating system ;-) ] + + +* Implementation + +The initial implementation is in contrib/sb-posix, and being filled +out on an as-needed basis. Contributions following these style rules +are welcome from anyone who writes them, provided the author is happy +to release the code as Public Domain or MIT-style licence. + +See/update the TODO list for current status + +** Designators + +See designator.lisp, add a define-designator form + +** Adding functions + +The use of DEFINE-CALL macro in interface.lisp should be obvious from +the existing examples, if less so from the macroexpansion + diff --git a/contrib/sb-posix/TODO b/contrib/sb-posix/TODO new file mode 100644 index 000000000..b67b9d90c --- /dev/null +++ b/contrib/sb-posix/TODO @@ -0,0 +1,198 @@ +1) optional arguments + +3) partial list of section 2 manpages from Debian Linux box: functions +we may want to consider interfaces for. Some of the obviously +unnecessary/dangerous functions have been deleted from this list, as +have the ones we've already got bindings for, but even so, inclusion +in this list does _not_ imply we've definitely decided something needs +adding. + +FD_CLR +FD_ISSET +FD_SET +FD_ZERO +accept +acct +adjtime +adjtimex +bdflush +bind +break +brk +cacheflush +capget +capset +chroot +clone +connect +creat +create_module +delete_module +execve +exit +fcntl +fdatasync +flock +fork +fstat +fstatfs +fsync +ftime +ftruncate +getcontext +getdents +getdomainname +getdtablesize +getgroups +gethostid +gethostname +getitimer +getpagesize +getpeername +getpriority +getrlimit +getrusage +getsockname +getsockopt +gettimeofday +gtty +idle +init_module +ioctl +ioctl_list +ioperm +iopl +listen +llseek +lock +lseek +lstat +madvise +mincore +mknod +mlock +mlockall +mmap +modify_ldt +mount +mprotect +mpx +mremap +msgctl +msgget +msgop +msgrcv +msgsnd +msync +munlock +munlockall +munmap +nanosleep +nice +open +pause +pipe +poll +prctl +pread +prof +profil +pselect +ptrace +pwrite +query_module +quotactl +read +readdir +readlink +readv +reboot +recv +recvfrom +recvmsg +rename +rmdir +sbrk +sched_get_priority_max +sched_get_priority_min +sched_getparam +sched_getscheduler +sched_rr_get_interval +sched_setparam +sched_setscheduler +sched_yield +select +semctl +semget +semop +send +sendfile +sendmsg +sendto +setcontext +setdomainname +setgroups +sethostid +sethostname +setitimer +setpgrp +setpriority +setrlimit +setsid +setsockopt +settimeofday +sgetmask +shmat +shmctl +shmdt +shmget +shmop +shutdown +sigaction +sigaltstack +sigblock +siggetmask +sigmask +signal +sigpause +sigpending +sigprocmask +sigreturn +sigsetmask +sigsuspend +sigvec +socket +socketcall +socketpair +ssetmask +stat +statfs +stime +stty +swapoff +swapon +symlink +sync +syscalls +sysctl +sysfs +sysinfo +syslog +time +times +truncate +ulimit +umask +umount +uname +ustat +utime +utimes +vfork +vhangup +wait +wait3 +wait4 +waitpid +write +writev diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp new file mode 100644 index 000000000..587261f38 --- /dev/null +++ b/contrib/sb-posix/constants.lisp @@ -0,0 +1,46 @@ +;;; -*- Lisp -*- + +;;; This isn't really lisp, but it's definitely a source file. + +;;; first, the headers necessary to find definitions of everything +(#||# + "sys/types.h" + "unistd.h" + "sys/stat.h" + + "sys/socket.h" "sys/un.h" "netinet/in.h" "netinet/in_systm.h" + "netinet/ip.h" "net/if.h" "netdb.h" "errno.h" "netinet/tcp.h" + "fcntl.h" ) + +;;; then the stuff we're looking for +((:integer af-inet "AF_INET" "IP Protocol family") + + (:type uid-t "uid_t") + (:type gid-t "gid_t") + + (:type pid-t "pid_t") + + ;; mode_t + (:type mode-t "mode_t") + (:integer s-isuid "S_ISUID") + (:integer s-isgid "S_ISGID") + (:integer s-isvtx "S_ISVTX") + (:integer s-irusr "S_IRUSR") + (:integer s-iwusr "S_IWUSR") + (:integer s-ixusr "S_IXUSR") + (:integer s-iread "S_IRUSR") + (:integer s-iwrite "S_IWUSR") + (:integer s-iexec "S_IXUSR") + (:integer s-irgrp "S_IRGRP") + (:integer s-iwgrp "S_IWGRP") + (:integer s-ixgrp "S_IXGRP") + (:integer s-iroth "S_IROTH") + (:integer s-iwoth "S_IWOTH") + (:integer s-ixoth "S_IXOTH") + + ;; access() + (:integer r-ok "R_OK") + (:integer w-ok "W_OK") + (:integer x-ok "X_OK") + (:integer f-ok "F_OK") + ) \ No newline at end of file diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp new file mode 100644 index 000000000..0b94cdb2d --- /dev/null +++ b/contrib/sb-posix/defpackage.lisp @@ -0,0 +1,2 @@ +(defpackage :sb-posix (:use )) +(defpackage :sb-posix-internal (:use #:sb-alien #:cl)) diff --git a/contrib/sb-posix/designator.lisp b/contrib/sb-posix/designator.lisp new file mode 100644 index 000000000..2aa33e276 --- /dev/null +++ b/contrib/sb-posix/designator.lisp @@ -0,0 +1,24 @@ +(in-package :sb-posix-internal) +(defmacro define-designator (name result &body conversions) + (let ((type `(quote (or ,@(mapcar #'car conversions)))) + (typename (intern (format nil "~A-~A" + (symbol-name name) + (symbol-name :designator)) + #.*package*))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (deftype ,typename () ,type) + (setf (get ',name 'designator-type) ',result)) + (defun ,(intern (symbol-name name) :sb-posix) (,name) + (declare (type ,typename ,name)) + (etypecase ,name + ,@conversions))))) + +(define-designator filename c-string + (pathname (namestring (translate-logical-pathname filename))) + (string filename)) + +(define-designator file-descriptor (integer 32) + (sb-impl::file-stream (sb-impl::fd-stream-fd file-descriptor)) + (fixnum file-descriptor)) + diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp new file mode 100644 index 000000000..932cc96d0 --- /dev/null +++ b/contrib/sb-posix/interface.lisp @@ -0,0 +1,75 @@ +(cl:in-package :sb-posix-internal) + +(define-condition sb-posix::syscall-error (error) + ((errno :initarg :errno :reader sb-posix::syscall-errno)) + (:report (lambda (c s) + (let ((errno (sb-posix::syscall-errno c))) + (format s "System call error ~A (~A)" + errno (sb-int:strerror errno)))))) + +(defun syscall-error () + (error 'sb-posix::syscall-error :errno (get-errno))) + +;;; filesystem access + +(define-call "access" int minusp (pathname filename) (mode int)) +(define-call "chdir" int minusp (pathname filename)) +(define-call "chmod" int minusp (pathname filename) (mode sb-posix::mode-t)) +(define-call "chown" int minusp (pathname filename) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) +(define-call "close" int minusp (fd file-descriptor)) +(define-call "dup" int minusp (oldfd file-descriptor)) +(define-call "dup2" int minusp (oldfd file-descriptor) (newfd file-descriptor)) +(define-call "fchdir" int minusp (fd file-descriptor)) +(define-call "fchmod" int minusp (fd file-descriptor) (mode sb-posix::mode-t)) +(define-call "fchown" int minusp (fd file-descriptor) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) +(define-call "link" int minusp (oldpath filename) (newpath filename)) +(define-call "lchown" int minusp (pathname filename) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) +(define-call "mkdir" int minusp (pathname filename) (mode sb-posix::mode-t)) +;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int)) +(define-call "rmdir" int minusp (pathname filename)) +(define-call "symlink" int minusp (oldpath filename) (newpath filename)) +(define-call "unlink" int minusp (pathname filename)) + + +;;; uid, gid + +(define-call "geteuid" sb-posix::uid-t not) ;"always successful", it says +(define-call "getresuid" sb-posix::uid-t not) +(define-call "getuid" sb-posix::uid-t not) +(define-call "seteuid" int minusp (uid sb-posix::uid-t)) +#+linux (define-call "setfsuid" int minusp (uid sb-posix::uid-t)) +(define-call "setreuid" int minusp + (ruid sb-posix::uid-t) (euid sb-posix::uid-t)) +(define-call "setresuid" int minusp + (ruid sb-posix::uid-t) (euid sb-posix::uid-t) + (suid sb-posix::uid-t)) +(define-call "setuid" int minusp (uid sb-posix::uid-t)) + +(define-call "getegid" sb-posix::gid-t not) +(define-call "getgid" sb-posix::gid-t not) +(define-call "getresgid" sb-posix::gid-t not) +(define-call "setegid" int minusp (gid sb-posix::gid-t)) +#+linux (define-call "setfsgid" int minusp (gid sb-posix::gid-t)) +(define-call "setgid" int minusp (gid sb-posix::gid-t)) +(define-call "setregid" int minusp + (rgid sb-posix::gid-t) (egid sb-posix::gid-t)) +(define-call "setresgid" int minusp + (rgid sb-posix::gid-t) + (egid sb-posix::gid-t) (sgid sb-posix::gid-t)) + +;;; processes, signals +(define-call "alarm" int not (seconds unsigned)) +(define-call "getpgid" sb-posix::pid-t minusp (pid sb-posix::pid-t)) +(define-call "getpid" sb-posix::pid-t not) +(define-call "getppid" sb-posix::pid-t not) +(define-call "getpgrp" sb-posix::pid-t not) +(define-call "getsid" sb-posix::pid-t minusp (pid sb-posix::pid-t)) +(define-call "kill" int minusp (pid sb-posix::pid-t) (signal int)) +(define-call "killpg" int minusp (pgrp int) (signal int)) +(define-call "pause" int minusp) +(define-call "setpgid" int minusp + (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) +(define-call "setpgrp" int minusp) diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp new file mode 100644 index 000000000..d32bfe544 --- /dev/null +++ b/contrib/sb-posix/macros.lisp @@ -0,0 +1,26 @@ +(in-package :sb-posix-internal) + +(defun lisp-for-c-symbol (s) + (intern (substitute #\- #\_ (string-upcase s)) :sb-posix)) + +(defmacro define-call (name return-type error-predicate &rest arguments) + (let ((lisp-name (lisp-for-c-symbol name))) + `(progn + (export ',lisp-name :sb-posix) + (declaim (inline ,lisp-name)) + (defun ,lisp-name ,(mapcar #'car arguments) + (let ((r (alien-funcall + (extern-alien + ,name + (function ,return-type + ,@(mapcar + (lambda (x) + (get (cadr x) 'designator-type (cadr x))) + arguments))) + ,@(mapcar (lambda (x) + (if (get (cadr x) 'designator-type) + `(,(intern (symbol-name (cadr x)) :sb-posix) + ,(car x)) + (car x))) + arguments)))) + (if (,error-predicate r) (syscall-error) r)))))) diff --git a/contrib/sb-posix/sb-posix.asd b/contrib/sb-posix/sb-posix.asd new file mode 100644 index 000000000..052e5317a --- /dev/null +++ b/contrib/sb-posix/sb-posix.asd @@ -0,0 +1,20 @@ +;;; -*- Lisp -*- +(require :sb-grovel) +(defpackage #:sb-posix-system (:use #:asdf #:cl #:sb-grovel)) +(in-package #:sb-posix-system) + +(defsystem sb-posix + :depends-on (sb-grovel) + :components ((:file "defpackage") + (:file "designator" :depends-on ("defpackage")) + (:file "macros" :depends-on ("defpackage")) + (sb-grovel:grovel-constants-file + "constants" + :package :sb-posix :depends-on ("defpackage")) + (:file "interface" :depends-on ("constants" "macros")))) + +#| +(defmethod perform ((o test-op) (c (eql (find-system :sb-grovel)))) + t) + +|# \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 17ce5332d..97fe437b3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.56" +"0.pre8.57" -- 2.11.4.GIT