From fc40a0aa203ace773c9ea059621be448718167c1 Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Fri, 23 Jan 2009 16:32:56 +0100 Subject: [PATCH] Better DEFSYSCALL. --- syscalls/early.lisp | 115 ++++++++++++++++++++++----------------- syscalls/ffi-functions-unix.lisp | 92 +++++++++++++++++++------------ syscalls/os-conditions-unix.lisp | 12 +--- syscalls/pkgdcl.lisp | 7 ++- 4 files changed, 126 insertions(+), 100 deletions(-) diff --git a/syscalls/early.lisp b/syscalls/early.lisp index ccb95c4..e1f8e6e 100644 --- a/syscalls/early.lisp +++ b/syscalls/early.lisp @@ -29,61 +29,90 @@ ;;; function's return value (after going through RETURN-FILTER). If ;;; ERROR-PREDICATE returns true, ERROR-GENERATOR is invoked. See the ;;; RETURN-WRAPPER parse method and type translation. -(define-foreign-type return-wrapper () +(define-foreign-type syscall-wrapper () ((error-predicate :initarg :error-predicate :reader error-predicate-of) + (error-location :initarg :error-location :reader error-location-of) (return-filter :initarg :return-filter :reader return-filter-of) (error-generator :initarg :error-generator :reader error-generator-of) + (restart :initarg :restart :reader syscall-restart-p) (base-type :initarg :base-type :reader base-type-of))) -(define-parse-method return-wrapper - (base-type &key error-predicate (return-filter 'identity) error-generator) +(defun default-error-predicate (base-type) + (case base-type + (:string + '(lambda (s) (not (stringp s)))) + (t + (case (cffi::canonicalize-foreign-type base-type) + (:pointer + 'null-pointer-p) + ((:char :short :int :long :long-long) + 'minusp) + ;; FIXME: go here if the canonical type is unsigned. + ((:unsigned-char :unsigned-short :unsigned-int + :unsigned-long :unsigned-long-long :void) + 'never-fails) + (t + (error "Could not choose an error-predicate function.")))))) + +(define-parse-method syscall-wrapper + (base-type &key (restart nil restart-p) + (error-predicate 'never-fails error-predicate-p) + (error-location :errno) + (return-filter 'identity) + (error-generator 'signal-posix-error)) ;; pick a default error-predicate - (unless error-predicate - (case base-type - (:string - (setf error-predicate '(lambda (s) (not (stringp s))))) - (t - (case (cffi::canonicalize-foreign-type base-type) - (:pointer - (setf error-predicate 'null-pointer-p)) - ((:char :short :int :long :long-long) - (setf error-predicate 'minusp)) - ;; FIXME: go here if the canonical type is unsigned. - ((:unsigned-char :unsigned-short :unsigned-int - :unsigned-long :unsigned-long-long :void) - (setf error-predicate 'never-fails)) - (t - (error "Could not choose an error-predicate function.")))))) + (unless error-predicate-p + (setf error-predicate (default-error-predicate base-type))) + (when (and (not restart-p) (eql 't restart)) + (setf error-generator 'signal-posix-error/restart)) (unless (or (eql 'never-fails error-predicate) error-generator) (error "Function can fail but no error-generator suplied.")) - (make-instance 'return-wrapper + (make-instance 'syscall-wrapper :actual-type base-type :base-type base-type + :restart restart :error-predicate error-predicate + :error-location error-location :return-filter return-filter :error-generator error-generator)) ;;; This type translator sets up the appropriate calls to ;;; RETURN-FILTER, ERROR-PREDICATE and ERROR-GENERATOR around the ;;; foreign function call. -(defmethod expand-from-foreign (value (type return-wrapper)) +(defmethod expand-from-foreign (value (type syscall-wrapper)) (if (and (eql 'identity (return-filter-of type)) (eql 'never-fails (error-predicate-of type))) value - (with-gensyms (block) - `(block ,block - (tagbody :restart - (let ((r (convert-from-foreign ,value ',(base-type-of type)))) - ,(let ((return-exp - (if (eql 'identity (return-filter-of type)) - 'r - `(,(return-filter-of type) r)))) - `(return-from ,block - ,(if (eql 'never-fails (error-predicate-of type)) - `return-exp - `(if (,(error-predicate-of type) r) - (,(error-generator-of type) r) - ,return-exp)))))))))) + (with-gensyms (retval errno block) + (let ((foreign-call + `(let* ,(remove-if 'null + `((,retval (convert-from-foreign ,value ',(base-type-of type))) + ,(case (error-location-of type) + (:errno `(,errno (%sys-errno))) + (:return `(,errno ,retval))))) + ,(let* ((return-val-exp + (if (eql 'identity (return-filter-of type)) + retval + `(,(return-filter-of type) ,retval))) + (return-exp + (if (eql 'never-fails (error-predicate-of type)) + `return-val-exp + `(if (,(error-predicate-of type) ,retval) + (,(error-generator-of type) ,errno) + ,return-val-exp)))) + (if (syscall-restart-p type) + `(return-from ,block ,return-exp) + return-exp))))) + (if (syscall-restart-p type) + `(block ,block + (tagbody :restart + ,foreign-call)) + foreign-call))))) + +(defmacro signal-posix-error/restart (errno) + `(if (= eintr ,errno) + (go :restart) + (signal-posix-error ,errno))) (defun foreign-name (spec &optional varp) @@ -121,25 +150,11 @@ (defcfun (,c-name ,lisp-name ,@options) ,return-type ,@args)))) -(defmacro signal-posix-error/restart (ret) - `(if (= eintr (%sys-errno)) - (go :restart) - (signal-posix-error ,ret))) - (defmacro defsyscall (name-and-opts return-type &body args) (multiple-value-bind (lisp-name c-name options) (parse-name-and-options name-and-opts) `(progn (declaim (inline ,lisp-name)) (defcfun (,c-name ,lisp-name ,@options) - (return-wrapper ,return-type :error-generator signal-posix-error) - ,@args)))) - -(defmacro defsyscall* (name-and-opts return-type &body args) - (multiple-value-bind (lisp-name c-name options) - (parse-name-and-options name-and-opts) - `(progn - (declaim (inline ,lisp-name)) - (defcfun (,c-name ,lisp-name ,@options) - (return-wrapper ,return-type :error-generator signal-posix-error/restart) + (syscall-wrapper ,@(ensure-list return-type)) ,@args)))) diff --git a/syscalls/ffi-functions-unix.lisp b/syscalls/ffi-functions-unix.lisp index 575f26a..1b44bd7 100644 --- a/syscalls/ffi-functions-unix.lisp +++ b/syscalls/ffi-functions-unix.lisp @@ -77,28 +77,30 @@ The two memory areas may overlap." ;;; I/O ;;;------------------------------------------------------------------------- -(defsyscall* (%sys-read "read") ssize-t +(defsyscall (%sys-read "read") + (ssize-t :restart t) "Read at most COUNT bytes from FD into the foreign area BUF." (fd :int) (buf :pointer) (count size-t)) -(defsyscall* (%sys-write "write") ssize-t +(defsyscall (%sys-write "write") + (ssize-t :restart t) "Write at most COUNT bytes to FD from the foreign area BUF." (fd :int) (buf :pointer) (count size-t)) -(defsyscall* (%sys-pread (#+linux "pread64" "pread")) - ssize-t +(defsyscall (%sys-pread (#+linux "pread64" "pread")) + (ssize-t :restart t) "Read at most COUNT bytes from FD at offset OFFSET into the foreign area BUF." (fd :int) (buf :pointer) (count size-t) (offset off-t)) -(defsyscall* (%sys-pwrite (#+linux "pwrite64" "pwrite")) - ssize-t +(defsyscall (%sys-pwrite (#+linux "pwrite64" "pwrite")) + (ssize-t :restart t) "Write at most COUNT bytes to FD at offset OFFSET from the foreign area BUF." (fd :int) (buf :pointer) @@ -110,7 +112,8 @@ The two memory areas may overlap." ;;; Files ;;;------------------------------------------------------------------------- -(defsyscall* (%%sys-open "open") :int +(defsyscall (%%sys-open "open") + (:int :restart t) (path filename-designator) (flags :int) (mode mode-t)) @@ -122,7 +125,8 @@ The two memory areas may overlap." \(default value is *DEFAULT-OPEN-MODE* - #o666)." (%%sys-open path flags mode)) -(defsyscall* (%sys-creat "creat") :int +(defsyscall (%sys-creat "creat") + (:int :restart t) "Create file PATH with permissions MODE and return the new FD." (path filename-designator) (mode mode-t)) @@ -159,14 +163,14 @@ to the argument OFFSET according to the directive WHENCE." (path filename-designator) (mode :int)) -(defsyscall* (%sys-truncate (#+linux "truncate64" "truncate")) - :int +(defsyscall (%sys-truncate (#+linux "truncate64" "truncate")) + (:int :restart t) "Truncate the file PATH to a size of precisely LENGTH octets." (path filename-designator) (length off-t)) -(defsyscall* (%sys-ftruncate (#+linux "ftruncate64" "ftruncate")) - :int +(defsyscall (%sys-ftruncate (#+linux "ftruncate64" "ftruncate")) + (:int :restart t) "Truncate the file referenced by FD to a size of precisely LENGTH octets." (fd :int) (length off-t)) @@ -201,30 +205,35 @@ to the argument OFFSET according to the directive WHENCE." "Delete the file PATH from the file system." (path filename-designator)) -(defsyscall* (%sys-chown "chown") :int +(defsyscall (%sys-chown "chown") + (:int :restart t) "Change ownership of file PATH to uid OWNER and gid GROUP(dereferences symlinks)." (path filename-designator) (owner uid-t) (group uid-t)) -(defsyscall* (%sys-fchown "fchown") :int +(defsyscall (%sys-fchown "fchown") + (:int :restart t) "Change ownership of an open file referenced by FD to uid OWNER and gid GROUP." (fd :int) (owner uid-t) (group uid-t)) -(defsyscall* (%sys-lchown "lchown") :int +(defsyscall (%sys-lchown "lchown") + (:int :restart t) "Change ownership of a file PATH to uid OWNER and gid GROUP(does not dereference symlinks)." (path filename-designator) (owner uid-t) (group uid-t)) -(defsyscall* (%sys-chmod "chmod") :int +(defsyscall (%sys-chmod "chmod") + (:int :restart t) "Change permissions of file PATH to mode MODE." (path filename-designator) (mode mode-t)) -(defsyscall* (%sys-fchmod "fchmod") :int +(defsyscall (%sys-fchmod "fchmod") + (:int :restart t) "Change permissions of open file referenced by FD to mode MODE." (fd :int) (mode mode-t)) @@ -279,7 +288,8 @@ to the argument OFFSET according to the directive WHENCE." (defsyscall (%sys-sync "sync") :void "Schedule all file system buffers to be written to disk.") -(defsyscall* (%sys-fsync "fsync") :int +(defsyscall (%sys-fsync "fsync") + (:int :restart t) "Schedule a file's buffers to be written to disk." (fildes :int)) @@ -310,7 +320,8 @@ to the argument OFFSET according to the directive WHENCE." "Change the current working directory to PATH." (path filename-designator)) -(defsyscall* (%sys-fchdir "fchdir") :int +(defsyscall (%sys-fchdir "fchdir") + (:int :restart t) "Change the current working directory to the directory referenced by FD." (fildes :int)) @@ -345,17 +356,20 @@ to the argument OFFSET according to the directive WHENCE." "Duplicate file descriptor FD." (fd :int)) -(defsyscall* (%sys-dup2 "dup2") :int +(defsyscall (%sys-dup2 "dup2") + (:int :restart t) "Make NEWFD be the copy of OLDFD, closing NEWFD first if necessary." (oldfd :int) (newfd :int)) -(defsyscall* (%sys-ioctl/2 "ioctl") :int +(defsyscall (%sys-ioctl/2 "ioctl") + (:int :restart t) "Send request REQUEST to file referenced by FD." (fd :int) (request :int)) -(defsyscall* (%sys-ioctl/3 "ioctl") :int +(defsyscall (%sys-ioctl/3 "ioctl") + (:int :restart t) "Send request REQUEST to file referenced by FD using argument ARG." (fd :int) (request :int) @@ -395,9 +409,10 @@ to the argument OFFSET according to the directive WHENCE." "Close directory DIR when done listing its contents." (dir :pointer)) -(defcfun* (%%sys-readdir-r (#+linux "readdir64_r" "readdir_r")) - (return-wrapper :int :error-predicate (lambda (r) (not (zerop r))) - :error-generator signal-posix-error-from-return-value) +(defsyscall (%%sys-readdir-r (#+linux "readdir64_r" "readdir_r")) + (:int + :error-predicate plusp + :error-location :return) (dirp :pointer) (entry :pointer) (result :pointer)) @@ -597,7 +612,8 @@ as indicated by WHICH and WHO to VALUE." ;;; Time ;;;------------------------------------------------------------------------- -(defsyscall* (%sys-usleep "usleep") :int +(defsyscall (%sys-usleep "usleep") + (:int :restart t) "Suspend execution for USECONDS microseconds." (useconds useconds-t)) @@ -765,18 +781,20 @@ The environment variable is overwritten only if overwrite it non-NIL." ;;; User info ;;;------------------------------------------------------------------------- -(defcfun (%%sys-getpwuid-r "getpwuid_r") - (return-wrapper :int :error-predicate (lambda (x) (not (zerop x))) - :error-generator signal-posix-error-from-return-value) +(defsyscall (%%sys-getpwuid-r "getpwuid_r") + (:int + :error-predicate plusp + :error-location :return) (uid uid-t) (pwd :pointer) (buffer :pointer) (bufsize size-t) (result :pointer)) -(defcfun (%%sys-getpwnam-r "getpwnam_r") - (return-wrapper :int :error-predicate (lambda (x) (not (zerop x))) - :error-generator signal-posix-error-from-return-value) +(defsyscall (%%sys-getpwnam-r "getpwnam_r") + (:int + :error-predicate plusp + :error-location :return) (name :string) (pwd :pointer) (buffer :pointer) @@ -806,8 +824,9 @@ The environment variable is overwritten only if overwrite it non-NIL." ;;;------------------------------------------------------------------------- (defsyscall (%%sys-getgrgid-r "getgrgid_r") - (return-wrapper :int :error-predicate (lambda (x) (not (zerop x))) - :error-generator signal-posix-error-from-return-value) + (:int + :error-predicate plusp + :error-location :return) (uid uid-t) (grp :pointer) (buffer :pointer) @@ -815,8 +834,9 @@ The environment variable is overwritten only if overwrite it non-NIL." (result :pointer)) (defsyscall (%%sys-getgrnam-r "getgrnam_r") - (return-wrapper :int :error-predicate (lambda (x) (not (zerop x))) - :error-generator signal-posix-error-from-return-value) + (:int + :error-predicate plusp + :error-location :return) (name :string) (grp :pointer) (buffer :pointer) diff --git a/syscalls/os-conditions-unix.lisp b/syscalls/os-conditions-unix.lisp index 08cbfdc..177e57c 100644 --- a/syscalls/os-conditions-unix.lisp +++ b/syscalls/os-conditions-unix.lisp @@ -51,15 +51,5 @@ (make-condition (get-posix-error-condition error-keyword)))) (declaim (inline posix-error)) -(defun posix-error (&optional (errno (%sys-errno))) +(defun signal-posix-error (&optional (errno (%sys-errno))) (error (make-posix-error errno))) - -;;; Default ERROR-GENERATOR for ERRNO-WRAPPER. -(declaim (inline signal-posix-error)) -(defun signal-posix-error (return-value) - (declare (ignore return-value)) - (posix-error)) - -(declaim (inline signal-posix-error-from-return-value)) -(defun signal-posix-error-from-return-value (return-value) - (posix-error return-value)) diff --git a/syscalls/pkgdcl.lisp b/syscalls/pkgdcl.lisp index 0a6de91..255e655 100644 --- a/syscalls/pkgdcl.lisp +++ b/syscalls/pkgdcl.lisp @@ -39,11 +39,13 @@ #:repeat-decreasing-timeout #:repeat-upon-condition-decreasing-timeout - ;; Return wrapper - #:return-wrapper + ;; Syscall return wrapper + #:syscall-wrapper #:error-predicate-of + #:error-location-of #:return-filter-of #:error-generator-of + #:syscall-restart-p #:base-type-of #:never-fails #:signal-posix-error @@ -53,7 +55,6 @@ #:defentrypoint #:defcfun* #:defsyscall - #:defsyscall* ;;;-------------------------------------------------------------------------- ;;; Syscalls -- 2.11.4.GIT