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.
(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")
(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
(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)))
(level integer)
(optname integer)
(optval (* t))
- (optlen integer :in-out))))
+ (optlen (* integer)))))
)
(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
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"
(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)))
"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)))
(defun get-name-service-error-message (num)
(hstrerror num))
)
-
(: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.
(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"))))
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)))
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)))
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))))))
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
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
`(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)
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)
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)
(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
+++ /dev/null
-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.
-
+++ /dev/null
-(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))))))))
-
-
-
-(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)
(namestring tmp-a-dot-out)
(namestring tmp-constants)) 0)
(compile-file tmp-constants :output-file output-file))))
-
(&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
#+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))
--- /dev/null
+@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
(: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")
(: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")
(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)
(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).
(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)))
(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
(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)
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"
;;; 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"
projects / sbcl.git / commitdiff