From d4c7ab04ed10729a2cfa3321f4382d8a218ad958 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs Date: Thu, 27 May 2004 13:58:15 +0000 Subject: [PATCH] 0.8.10.56: MORE ALIENS! sb-grovel now defines alien structures. Affected: ... sb-grovel, obviously. Reworked the def-to-lisp mechanism a bit and then hacked foreign-glue. .... array-data.lisp isn't needed by sb-grovel any more, and any code that uses it will probably break anyway; removed it. .... The Manual: Now there's a section on sb-grovel usage. sb-grovel's README is no more. ... sb-bsd-sockets: It had to learn to use aliens instead of non-typechecked lisp arrays. I hope there are no memory leaks. ... ditto for sb-posix. Thanks to vja for patches & patiently testing my changes on x86 and SPARC. --- contrib/sb-bsd-sockets/constants.lisp | 34 +- contrib/sb-bsd-sockets/inet.lisp | 48 ++- contrib/sb-bsd-sockets/local.lisp | 15 +- contrib/sb-bsd-sockets/name-service.lisp | 57 ++-- contrib/sb-bsd-sockets/sockets.lisp | 134 ++++---- contrib/sb-bsd-sockets/sockopt.lisp | 103 +++--- contrib/sb-grovel/README | 41 --- contrib/sb-grovel/array-data.lisp | 72 ----- contrib/sb-grovel/def-to-lisp.lisp | 169 ++++++---- contrib/sb-grovel/foreign-glue.lisp | 499 ++++++++++++++++++++++-------- contrib/sb-grovel/sb-grovel.asd | 3 +- contrib/sb-grovel/sb-grovel.texinfo | 244 +++++++++++++++ contrib/sb-posix/constants.lisp | 9 +- contrib/sb-posix/interface.lisp | 145 +++++---- doc/manual/Makefile | 2 +- version.lisp-expr | 2 +- 16 files changed, 994 insertions(+), 583 deletions(-) delete mode 100644 contrib/sb-grovel/README delete mode 100644 contrib/sb-grovel/array-data.lisp create mode 100644 contrib/sb-grovel/sb-grovel.texinfo diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 9dbf4f7..fa17043 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -104,23 +104,27 @@ (buf (* t)))) |# (:structure protoent ("struct protoent" - ((* t) name "char *" "p_name") + (c-string-pointer name "char *" "p_name") ((* (* t)) aliases "char **" "p_aliases") (integer proto "int" "p_proto"))) (:function getprotobyname ("getprotobyname" (* t) (name c-string))) (:integer inaddr-any "INADDR_ANY") (:structure in-addr ("struct in_addr" - ((array (unsigned 8) 4) addr "u_int32_t" "s_addr"))) + ((array (unsigned 8)) addr "u_int32_t" "s_addr"))) (:structure sockaddr-in ("struct sockaddr_in" (integer family "sa_family_t" "sin_family") - ((array (unsigned 8) 2) port "u_int16_t" "sin_port") - ((array (unsigned 8) 4) addr "struct in_addr" "sin_addr"))) + ;; These two could be in-port-t and + ;; in-addr-t, but then we'd throw away the + ;; convenience (and byte-order agnosticism) + ;; of the old sb-grovel scheme. + ((array (unsigned 8)) port "u_int16_t" "sin_port") + ((array (unsigned 8)) addr "struct in_addr" "sin_addr"))) (:structure sockaddr-un ("struct sockaddr_un" (integer family "sa_family_t" "sun_family") - ((array (unsigned 8) 108) path "char" "sun_path"))) + (c-string path "char" "sun_path"))) (:structure hostent ("struct hostent" - ((* t) name "char *" "h_name") + (c-string-pointer name "char *" "h_name") ((* c-string) aliases "char **" "h_aliases") (integer type "int" "h_addrtype") (integer length "int" "h_length") @@ -131,26 +135,26 @@ (protocol integer))) (:function bind ("bind" integer (sockfd integer) - (my-addr (* t)) + (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen integer))) (:function listen ("listen" integer (socket integer) (backlog integer))) (:function accept ("accept" integer (socket integer) - (my-addr (* t)) + (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen integer :in-out))) (:function getpeername ("getpeername" integer (socket integer) - (her-addr (* t)) + (her-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen integer :in-out))) (:function getsockname ("getsockname" integer (socket integer) - (my-addr (* t)) + (my-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen integer :in-out))) (:function connect ("connect" integer (socket integer) - (his-addr (* t)) + (his-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen integer ))) (:function close ("close" integer @@ -160,10 +164,10 @@ (buf (* t)) (len integer) (flags integer) - (sockaddr (* t)) + (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (socklen (* integer)))) - (:function gethostbyname ("gethostbyname" (* t ) (name c-string))) - (:function gethostbyaddr ("gethostbyaddr" (* t ) + (:function gethostbyname ("gethostbyname" (* hostent) (name c-string))) + (:function gethostbyaddr ("gethostbyaddr" (* hostent) (addr (* t)) (len integer) (af integer))) @@ -182,5 +186,5 @@ (level integer) (optname integer) (optval (* t)) - (optlen integer :in-out)))) + (optlen (* integer))))) ) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 3ea609e..59f95f0 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -26,10 +26,9 @@ (defun make-inet-address (dotted-quads) "Return a vector of octets given a string DOTTED-QUADS in the format \"127.0.0.1\"" - (coerce - (mapcar #'parse-integer - (split dotted-quads nil '(#\.))) - 'vector)) + (map 'vector + #'parse-integer + (split dotted-quads nil '(#\.)))) ;;; getprotobyname only works in the internet domain, which is why this ;;; is here @@ -38,52 +37,49 @@ using getprotobyname(2) which typically looks in NIS or /etc/protocols" ;; for extra brownie points, could return canonical protocol name ;; and aliases as extra values - (let ((ent (sb-grovel::foreign-vector (sockint::getprotobyname name) 1 - sockint::size-of-protoent))) + (let ((ent (sockint::getprotobyname name))) (sockint::protoent-proto ent))) - -;;; sockaddr protocol -;;; (1) sockaddrs are represented as the semi-foreign array-of-octets -;;; thing -;;; (2) a protocol provides make-sockaddr-for, size-of-sockaddr, +;;; our protocol provides make-sockaddr-for, size-of-sockaddr, ;;; bits-of-sockaddr (defmethod make-sockaddr-for ((socket inet-socket) &optional sockaddr &rest address &aux (host (first address)) (port (second address))) (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-in)))) (when (and host port) + (setf host (coerce host '(simple-array (unsigned-byte 8) (4)))) ;; port and host are represented in C as "network-endian" unsigned ;; integers of various lengths. This is stupid. The value of the ;; integer doesn't matter (and will change depending on your ;; machine's endianness); what the bind(2) call is interested in ;; is the pattern of bytes within that integer. - + ;; We have no truck with such dreadful type punning. Octets to ;; octets, dust to dust. (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet) - (setf (sockint::sockaddr-in-port sockaddr 0) (ldb (byte 8 8) port)) - (setf (sockint::sockaddr-in-port sockaddr 1) (ldb (byte 8 0) port)) - - (setf (sockint::sockaddr-in-addr sockaddr 0) (elt host 0)) - (setf (sockint::sockaddr-in-addr sockaddr 1) (elt host 1)) - (setf (sockint::sockaddr-in-addr sockaddr 2) (elt host 2)) - (setf (sockint::sockaddr-in-addr sockaddr 3) (elt host 3))) + (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0) (ldb (byte 8 8) port)) + (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1) (ldb (byte 8 0) port)) + + (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 0) (elt host 0)) + (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 1) (elt host 1)) + (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 2) (elt host 2)) + (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) 3) (elt host 3))) sockaddr)) +(defmethod free-sockaddr-for ((socket inet-socket) sockaddr) + (sockint::free-sockaddr-in sockaddr)) + (defmethod size-of-sockaddr ((socket inet-socket)) sockint::size-of-sockaddr-in) (defmethod bits-of-sockaddr ((socket inet-socket) sockaddr) "Returns address and port of SOCKADDR as multiple values" (values - (vector - (sockint::sockaddr-in-addr sockaddr 0) - (sockint::sockaddr-in-addr sockaddr 1) - (sockint::sockaddr-in-addr sockaddr 2) - (sockint::sockaddr-in-addr sockaddr 3)) - (+ (* 256 (sockint::sockaddr-in-port sockaddr 0)) - (sockint::sockaddr-in-port sockaddr 1)))) + (coerce (loop for i from 0 below 4 + collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) + '(vector (unsigned-byte 8) 4)) + (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0)) + (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))) (defun make-inet-socket (type protocol) "Make an INET socket. Deprecated in favour of make-instance" diff --git a/contrib/sb-bsd-sockets/local.lisp b/contrib/sb-bsd-sockets/local.lisp index cf106f1..ccc220b 100644 --- a/contrib/sb-bsd-sockets/local.lisp +++ b/contrib/sb-bsd-sockets/local.lisp @@ -19,22 +19,17 @@ a network. (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un)))) (setf (sockint::sockaddr-un-family sockaddr) sockint::af-local) (when filename - (loop for c across filename - ;; XXX magic constant ew ew ew. should grovel this from - ;; system headers - for i from 0 to (min 107 (1- (length filename))) - do (setf (sockint::sockaddr-un-path sockaddr i) (char-code c)) - finally - (setf (sockint::sockaddr-un-path sockaddr (1+ i)) 0))) + (setf (sockint::sockaddr-un-path sockaddr) filename)) sockaddr)) +(defmethod free-sockaddr-for ((socket local-socket) sockaddr) + (sockint::free-sockaddr-un sockaddr)) + (defmethod size-of-sockaddr ((socket local-socket)) sockint::size-of-sockaddr-un) (defmethod bits-of-sockaddr ((socket local-socket) sockaddr) "Return the file name of the local socket address SOCKADDR." - (let ((name (sb-c-call::%naturalize-c-string - (sb-sys:sap+ (sb-grovel::array-data-address sockaddr) - sockint::offset-of-sockaddr-un-path)))) + (let ((name (sockint::sockaddr-un-path sockaddr))) (if (zerop (length name)) nil name))) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index c5ba475..7fc2892 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -31,44 +31,42 @@ eventually, so that we can do DNS lookups in parallel with other things "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. HOST-NAME may also be an IP address in dotted quad notation or some other weird stuff - see gethostbyname(3) for grisly details." - (let ((h (sockint::gethostbyname host-name))) - (make-host-ent h))) + (make-host-ent (sockint::gethostbyname host-name))) (defun get-host-by-address (address) "Returns a HOST-ENT instance for ADDRESS, which should be a vector of -(integer 0 255), or throws some kind of error. See gethostbyaddr(3) for + (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for grisly details." - (let ((packed-addr (sockint::allocate-in-addr))) - (loop for i from 0 to 3 - do (setf (sockint::in-addr-addr packed-addr i) (elt address i))) - (make-host-ent - (sb-sys:with-pinned-objects (packed-addr) - (sockint::gethostbyaddr (sb-grovel::array-data-address packed-addr) - 4 - sockint::af-inet))))) + (sockint::with-in-addr packed-addr () + (let ((addr-vector (coerce address 'vector))) + (loop for i from 0 below (length addr-vector) + do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i) + (elt addr-vector i))) + (make-host-ent (sockint::gethostbyaddr packed-addr + 4 + sockint::af-inet))))) (defun make-host-ent (h) (if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname")) - (let* ((local-h (sb-grovel::foreign-vector h 1 sockint::size-of-hostent)) - (length (sockint::hostent-length local-h)) - (aliases - (loop for i = 0 then (1+ i) - for al = (sb-sys:sap-ref-sap - (sb-sys:int-sap (sockint::hostent-aliases local-h)) - (* i 4)) - until (= (sb-sys:sap-int al) 0) - collect (sb-c-call::%naturalize-c-string al))) - (address0 (sb-sys:sap-ref-sap (sb-sys:int-sap (sockint::hostent-addresses local-h)) 0)) + (let* ((length (sockint::hostent-length h)) + (aliases (loop for i = 0 then (1+ i) + for al = (sb-alien:deref (sockint::hostent-aliases h) i) + while al + collect al)) + (address0 (sockint::hostent-addresses h)) (addresses - (loop for i = 0 then (+ length i) - for ad = (sb-sys:sap-ref-32 address0 i) - while (> ad 0) - collect - (sb-grovel::foreign-vector (sb-sys:sap+ address0 i) 1 length)))) + (loop for i = 0 then (1+ i) + for ad = (sb-alien:deref address0 i) + until (sb-alien:null-alien ad) + collect (ecase (sockint::hostent-type h) + (#.sockint::af-inet + (loop for i from 0 below length + collect (sb-alien:deref ad i))) + (#.sockint::af-local + (sb-alien:cast ad sb-alien:c-string)))))) (make-instance 'host-ent - :name (sb-c-call::%naturalize-c-string - (sb-sys:int-sap (sockint::hostent-name local-h))) - :type (sockint::hostent-type local-h) + :name (sockint::hostent-name h) + :type (sockint::hostent-type h) :aliases aliases :addresses addresses))) @@ -143,4 +141,3 @@ GET-NAME-SERVICE-ERRNO") (defun get-name-service-error-message (num) (hstrerror num)) ) - diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index 9f15ad6..6c68594 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -49,6 +49,15 @@ (:documentation "Return a Socket Address object suitable for use with SOCKET. When SOCKADDR is passed, it is used instead of a new object.")) +(defgeneric free-sockaddr-for (socket sockaddr) + (:documentation "Deallocate a Socket Address object that was +created for SOCKET.")) + +(defmacro with-sockaddr-for ((socket sockaddr sockaddr-args) &body body) + `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args))) + (unwind-protect (progn ,@body) + (free-sockaddr-for ,socket ,sockaddr)))) + ;; we deliberately redesign the "bind" interface: instead of passing a ;; sockaddr_something as second arg, we pass the elements of one as ;; multiple arguments. @@ -61,11 +70,10 @@ See also bind(2)")) (defmethod socket-bind ((socket socket) &rest address) - (let ((sockaddr (apply #'make-sockaddr-for socket nil address))) - (if (= (sb-sys:with-pinned-objects (sockaddr) - (sockint::bind (socket-file-descriptor socket) - (sb-grovel::array-data-address sockaddr) - (size-of-sockaddr socket))) + (with-sockaddr-for (socket sockaddr address) + (if (= (sockint::bind (socket-file-descriptor socket) + sockaddr + (size-of-sockaddr socket)) -1) (socket-error "bind")))) @@ -76,44 +84,41 @@ newly-created connected socket and the peer address as multiple values")) (defmethod socket-accept ((socket socket)) - (let ((sockaddr (make-sockaddr-for socket))) - (sb-sys:with-pinned-objects (sockaddr) - (let ((fd (sockint::accept (socket-file-descriptor socket) - (sb-grovel::array-data-address sockaddr) - (size-of-sockaddr socket)))) - (apply #'values - (if (= fd -1) - (socket-error "accept") - (let ((s (make-instance (class-of socket) - :type (socket-type socket) - :protocol (socket-protocol socket) - :descriptor fd))) - (sb-ext:finalize s (lambda () (sockint::close fd))))) - (multiple-value-list (bits-of-sockaddr socket sockaddr))))))) + (with-sockaddr-for (socket sockaddr nil) + (let ((fd (sockint::accept (socket-file-descriptor socket) + sockaddr + (size-of-sockaddr socket)))) + (apply #'values + (if (= fd -1) + (socket-error "accept") + (let ((s (make-instance (class-of socket) + :type (socket-type socket) + :protocol (socket-protocol socket) + :descriptor fd))) + (sb-ext:finalize s (lambda () (sockint::close fd))))) + (multiple-value-list (bits-of-sockaddr socket sockaddr)))))) (defgeneric socket-connect (socket &rest address) (:documentation "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value.")) (defmethod socket-connect ((socket socket) &rest peer) - (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer))) - (if (= (sb-sys:with-pinned-objects (sockaddr) - (sockint::connect (socket-file-descriptor socket) - (sb-grovel::array-data-address sockaddr) - (size-of-sockaddr socket))) + (with-sockaddr-for (socket sockaddr peer) + (if (= (sockint::connect (socket-file-descriptor socket) + sockaddr + (size-of-sockaddr socket)) -1) - (socket-error "connect") ))) + (socket-error "connect")))) (defgeneric socket-peername (socket) (:documentation "Return the socket's peer; depending on the address family this may return multiple values")) (defmethod socket-peername ((socket socket)) - (let* ((sockaddr (make-sockaddr-for socket))) - (when (= (sb-sys:with-pinned-objects (sockaddr) - (sockint::getpeername (socket-file-descriptor socket) - (sb-grovel::array-data-address sockaddr) - (size-of-sockaddr socket))) + (with-sockaddr-for (socket sockaddr address) + (when (= (sockint::getpeername (socket-file-descriptor socket) + sockaddr + (size-of-sockaddr socket)) -1) (socket-error "getpeername")) (bits-of-sockaddr socket sockaddr))) @@ -123,11 +128,10 @@ values")) that the socket is bound to, as multiple values.")) (defmethod socket-name ((socket socket)) - (let* ((sockaddr (make-sockaddr-for socket))) - (when (= (sb-sys:with-pinned-objects (sockaddr) - (sockint::getsockname (socket-file-descriptor socket) - (sb-grovel::array-data-address sockaddr) - (size-of-sockaddr socket))) + (with-sockaddr-for (socket sockaddr nil) + (when (= (sockint::getsockname (socket-file-descriptor socket) + sockaddr + (size-of-sockaddr socket)) -1) (socket-error "getsockname")) (bits-of-sockaddr socket sockaddr))) @@ -152,34 +156,38 @@ so that the actual packet length is returned even if the buffer was too small")) (defmethod socket-receive ((socket socket) buffer length - &key - oob peek waitall - (element-type 'character)) - (let ((flags - (logior (if oob sockint::MSG-OOB 0) - (if peek sockint::MSG-PEEK 0) - (if waitall sockint::MSG-WAITALL 0) - sockint::MSG-NOSIGNAL ;don't send us SIGPIPE - (if (eql (socket-type socket) :datagram) - sockint::msg-TRUNC 0))) - (sockaddr (make-sockaddr-for socket))) - (unless (or buffer length) - (error "Must supply at least one of BUFFER or LENGTH")) - (unless buffer - (setf buffer (make-array length :element-type element-type))) - (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2))) - (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket)) - (sb-sys:with-pinned-objects (buffer sockaddr) - (let ((len - (sockint::recvfrom (socket-file-descriptor socket) - (sb-grovel::array-data-address buffer) - (or length (length buffer)) - flags - (sb-grovel::array-data-address sockaddr) - (sb-alien:cast sa-len (* integer))))) - (when (= len -1) (socket-error "recvfrom")) - (apply #'values buffer len (multiple-value-list - (bits-of-sockaddr socket sockaddr)))))))) + &key + oob peek waitall + (element-type 'character)) + (with-sockaddr-for (socket sockaddr nil) + (let ((flags + (logior (if oob sockint::MSG-OOB 0) + (if peek sockint::MSG-PEEK 0) + (if waitall sockint::MSG-WAITALL 0) + #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE + (if (eql (socket-type socket) :datagram) + sockint::msg-TRUNC 0)))) + (unless (or buffer length) + (error "Must supply at least one of BUFFER or LENGTH")) + (unless length + (setf length (length buffer))) + (let ((copy-buffer (sb-alien:make-alien (array sb-alien:unsigned 1) length))) + (unwind-protect + (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2))) + (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket)) + (let ((len + (sockint::recvfrom (socket-file-descriptor socket) + copy-buffer + length + flags + sockaddr + (sb-alien:cast sa-len (* integer))))) + (when (= len -1) (socket-error "recvfrom")) + (loop for i from 0 below len + do (setf (elt buffer i) (sb-alien:deref copy-buffer i))) + (apply #'values buffer len (multiple-value-list + (bits-of-sockaddr socket sockaddr))))) + (sb-alien:free-alien copy-buffer)))))) diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index e44aa84..04bf3bb 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -20,7 +20,7 @@ In terms of providing a useful interface, we have to face up to the fact that most of these take different data types - some are integers, some are booleans, some are foreign struct instances, etc etc -(define-socket-option lisp-name level number mangle-arg size mangle-return) + (define-socket-option lisp-name level number mangle-arg size mangle-return) macro-expands to two functions that define lisp-name and (setf ,lisp-name) and calls the functions mangle-arg and mangle-return on outgoing and incoming @@ -41,15 +41,15 @@ something that the caller will want. Code for options that not every system has should be conditionalised: -(if (boundp 'sockint::IP_RECVIF) - (define-socket-option so-receive-interface (getprotobyname "ip") - sockint::IP_RECVIF ... )) + (if (boundp 'sockint::IP_RECVIF) + (define-socket-option so-receive-interface (getprotobyname "ip") + sockint::IP_RECVIF ... )) |# (defmacro define-socket-option - (lisp-name level number mangle-arg size mangle-return) + (lisp-name level number buffer-type mangle-arg mangle-return mangle-setf-buffer) (let ((find-level (if (numberp (eval level)) level @@ -57,48 +57,36 @@ Code for options that not every system has should be conditionalised: `(progn (export ',lisp-name) (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket))) - (let ((buf (make-array sockint::size-of-int - :element-type '(unsigned-byte 8) - :initial-element 0))) - (sb-sys:with-pinned-objects (buf) - (if (= -1 (sockint::getsockopt - fd ,find-level ,number (sb-grovel::array-data-address buf) ,size)) - (socket-error "getsockopt") - (,mangle-return buf ,size))))) + (sb-alien:with-alien ((size sb-alien:integer) + (buffer ,buffer-type)) + (setf size (sb-alien:alien-size ,buffer-type :bytes)) + (if (= -1 (sockint::getsockopt fd ,find-level ,number + (sb-alien:addr buffer) + (sb-alien:addr size))) + (socket-error "getsockopt") + (,mangle-return buffer size)))) (defun (setf ,lisp-name) (new-val socket &aux (fd (socket-file-descriptor socket))) - (if (= -1 - (sb-sys:without-gcing - (sockint::setsockopt - fd ,find-level ,number (funcall (function ,mangle-arg) new-val ,size) - ,size))) - (socket-error "setsockopt")))))) + (sb-alien:with-alien ((buffer ,buffer-type)) + (setf buffer ,(if mangle-arg + `(,mangle-arg new-val) + `new-val)) + (when (= -1 (sockint::setsockopt fd ,find-level ,number + (,mangle-setf-buffer buffer) + ,(if (eql buffer-type 'sb-alien:c-string) + `(length new-val) + `(sb-alien:alien-size ,buffer-type :bytes)))) + (socket-error "setsockopt"))))))) ;;; sockopts that have integer arguments -(defun int-to-foreign (x size) - ;; can't use with-alien, as the variables it creates only have - ;; dynamic scope. can't use the passed-in size because sap-alien - ;; is a macro and evaluates its second arg at read time - (let* ((v (make-array size :element-type '(unsigned-byte 8) - :initial-element 0)) - (d (sb-grovel::array-data-address v)) - (alien (sb-alien:sap-alien - d; (sb-sys:int-sap d) - (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) - (setf (sb-alien:deref alien 0) x) - alien)) - -(defun buffer-to-int (x size) - (declare (ignore size)) - (let ((alien (sb-alien:sap-alien - (sb-grovel::array-data-address x) - (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) - (sb-alien:deref alien))) +(defun foreign-int-to-integer (buffer size) + (assert (= size (sb-alien:alien-size sb-alien:integer :bytes))) + buffer) (defmacro define-socket-option-int (name level number) `(define-socket-option ,name ,level ,number - int-to-foreign sockint::size-of-int buffer-to-int)) + sb-alien:integer nil foreign-int-to-integer sb-alien:addr)) (define-socket-option-int sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat) @@ -110,20 +98,22 @@ Code for options that not every system has should be conditionalised: sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf) (define-socket-option-int sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf) -(define-socket-option-int +#+linux(define-socket-option-int sockopt-priority sockint::sol-socket sockint::so-priority) ;;; boolean options are integers really -(defun bool-to-foreign (x size) - (int-to-foreign (if x 1 0) size)) +(defun foreign-int-to-bool (x size) + (if (zerop (foreign-int-to-integer x size)) + nil + t)) -(defun buffer-to-bool (x size) - (not (= (buffer-to-int x size) 0))) +(defun bool-to-foreign-int (val) + (if val 1 0)) (defmacro define-socket-option-bool (name level number) `(define-socket-option ,name ,level ,number - bool-to-foreign sockint::size-of-int buffer-to-bool)) + sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr)) (define-socket-option-bool sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr) @@ -131,9 +121,9 @@ Code for options that not every system has should be conditionalised: sockopt-keep-alive sockint::sol-socket sockint::so-keepalive) (define-socket-option-bool sockopt-oob-inline sockint::sol-socket sockint::so-oobinline) -(define-socket-option-bool +#+linux(define-socket-option-bool sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat) -(define-socket-option-bool +#+linux(define-socket-option-bool sockopt-pass-credentials sockint::sol-socket sockint::so-passcred) (define-socket-option-bool sockopt-debug sockint::sol-socket sockint::so-debug) @@ -144,19 +134,12 @@ Code for options that not every system has should be conditionalised: (define-socket-option-bool sockopt-tcp-nodelay :tcp sockint::tcp-nodelay) -(defun string-to-foreign (string size) - (declare (ignore size)) - (let ((data (sb-grovel::array-data-address string))) - (sb-alien:sap-alien data (* t)))) - -(defun buffer-to-string (x size) - (declare (ignore size)) - (sb-c-call::%naturalize-c-string - (sb-grovel::array-data-address x))) - -(define-socket-option sockopt-bind-to-device sockint::sol-socket - sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz - buffer-to-string) +(defun identity-1 (x &rest args) + (declare (ignore args)) + x) + +#+linux(define-socket-option sockopt-bind-to-device sockint::sol-socket + sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity) ;;; other kinds of socket option diff --git a/contrib/sb-grovel/README b/contrib/sb-grovel/README deleted file mode 100644 index 6d640d4..0000000 --- a/contrib/sb-grovel/README +++ /dev/null @@ -1,41 +0,0 @@ -Many of the structure offsets and symbolic constants necessary to do -FFI vary between architectures and operating systems. To avoid a -maintenance nightmare, we derive them automatically by creating and -running a small C program. The C program is created by -def-to-lisp.lisp with input from a GROVEL-CONSTANTS-FILE - -The ASDF component type GROVEL-CONSTANTS-FILE has its PERFORM -operation defined to write out a C source file, compile it, and run -it. The output from this program is Lisp, which is then itself -compiled. - -How to use it from your own system - -1) Create a Lisp package for the foreign constants/functions to go into. -It needs to use SB-GROVEL and SB-ALIEN - -2) Make your system depend on the "sb-grovel" system - -3) Create a grovel-constants data file - see example-constants.lisp in -this directory - -4) Add it as a component in your system. e.g. - -(defsystem sbcl-hemlock - :depends-on (sb-grovel) - :components - ((:module "sbcl" - :components - ((:file "defpackage") - (sb-grovel:grovel-constants-file "example-constants" - :package :sbcl-hemlock - ))))) - -Make sure to specify the package you chose in step 1 - -5) Build stuff - ---- - -Note that we assume that the C type char has 8 bits. - diff --git a/contrib/sb-grovel/array-data.lisp b/contrib/sb-grovel/array-data.lisp deleted file mode 100644 index ad5aa4a..0000000 --- a/contrib/sb-grovel/array-data.lisp +++ /dev/null @@ -1,72 +0,0 @@ -(in-package :sb-grovel) - -;;; borrowed from CMUCL manual, lightly ported - -(defun array-data-address (array) - "Return the physical address of where the actual data of an array is -stored. - -ARRAY must be a specialized array type - an array of one of these types: - - double-float - single-float - (unsigned-byte 32) - (unsigned-byte 16) - (unsigned-byte 8) - (signed-byte 32) - (signed-byte 16) - (signed-byte 8) -" - (declare (type (or (array (signed-byte 8)) - (array base-char) - simple-base-string - (array (signed-byte 16)) - (array (signed-byte 32)) - (array (unsigned-byte 8)) - (array (unsigned-byte 16)) - (array (unsigned-byte 32)) - (array single-float) - (array double-float)) - array) - (optimize (speed 0) (debug 3) (safety 3))) - ;; with-array-data will get us to the actual data. However, because - ;; the array could have been displaced, we need to know where the - ;; data starts. - - (let* ((type (car (multiple-value-list (array-element-type array)))) - (type-size - (cond ((or (equal type '(signed-byte 8)) - (equal type 'cl::base-char) - (equal type '(unsigned-byte 8))) - 1) - ((or (equal type '(signed-byte 16)) - (equal type '(unsigned-byte 16))) - 2) - ((or (equal type '(signed-byte 32)) - (equal type '(unsigned-byte 32))) - 4) - ((equal type 'single-float) - 4) - ((equal type 'double-float) - 8) - (t (error "Unknown specialized array element type"))))) - (sb-kernel::with-array-data ((data array) - (start) - (end)) - (declare (ignore end)) - ;; DATA is a specialized simple-array. Memory is laid out like this: - ;; - ;; byte offset Value - ;; 0 type code (e.g. 70 for double-float vector) - ;; 4 FIXNUMIZE(number of elements in vector) - ;; 8 1st element of vector - ;; ... ... - ;; - (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data))))) - (declare (type (unsigned-byte 32) addr) - (optimize (speed 3) (safety 0))) - (sb-sys:int-sap (the (unsigned-byte 32) - (+ addr (* type-size start)))))))) - - - diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index e1f54f0..265a0ce 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -1,77 +1,115 @@ -(in-package :SB-GROVEL) -(defvar *export-symbols* nil) +(in-package #:sb-grovel) -(defun c-for-structure (stream lisp-name c-struct) - (destructuring-bind (c-name &rest elements) c-struct - (format stream "printf(\"(sb-grovel::define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name) +(defvar *default-c-stream* nil) + +(defun escape-for-string (string) + (c-escape string)) + +(defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\)) + "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR." + (coerce (loop for c across string + if (member c dangerous-chars) collect escape-char + collect c) + 'string)) + +(defun as-c (&rest args) + "Pretty-print ARGS into the C source file, separated by #\Space" + (format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args))) + +(defun printf (formatter &rest args) + "Emit C code to printf the quoted code, via FORMAT. +The first argument is the C string that should be passed to +printf. + +The rest of the arguments are consumed by FORMAT clauses, until +there are no more FORMAT clauses to fill. If there are more +arguments, they are emitted as printf arguments. + +There is no error checking done, unless you pass too few FORMAT +clause args. I recommend using this formatting convention in +code: + + (printf \"string ~A ~S %d %d\" format-arg-1 format-arg-2 + printf-arg-1 printf-arg-2)" + (let ((*print-pretty* nil)) + (apply #'format *default-c-stream* + " printf (\"~@?\\n\"~@{, ~A~});~%" + (c-escape formatter) + args))) + +(defun c-for-structure (lispname cstruct) + (destructuring-bind (cname &rest elements) cstruct + (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname + (format nil "sizeof(~A)" cname)) (dolist (e elements) (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e - ;; FIXME: this format string doesn't actually guarantee - ;; non-multilined-string-constantness, it just makes it more - ;; likely. Sort out the required behaviour (and maybe make - ;; the generated C more readable, while we're at it...) -- - ;; CSR, 2003-05-27 - (format stream "printf(\"(sb-grovel::define-c-accessor ~A-~A\\n\\~% ~ - ~A ~A \");~%" - lisp-name lisp-el-name lisp-name lisp-type) - ;; offset - (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%" - c-name c-el-name) - ;; length + (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type) + ;; offset + (as-c "{" cname "t;") + (printf " %d" + (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name)) + (as-c "}") + ;; length (if distrust-length - (format stream "printf(\"|CL|:|NIL|\");") - (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%" - c-name c-el-name)) - (format stream "printf(\")\\n\");~%"))))) - -(defun c-for-function (stream lisp-name alien-defn) - (destructuring-bind (c-name &rest definition) alien-defn - (format stream "printf(\"(cl:declaim (cl:inline ~A))\\n\");~%" lisp-name) - (format stream - "printf(\"(sb-grovel::define-foreign-routine (\\\"~A\\\" ~A)\\n\\~%~ - ~{ ~W~^\\n\\~%~})\\n\");~%" - c-name lisp-name definition))) + (printf " 0)") + (progn + (as-c "{" cname "t;") + (printf " %d)" + (format nil "sizeof(t.~A)" c-el-name)) + (as-c "}"))))) + (printf "))"))) (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\")~%") + (declare (ignorable definitions package-name)) + (let ((*default-c-stream* stream) + (*print-right-margin* nil)) (loop for i in (cons "stdio.h" headers) do (format stream "#include <~A>~%" i)) - (format stream "main() { ~% -printf(\"(in-package ~S)\\\n\");~%" package-name) - (format stream "printf(\"(cl:deftype int () '(%ssigned-byte %d))\\\n\",SIGNED_(int),8*sizeof (int));~%") - (format stream "printf(\"(cl:deftype char () '(%ssigned-byte %d))\\\n\",SIGNED_(char),8*sizeof (char));~%") - (format stream "printf(\"(cl:deftype long () '(%ssigned-byte %d))\\\n\",SIGNED_(long),8*sizeof (long));~%") - (format stream "printf(\"(cl:defconstant size-of-int %d)\\\n\",sizeof (int));~%") - (format stream "printf(\"(cl:defconstant size-of-char %d)\\\n\",sizeof (char));~%") - (format stream "printf(\"(cl:defconstant size-of-long %d)\\\n\",sizeof (long));~%") + (as-c "#define SIGNEDP(x) (((x)-1)<0)") + (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")") + (as-c "int main() {") + (printf "(cl:in-package #:~A)" package-name) + (printf "(cl:eval-when (:compile-toplevel)") + (printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))") + (dolist (type '("char" "short" "long" "int" + #+nil"long long" ; TODO: doesn't exist in sb-alien yet + )) + (printf " (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type) + (format nil "sizeof(~A)" type))) + (printf ")") (dolist (def definitions) - (destructuring-bind (type lispname cname &optional doc) def - (cond ((eq type :integer) - (format stream - "#ifdef ~A~%~ - printf(\"(cl:defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%~ - #else~%~ - printf(\"(sb-int:style-warn \\\"Couln't grovel definition for ~A (unknown to the C compiler).\\\")\\n\");~%~ - #endif~%" - cname lispname doc cname 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(\"(cl:defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" - lispname doc cname)) - ((eq type :function) - (c-for-function stream lispname cname)) - ((eq type :structure) - (c-for-structure stream lispname cname)) - (t - (format stream - "printf(\";; Non hablo Espagnol, Monsieur~%"))))) - (format stream "exit(0);~%}~%"))) + (destructuring-bind (type lispname cname &optional doc dont-export) def + (case type + (:integer + (as-c "#ifdef" cname) + (printf "(cl:defconstant ~A %d \"~A\")" lispname doc + cname) + ;; XXX: do this? + (unless dont-export + (printf "(cl:export '~A)" lispname)) + (as-c "#else") + (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) + (as-c "#endif")) + (:type + (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname + (format nil "SIGNED_(~A)" cname) + (format nil "(8*sizeof(~A))" cname))) + (:string + (printf "(cl:defparameter ~A %s \"~A\"" lispname doc + cname)) + (:function + (printf "(cl:declaim (cl:inline ~A))" lispname) + (destructuring-bind (f-cname &rest definition) cname + (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname) + (printf "~{ ~W~^\\n~})" definition))) + (:structure + (c-for-structure lispname cname)) + (otherwise + ;; should we really not sprechen espagnol, monsieurs? + (error "Unknown grovel keyword encountered: ~A" type)) + ))) + (as-c "return 0;") + (as-c "}"))) (defun c-constants-extract (filename output-file package) (with-open-file (f output-file :direction :output :if-exists :supersede) @@ -114,4 +152,3 @@ printf(\"(in-package ~S)\\\n\");~%" package-name) (namestring tmp-a-dot-out) (namestring tmp-constants)) 0) (compile-file tmp-constants :output-file output-file)))) - diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index cf46538..3a08349 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -13,149 +13,374 @@ (&whole it (c-name lisp-name) return-type &rest args) (declare (ignorable c-name lisp-name return-type args)) `(define-alien-routine ,@(cdr it))) -#|| -(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) -(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2) -||# -;;; define-c-accessor makes us a setter and a getter for changing -;;; memory at the appropriate offset - -;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4) - -(defmacro define-c-accessor (el structure type offset length) - (declare (ignore structure)) - (let* ((ty (cond - ((eql type (intern "INTEGER")) - `(,type ,(* 8 length))) - ((and (consp type) (eql (car type) (intern "*"))) ; pointer - `(unsigned ,(* 8 length))) - ((eql type (intern "C-STRING")) ; c-string as array - `(base-char 8)) - ((and (consp type) (eql (car type) (intern "ARRAY"))) - (cadr type)) - ((let ((type (sb-alien-internals:unparse-alien-type - (sb-alien-internals:parse-alien-type type nil)))) - (cond - ((consp type) - (case (car type) - (signed `(integer ,(cadr type))) - (unsigned type))) - (t (error "foo"))))))) - (sap-ref-? (intern (format nil "~ASAP-REF-~A" - (if (member (car ty) '(INTEGER SIGNED)) - "SIGNED-" "") - (cadr ty)) - (find-package "SB-SYS")))) - (labels - ((template (before after) - `(let* ((addr - (the (unsigned-byte ,sb-vm:n-machine-word-bits) - (+ #.(ash 1 sb-vm:n-lowtag-bits) - (logandc1 #.(1- (ash 1 sb-vm:n-lowtag-bits)) - (sb-kernel:get-lisp-obj-address ptr))))) - (sap (sb-sys:int-sap - (the (unsigned-byte ,sb-vm:n-machine-word-bits) - (+ addr ,offset))))) - (,before (,sap-ref-? sap index) ,after)))) - `(progn - ;;(declaim (inline ,el (setf ,el))) - (defun ,el (ptr &optional (index 0)) - (declare (optimize (speed 3) (safety 0))) - (sb-sys:without-gcing - ,(if (eql type (intern "C-STRING")) - `(naturalize-bounded-c-string ptr ,offset ,length) - (template 'prog1 nil)))) - (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset) - (defun (setf ,el) (newval ptr &optional (index 0)) - (declare (optimize (speed 3) (safety 0))) - (sb-sys:without-gcing - ,(if (eql type (intern "C-STRING")) - `(set-bounded-c-string ptr ,offset ,length newval) - (template 'setf 'newval)))))))) - - -;;; make memory allocator for appropriately-sized block of memory, and -;;; a constant to tell us how big it was anyway -(defmacro define-c-struct (name size) - (labels ((p (x) (intern (concatenate 'string x (symbol-name name)) - (symbol-package name)))) + + + +;;; strctures + +#| C structs need: the with-... interface. +|# + +;;; global XXXs: +#| + XXX: :distrust-length t fields are dangerous. they should only be at + the end of the structure (they mess up offset/size calculations) +|# + +(defun reintern (symbol &optional (package *package*)) + (if (symbolp symbol) + (intern (symbol-name symbol) package) + symbol)) + +(defparameter alien-type-table (make-hash-table :test 'eql)) +(defparameter lisp-type-table (make-hash-table :test 'eql)) + +(macrolet ((define-alien-types ((type size) &rest defns) + `(progn + ,@(loop for defn in defns + collect (destructuring-bind (expected-type c-type lisp-type) defn + `(progn + (setf (gethash ',expected-type alien-type-table) + (lambda (,type ,size) + (declare (ignorable type size)) + ,c-type)) + (setf (gethash ',expected-type lisp-type-table) + (lambda (,type ,size) + (declare (ignorable type size)) + ,lisp-type)))))))) + (define-alien-types (type size) + (integer (or (gethash size (symbol-value (intern "*INTEGER-SIZES*"))) + `(integer ,(* 8 size))) + `(unsigned-byte ,(* 8 size))) + (unsigned `(unsigned ,(* 8 size)) + `(unsigned-byte ,(* 8 size))) + (signed `(signed ,(* 8 size)) + `(signed-byte ,(* 8 size))) + (c-string `(array char ,size) 'cl:simple-string) + (c-string-pointer 'c-string 'cl:simple-string) + ;; TODO: multi-dimensional arrays, if they are ever needed. + (array (destructuring-bind (array-tag elt-type &optional array-size) type + (declare (ignore array-tag)) + ;; XXX: use of EVAL. alien-size is a macro, + ;; unfortunately; and it will only accept unquoted type + ;; forms. + `(sb-alien:array ,elt-type ,(or array-size + (/ size (eval `(sb-alien:alien-size ,elt-type :bytes)))))) + `(vector t)))) + +(defun retrieve-type-for (type size table) + (multiple-value-bind (type-fn found) + (gethash (reintern (typecase type + (list (first type)) + (t type)) + (find-package '#:sb-grovel)) + table) + (values + (if found + (funcall (the function type-fn) type size) + type) + found))) + +(defun alien-type-for (type size) + (reintern (retrieve-type-for type size alien-type-table))) + +(defun lisp-type-for (type size) + (multiple-value-bind (val found) + (retrieve-type-for type size lisp-type-table) + (if found + val + t))) + + +(defun mk-padding (len offset) + (make-instance 'padding + :type `(array char ,len) + :offset offset + :size len + :name (gensym "PADDING"))) +(defun mk-struct (offset &rest children) + (make-instance 'struct :name (gensym "STRUCT") + :children (remove nil children) + :offset offset)) +(defun mk-union (offset &rest children) + (make-instance 'union :name (gensym "UNION") + :children (remove nil children) + :offset offset)) +(defun mk-val (name type h-type offset size) + (declare (ignore h-type)) + (make-instance 'value-slot :name name + :size size + :offset offset + :type type)) + +;;; struct tree classes + +(defclass slot () + ((offset :initarg :offset :reader offset) + (name :initarg :name :reader name))) + +(defclass structured-type (slot) + ((children :initarg :children :accessor children))) + +(defclass union (structured-type) + ()) + +(defclass struct (structured-type) + ()) + +(defclass value-slot (slot) + ((size :initarg :size :reader size) + (type :initarg :type :reader type))) + +(defclass padding (value-slot) + ()) + +(defmethod print-object ((o value-slot) s) + (print-unreadable-object (o s :type t) + (format s "~S ~A+~A=~A" (name o) (offset o) (size o) (slot-end o)))) + +(defmethod print-object ((o structured-type) s) + (print-unreadable-object (o s :type t) + (format s "~S ~A" (name o) (children o)))) + +(defmethod size ((slot structured-type)) + (let ((min-offset (offset slot))) + (if (null (children slot)) + 0 + (reduce #'max (mapcar (lambda (child) + (+ (- (offset child) min-offset) (size child))) + (children slot)) + :initial-value 0)))) + +(defgeneric slot-end (slot)) +(defmethod slot-end ((slot slot)) + (+ (offset slot) (size slot))) + +(defun overlap-p (elt1 elt2) + (unless (or (zerop (size elt1)) + (zerop (size elt2))) + (or + (and (<= (offset elt1) + (offset elt2)) + (< (offset elt2) + (slot-end elt1))) + (and (<= (offset elt2) + (offset elt1)) + (< (offset elt1) + (slot-end elt2)))))) + +(defgeneric find-overlaps (root new-element)) +(defmethod find-overlaps ((root structured-type) new-element) + (when (overlap-p root new-element) + (let ((overlapping-elts (loop for child in (children root) + for overlap = (find-overlaps child new-element) + when overlap + return overlap))) + (cons root overlapping-elts)))) + +(defmethod find-overlaps ((root value-slot) new-element) + (when (overlap-p root new-element) + (list root))) + +(defgeneric pad-to-offset-of (to-pad parent)) + (macrolet ((skel (end-form) + `(let* ((end ,end-form) + (len (abs (- (offset to-pad) end)))) + (cond + ((= end (offset to-pad)) ; we are at the right offset. + nil) + (t ; we have to pad between the + ; old slot's end and the new + ; slot's offset + (mk-padding len end)))))) + + (defmethod pad-to-offset-of (to-pad (parent struct)) + (skel (if (null (children parent)) + 0 + (+ (size parent) (offset parent))))) + (defmethod pad-to-offset-of (to-pad (parent union)) + (skel (if (null (children parent)) + (offset to-pad) + (offset parent))))) + +(defgeneric replace-by-union (in-st element new-element)) +(defmethod replace-by-union ((in-st struct) elt new-elt) + (setf (children in-st) (remove elt (children in-st))) + (let ((padding (pad-to-offset-of new-elt in-st))) + (setf (children in-st) + (nconc (children in-st) + (list (mk-union (offset elt) + elt + (if padding + (mk-struct (offset elt) + padding + new-elt) + new-elt))))))) + +(defmethod replace-by-union ((in-st union) elt new-elt) + (let ((padding (pad-to-offset-of new-elt in-st))) + (setf (children in-st) + (nconc (children in-st) + (list (if padding + (mk-struct (offset in-st) + padding + new-elt) + new-elt)))))) + +(defgeneric insert-element (root new-elt)) +(defmethod insert-element ((root struct) (new-elt slot)) + (let ((overlaps (find-overlaps root new-elt))) + (cond + (overlaps (let ((last-structure (first (last overlaps 2))) + (last-val (first (last overlaps)))) + (replace-by-union last-structure last-val new-elt) + root)) + (t + (let ((padding (pad-to-offset-of new-elt root))) + (setf (children root) + (nconc (children root) + (when padding (list padding)) + (list new-elt))))))) + root) + +(defun sane-slot (alien-var &rest slots) + "Emulates the SB-ALIEN:SLOT interface, with useful argument order for +deeply nested structures." + (labels ((rewriter (slots) + (if (null slots) + alien-var + `(sb-alien:slot ,(rewriter (rest slots)) + ',(first slots))))) + (rewriter slots))) + +(defgeneric accessor-modifier-for (element-type accessor-type)) + +(defun identity-1 (thing &rest ignored) + (declare (ignore ignored)) + thing) +(defun (setf identity-1) (new-thing place &rest ignored) + (declare (ignore ignored)) + (setf place new-thing)) + +(defmethod accessor-modifier-for (element-type (accessor-type (eql :getter))) + 'identity-1) +(defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) + (accessor-type (eql :getter))) + 'c-string->lisp-string) +(defmethod accessor-modifier-for (element-type (accessor-type (eql :setter))) + nil) +(defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) + (accessor-type (eql :setter))) + 'c-string->lisp-string) +(defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) + (accessor-type (eql :getter))) + 'c-string->lisp-string) + +(defun c-string->lisp-string (string &optional limit) + (declare (ignore limit)) + (cast string c-string)) + +(defun (setf c-string->lisp-string) (new-string alien &optional limit) + (declare (string new-string)) + (let* ((upper-bound (or limit (1+ (length new-string)))) + (last-elt (min (1- upper-bound) (length new-string)))) + (loop for i upfrom 0 below last-elt + for char across new-string + do (setf (deref alien i) (char-code char))) + (setf (deref alien last-elt) 0) + (subseq new-string 0 last-elt))) + +(defgeneric accessors-for (struct-name element path)) +(defmethod accessors-for (struct-name (root structured-type) path) + nil) + + +(defmethod accessors-for (struct-name (root value-slot) path) + (let ((rpath (reverse path)) + (accessor-name (format nil "~A-~A" + (symbol-name struct-name) + (symbol-name (name root))))) + (labels ((accessor (root rpath) + (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) + `((defun ,(intern accessor-name) (struct) + (declare (type (alien ,struct-name) struct) + (optimize (speed 3))) + (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) + :getter) + ,(accessor root rpath) ,(size root))) + (defun (setf ,(intern accessor-name)) (new-val struct) + (declare (type (alien ,struct-name) struct) + (type ,(lisp-type-for (type root) (size root)) new-val) + (optimize (speed 3))) + ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root) + (find-package :sb-grovel)) + :setter)) + (modified-accessor (if accessor-modifier + `(,accessor-modifier ,(accessor root rpath) ,(size root)) + (accessor root rpath)))) + + `(setf ,modified-accessor new-val))) + (defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name)) + ,(offset root)))))) + + + +(defmethod accessors-for (struct (root padding) path) + nil) + +(defgeneric generate-struct-definition (struct-name root path)) +(defmethod generate-struct-definition (struct-name (root structured-type) path) + (let ((naccessors (accessors-for struct-name root path)) + (nslots nil)) + (dolist (child (children root)) + (multiple-value-bind (slots accessors) + (generate-struct-definition struct-name child (cons root path)) + (setf nslots (nconc nslots slots)) + (setf naccessors (nconc naccessors accessors)))) + (values `((,(name root) (,(type-of root) ,(name root) ,@nslots))) + naccessors))) + +(defmethod generate-struct-definition (struct-name (root value-slot) path) + (values `((,(name root) ,(alien-type-for (type root) (size root)))) + (accessors-for struct-name root path))) + +(defmacro define-c-struct (name size &rest elements) + (multiple-value-bind (struct-elements accessors) + (let* ((root (make-instance 'struct :name name :children nil :offset 0))) + (loop for e in (sort elements #'< :key #'fourth) + do (insert-element root (apply 'mk-val e)) + finally (return root)) + (setf (children root) + (nconc (children root) + (list + (mk-padding (max 0 (- size + (size root))) + (size root))))) + (generate-struct-definition name root nil)) `(progn - (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0 - :element-type '(unsigned-byte 8))) - (defconstant ,(p "SIZE-OF-") ,size) - (deftype ,name () '(simple-array (unsigned-byte 8) (,size))) - (defun ,(p "FREE-" ) (p) (declare (ignore p))) - (defmacro ,(p "WITH-") (var (&rest field-values) &body body) + (eval-when (:compile-toplevel :load-toplevel :execute) + (sb-alien:define-alien-type ,@(first struct-elements))) + ,@accessors + (defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body) (labels ((field-name (x) (intern (concatenate 'string (symbol-name ',name) "-" (symbol-name x)) ,(symbol-package name)))) - (append `(let ((,var ,'(,(p "ALLOCATE-"))))) - (mapcar (lambda (pair) - `(setf (,(field-name (car pair)) ,var) ,(cadr pair))) - field-values) - body)))))) + `(let ((,var ,'(,(intern (format nil "ALLOCATE-~A" name))))) + (unwind-protect + (progn + (progn ,@(mapcar (lambda (pair) + `(setf (,(field-name (first pair)) ,var) ,(second pair))) + field-values)) + ,@body) + (funcall ',',(intern (format nil "FREE-~A" name)) ,var))))) + (defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size) + (defun ,(intern (format nil "ALLOCATE-~A" name)) () + (sb-alien:make-alien ,name)) + (defun ,(intern (format nil "FREE-~A" name)) (o) + (sb-alien:free-alien o))))) (defun foreign-nullp (c) "C is a pointer to 0?" - (= 0 (sb-sys:sap-int (sb-alien:alien-sap c)))) - -;;; this could be a lot faster if I cared enough to think about it -(defun foreign-vector (pointer size length) - "Compose a vector of the words found in foreign memory starting at -POINTER. Each word is SIZE bytes long; LENGTH gives the number of -elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO" - (assert (= size 1)) - (let ((ptr - (typecase pointer - (sb-sys:system-area-pointer - (sap-alien pointer (* (sb-alien:unsigned 8)))) - (t - (sb-alien:cast pointer (* (sb-alien:unsigned 8)))))) - (result (make-array length :element-type '(unsigned-byte 8)))) - (loop for i from 0 to (1- length) by size - do (setf (aref result i) (sb-alien:deref ptr i))) - result)) - -(defun naturalize-bounded-c-string (pointer offset &optional max-length) - "Return the 0-terminated string starting at (+ POINTER OFFSET) with -maximum length MAX-LENGTH, as a lisp object." - (let* ((ptr - (typecase pointer - (sb-sys:system-area-pointer - (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char))) - (t - (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char))))) - (length (loop for i upfrom 0 - until (or (and max-length - (= i (1- max-length))) - (= (sb-alien:deref ptr i) 0)) - finally (return i))) - (result (make-string length - :element-type 'base-char))) - (sb-kernel:copy-from-system-area (alien-sap ptr) 0 - result (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - (* length sb-vm:n-byte-bits)) - result)) - -(defun set-bounded-c-string (pointer offset max-length value) - "Set the range from POINTER + OFFSET to at most POINTER + OFFSET + -MAX-LENGTH to the string contained in VALUE." - (assert (numberp max-length) nil - "Structure field must have a grovelable maximum length.") - (assert (< (length value) max-length)) - (let* ((ptr - (typecase pointer - (sb-sys:system-area-pointer - (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char))) - (t - (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char))))) - (length (length value))) - (sb-kernel:copy-to-system-area value (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - (alien-sap ptr) 0 - (* length sb-vm:n-byte-bits)) - (setf (sb-alien:deref ptr length) 0) - value)) + (null-alien c)) \ No newline at end of file diff --git a/contrib/sb-grovel/sb-grovel.asd b/contrib/sb-grovel/sb-grovel.asd index b1ade29..e673135 100644 --- a/contrib/sb-grovel/sb-grovel.asd +++ b/contrib/sb-grovel/sb-grovel.asd @@ -9,8 +9,7 @@ #+sb-building-contrib "SYS:CONTRIB;SB-GROVEL;" :components ((:file "defpackage") (:file "def-to-lisp" :depends-on ("defpackage")) - (:file "foreign-glue" :depends-on ("defpackage")) - (:file "array-data" :depends-on ("defpackage")))) + (:file "foreign-glue" :depends-on ("defpackage")))) (defmethod perform :after ((o load-op) (c (eql (find-system :sb-grovel)))) (provide 'sb-grovel)) diff --git a/contrib/sb-grovel/sb-grovel.texinfo b/contrib/sb-grovel/sb-grovel.texinfo new file mode 100644 index 0000000..5e5f043 --- /dev/null +++ b/contrib/sb-grovel/sb-grovel.texinfo @@ -0,0 +1,244 @@ +@node sb-grovel +@section sb-grovel +@cindex Foreign Function Interface, generation + +The @code{sb-grovel} module helps in generation of foreign function +interfaces. It aids in extracting constants' values from the C +compiler and in generating SB-ALIEN structure and union types, +@pxref{Defining Foreign Types}. + +The ASDF(@uref{http://www.cliki.net/ASDF}) component type +GROVEL-CONSTANTS-FILE has its PERFORM +@c @xref for PERFORM when asdf manual is included? +operation defined to write out a C source file, compile it, and run +it. The output from this program is Lisp, which is then itself +compiled and loaded. + +sb-grovel is used in a few contributed modules, and it is currently +compatible only to SBCL. However, if you want to use it, here are a +few directions. + +@subsection Using sb-grovel in your own ASDF system + +@enumerate + +@item +Create a Lisp package for the foreign constants/functions to go into. + +@item +Make your system depend on the 'sb-grovel system. + +@item +Create a grovel-constants data file - for an example, see +example-constants.lisp in the contrib/sb-grovel/ directory in the SBCL +source distribution. + +@item +Add it as a component in your system. e.g. + +@lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sb-grovel)) + +(defpackage :example-package.system + (:use :cl :asdf :sb-grovel)) + +(in-package :example-package.system) + +(defsystem example-system + :depends-on (sb-grovel) + :components + ((:module "sbcl" + :components + ((:file "defpackage") + (grovel-constants-file "example-constants" + :package :example-package))))) +@end lisp + +Make sure to specify the package you chose in step 1 + +@item +Build stuff. + +@end enumerate + +@subsection Contents of a grovel-constants-file + +The grovel-constants-file, typically named @code{constants.lisp}, +comprises lisp expressions describing the foreign things that you want +to grovel for. A @code{constants.lisp} file contains two sections: + +@itemize +@item +a list of headers to include in the C program, for example: +@lisp +("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.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" "signal.h" ) +@end lisp + +@item +A list of sb-grovel clauses describing the things you want to grovel +from the C compiler, for example: +@lisp +((:integer af-local + #+(or sunos solaris) "AF_UNIX" + #-(or sunos solaris) "AF_LOCAL" + "Local to host (pipes and file-domain).") + (:structure stat ("struct stat" + (integer dev "dev_t" "st_dev") + (integer atime "time_t" "st_atime"))) + (:function getpid ("getpid" int ))) +@end lisp +@end itemize + +There are two types of things that sb-grovel can sensibly extract from +the C compiler: constant integers and structure layouts. It is also +possible to define foreign functions in the constants.lisp file, but +these definitions don't use any information from the C program; they +expand directly to @code{sb-alien:define-alien-routine} +(@pxref{The define-alien-routine Macro}) forms. + +Here's how to use the grovel clauses: + +@itemize +@item +@code{:integer} - constant expressions in C. Used in this form: +@lisp + (:integer lisp-variable-name "C expression") +@end lisp + +@code{"C expression"} will be typically be the name of a constant. But +other forms are possible. + +@item +@code{:structure} - alien structure definitions look like this: +@lisp + (:structure lisp-struct-name ("struct c_structure" + (type-designator lisp-element-name + "c_element_type" "c_element_name" + :distrust-length nil) + ; ... + )) +@end lisp + +@code{type-designator} is a reference to a type whose size (and type +constraints) will be groveled for. sb-grovel accepts a form of type +designator that doesn't quite conform to either lisp nor sb-alien's +type specifiers. Here's a list of type designators that sb-grovel +currently accepts: +@itemize +@item +@code{integer} - a C integral type; sb-grovel will infer the exact +type from size information extracted from the C program. All common C +integer types can be grovelled for with this type designator, but it +is not possible to grovel for bit fields yet. + +@item +@code{(unsigned n)} - an unsigned integer variable that is @code{n} +bytes long. No size information from the C program will be used. +@item +@code{(signed n)} - an signed integer variable that is @code{n} bytes +long. No size information from the C program will be used. + +@item +@code{c-string} - an array of @code{char} in the structure. sb-grovel +will use the array's length from the C program, unless you pass it the +@code{:distrust-length} keyword argument with non-@code{nil} value +(this might be required for structures such as solaris's @code{struct +dirent}). + +@item +@code{c-string-pointer} - a pointer to a C string, corresponding to +the @code{sb-alien:c-string} type (@pxref{Foreign Type Specifiers}). +@item +@code{(array alien-type)} - An array of the previously-declared alien +type. The array's size will be determined from the output of the C +program and the alien type's size. +@item +@code{(array alien-type n)} - An array of the previously-declared alien +type. The array's size will be assumed as being @code{n}. +@end itemize + + +Note that @code{c-string} and @code{c-string-pointer} do not have the +same meaning. If you declare that an element is of type +@code{c-string}, it will be treated as if the string is a part of the +structure, whereas if you declare that the element is of type +@code{c-string-pointer}, a @emph{pointer to a string} will be the +structure member. + +@item +@code{:function} - alien function definitions are similar to +@code{define-alien-routine} definitions, because they expand to such +forms when the lisp program is loaded. @xref{Foreign Function Calls} + +@lisp +(:function lisp-function-name ("alien_function_name" alien-return-type + (argument alien-type) + (argument2 alien-type))) +@end lisp +@end itemize + + +@subsection Programming with sb-grovel's structure types + +Let us assume that you have a grovelled structure definition: +@lisp + (:structure mystruct ("struct my_structure" + (integer myint "int" "st_int") + (c-string mystring "char[]" "st_str"))) +@end lisp + +What can you do with it? Here's a short interface document: + +@itemize +@item +Creating and destroying objects: +@itemize +@item +Function @code{(allocate-mystruct)} - allocates an object of type @code{mystruct}and +returns a system area pointer to it. +@item +Function @code{(free-mystruct var)} - frees the alien object pointed to by +@var{var}. +@item +Macro @code{(with-mystruct var ((member init) [...]) &body body)} - +allocates an object of type @code{mystruct} that is valid in +@var{body}. If @var{body} terminates or control unwinds out of +@var{body}, the object pointed to by @var{var} will be deallocated. +@end itemize + +@item +Accessing structure members: +@itemize +@item +@code{(mystruct-myint var)} and @code{(mystruct-mystring var)} return +the value of the respective fields in @code{mystruct}. +@item +@code{(setf (mystruct-myint var) new-val)} and +@code{(setf (mystruct-mystring var) new-val)} sets the value of the respective +structure member to the value of @var{new-val}. Notice that in +@code{(setf (mystruct-mystring var) new-val)}'s case, new-val is a lisp +string. +@end itemize +@end itemize + +@subsubsection Traps and Pitfalls +Basically, you can treat functions and data structure definitions that +sb-grovel spits out as if they were alien routines and types. This has +a few implications that might not be immediately obvious (especially +if you have programmed in a previous version of sb-grovel that didn't +use alien types): + +@itemize +@item +You must take care of grovel-allocated structures yourself. They are +alien types, so the garbage collector will not collect them when you +drop the last reference. + +@item +If you use the @code{with-mystruct} macro, be sure that no references +to the variable thus allocated leaks out. It will be deallocated when +the block exits. +@end itemize diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index eb69613..8acbd2d 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -241,7 +241,7 @@ (:c-string name "char *" "d_name" :distrust-length #+sunos t #-sunos nil))) - (:structure stat + (:structure alien-stat ("struct stat" (mode-t mode "mode_t" "st_mode") (ino-t ino "ino_t" "st_ino") @@ -297,16 +297,13 @@ (:type tcflag-t "tcflag_t") (:integer nccs "NCCS") - (:structure termios + (:structure alien-termios ("struct termios" (tcflag-t iflag "tcflag_t" "c_iflag") (tcflag-t oflag "tcflag_t" "c_oflag") (tcflag-t cflag "tcflag_t" "c_cflag") (tcflag-t lflag "tcflag_t" "c_lflag") - ;; Uh, so what's the point of grovelling CC-T if I can't - ;; use it here? the c_cc field is an array of NCCS - ;; elements of type cc_t. FIXME - ((array (unsigned 8)) cc "cc_t" "c_cc"))) + ((array cc-t) cc "cc_t" "c_cc"))) (:integer veof "VEOF") (:integer veol "VEOL") diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 7c83661..4d17eca 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -1,5 +1,26 @@ (cl:in-package :sb-posix-internal) +(defun make-alien-slot-name (alien-type slot-name) + (intern (format nil "~A-~A" alien-type slot-name) + (symbol-package slot-name))) + +(declaim (inline alien-to-protocol-class)) +(defun alien-to-protocol-class (alien alien-type instance protocol-class slots) + "Copy SLOTS from the alien object ALIEN of type ALIEN-TYPE to INSTANCE, an instance of PROTOCOL-CLASS. +We assume that SLOT names are the same in the alien object and in +the protocol-class." + (unless instance + (setf instance (make-instance protocol-class))) + (loop for slot in slots + do (setf (slot-value instance slot) + (sb-alien:slot alien slot))) + instance) + +(defun protocol-class-to-alien (instance protocol-class alien alien-type slots) + (loop for slot in slots + do (setf (sb-alien:slot alien slot) (slot-value instance slot))) + instance) + (define-condition sb-posix:syscall-error (error) ((errno :initarg :errno :reader sb-posix:syscall-errno)) (:report (lambda (c s) @@ -74,7 +95,7 @@ (fcntl-without-arg fd cmd))) (define-call "opendir" (* t) null-alien (pathname filename)) -(define-call "readdir" (* t) +(define-call "readdir" sb-posix::dirent ;; readdir() has the worst error convention in the world. It's just ;; too painful to support. (return is NULL _and_ errno "unchanged" ;; is not an error, it's EOF). @@ -141,6 +162,18 @@ (define-call "getpagesize" int minusp) +(defclass sb-posix::stat () + ((sb-posix::mode :initarg :mode :accessor sb-posix::stat-mode) + (sb-posix::ino :initarg :ino :accessor sb-posix::stat-ino) + (sb-posix::dev :initarg :dev :accessor sb-posix::stat-dev) + (sb-posix::nlink :initarg :nlink :accessor sb-posix::stat-nlink) + (sb-posix::uid :initarg :uid :accessor sb-posix::stat-uid) + (sb-posix::gid :initarg :gid :accessor sb-posix::stat-gid) + (sb-posix::size :initarg :size :accessor sb-posix::stat-size) + (sb-posix::atime :initarg :atime :accessor sb-posix::stat-atime) + (sb-posix::mtime :initarg :mtime :accessor sb-posix::stat-mtime) + (sb-posix::ctime :initarg :ctime :accessor sb-posix::stat-ctime))) + (defmacro define-stat-call (name arg designator-fun type) ;; FIXME: this isn't the documented way of doing this, surely? (let ((lisp-name (intern (string-upcase name) :sb-posix))) @@ -148,31 +181,27 @@ (export ',lisp-name :sb-posix) (declaim (inline ,lisp-name)) (defun ,lisp-name (,arg &optional stat) - (declare (type (or null sb-posix::stat) stat)) - (unless stat - (setq stat (sb-posix::allocate-stat))) - ;; FIXME: Hmm. WITH-PINNED-OBJECTS/WITHOUT-GCING or something - ;; is probably needed round here. - (let* ((s (sb-sys:int-sap - ;; FIXME: WILL NOT WORK ON 64-BIT LISP. VECTOR-SAP - ;; would be better if the STAT object were - ;; guaranteed to be a vector, but it's not (and may - ;; well turn into an alien soon). - (+ 8 (logandc2 (sb-kernel:get-lisp-obj-address stat) 7)))) - (r (alien-funcall - (extern-alien ,name ,type) - (,designator-fun ,arg) - s))) - (when (minusp r) - (syscall-error))) - stat)))) + (declare (type (or null (sb-alien:alien (* sb-posix::alien-stat))) stat)) + (sb-posix::with-alien-stat a-stat () + (let ((r (alien-funcall + (extern-alien ,name ,type) + (,designator-fun ,arg) + a-stat))) + (when (minusp r) + (syscall-error)) + (alien-to-protocol-class a-stat 'sb-posix::alien-stat + stat 'sb-posix::stat + '(sb-posix::mode sb-posix::ino sb-posix::dev + sb-posix::nlink sb-posix::uid sb-posix::gid + sb-posix::size sb-posix::atime + sb-posix::mtime sb-posix::ctime)))))))) + (define-stat-call "stat" pathname sb-posix::filename - ;; FIXME: (* T)? Ew. (* STAT) would be preferable - (function int c-string (* t))) + (function int c-string (* sb-posix::alien-stat))) (define-stat-call "lstat" pathname sb-posix::filename - (function int c-string (* t))) + (function int c-string (* sb-posix::alien-stat))) (define-stat-call "fstat" fd sb-posix::file-descriptor - (function int int (* t))) + (function int int (* sb-posix::alien-stat))) ;;; mode flags @@ -198,40 +227,50 @@ (syscall-error))) (values (aref filedes2 0) (aref filedes2 1))) +(defclass sb-posix::termios () + ((sb-posix::iflag :initarg :iflag :accessor sb-posix::termios-iflag) + (sb-posix::oflag :initarg :oflag :accessor sb-posix::termios-oflag) + (sb-posix::cflag :initarg :cflag :accessor sb-posix::termios-cflag) + (sb-posix::lflag :initarg :lflag :accessor sb-posix::termios-lflag) + (sb-posix::cc :initarg :cc :accessor sb-posix::termios-cc))) + (export 'sb-posix::tcsetattr :sb-posix) (declaim (inline sb-posix::tcsetattr)) (defun sb-posix::tcsetattr (fd actions termios) - (let ((fd (sb-posix::file-descriptor fd))) - (let* ((s (sb-sys:int-sap - ;; FIXME: WILL NOT WORK ON 64-BIT LISP. VECTOR-SAP would - ;; be better if the STAT object were guaranteed to be a - ;; vector, but it's not (and may well turn into an alien - ;; soon). - (+ 8 (logandc2 (sb-kernel:get-lisp-obj-address termios) 7)))) - (r (alien-funcall - ;; it's the old (* T) problem again :-( - (extern-alien "tcsetattr" (function int int int (* t))) - fd actions s))) - (when (minusp r) - (syscall-error))) - (values))) + (sb-posix::with-alien-termios a-termios () + (protocol-class-to-alien termios 'sb-posix::termios + a-termios 'sb-posix::alien-termios + '(sb-posix::iflag sb-posix::oflag + sb-posix::cflag sb-posix::lflag)) + (loop with ccs = (sb-posix::alien-termios-cc a-termios) + for i from 0 below sb-posix::nccs + do (setf (sb-alien:deref ccs i) + (aref (sb-posix::termios-cc termios) i))) + (let ((fd (sb-posix::file-descriptor fd))) + (let* ((r (alien-funcall + (extern-alien "tcsetattr" (function int int int sb-posix::alien-termios)) + fd actions termios))) + (when (minusp r) + (syscall-error))) + (values)))) (export 'sb-posix::tcgetattr :sb-posix) (declaim (inline sb-posix::tcgetattr)) (defun sb-posix::tcgetattr (fd &optional termios) - (unless termios - (setq termios (sb-posix::allocate-termios))) - ;; FIXME: Hmm. WITH-PINNED-OBJECTS/WITHOUT-GCING or something - ;; is probably needed round here. - (let* ((s (sb-sys:int-sap - ;; FIXME: WILL NOT WORK ON 64-BIT LISP. VECTOR-SAP would - ;; be better if the STAT object were guaranteed to be a - ;; vector, but it's not (and may well turn into an alien - ;; soon). - (+ 8 (logandc2 (sb-kernel:get-lisp-obj-address termios) 7)))) - (r (alien-funcall - (extern-alien "tcgetattr" (function int int (* t))) - (sb-posix::file-descriptor fd) - s))) - (when (minusp r) - (syscall-error))) + (sb-posix::with-alien-termios a-termios () + (let ((r (alien-funcall + (extern-alien "tcgetattr" (function int int sb-posix::alien-termios)) + (sb-posix::file-descriptor fd) + a-termios))) + (when (minusp r) + (syscall-error)) + (setf termios + (alien-to-protocol-class a-termios 'alien-termios + termios 'termios + '(sb-posix::iflag sb-posix::oflag + sb-posix::cflag sb-posix::lflag))) + (setf (sb-posix::termios-cc termios) (make-array sb-posix::nccs)) + (loop with ccs = (sb-posix::alien-termios-cc a-termios) + for i from 0 below sb-posix::nccs + do (setf (aref (sb-posix::termios-cc termios) i) + (sb-alien:deref ccs i))))) termios) diff --git a/doc/manual/Makefile b/doc/manual/Makefile index 6e1e201..bc5d3cb 100644 --- a/doc/manual/Makefile +++ b/doc/manual/Makefile @@ -14,7 +14,7 @@ HTMLDIR=$(basename $(ROOTFILE)) DOCSTRINGDIR="docstrings/" # List of contrib modules that docstring docs will be created for. # FIXME: should check test-passed and not load them. -MODULES=':sb-md5 :sb-rotate-byte' +MODULES=':sb-md5 :sb-rotate-byte :sb-grovel' # List of package names that docstring docs will be created for. PACKAGES=":COMMON-LISP :SB-ALIEN :SB-DEBUG :SB-EXT :SB-GRAY :SB-MOP :SB-PROFILE :SB-THREAD :SB-MD5 :SB-ROTATE-BYTE" diff --git a/version.lisp-expr b/version.lisp-expr index 08a23be..4463826 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.10.55" +"0.8.10.56" -- 1.7.10.4