X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fforeign-glue.lisp;h=a35d72c15e2dc24d4b70e49b1b86d2ae2b29dab3;hb=212e8d1c7938bbbd8d4c84b77c6a8f58abd04207;hp=e07bb59c05436c5d54ad7561ba4f81838f424549;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index e07bb59..a35d72c 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -36,49 +36,49 @@ (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)))))))) + `(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))) + `(integer ,(* 8 size))) + `(unsigned-byte ,(* 8 size))) (unsigned `(unsigned ,(* 8 size)) - `(unsigned-byte ,(* 8 size))) + `(unsigned-byte ,(* 8 size))) (signed `(signed ,(* 8 size)) - `(signed-byte ,(* 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)))) + (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)))))) + 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) + (list (first type)) + (t type)) + (find-package '#:sb-grovel)) + table) (values (if found - (funcall (the function type-fn) type size) - type) + (funcall (the function type-fn) type size) + type) found))) (defun alien-type-for (type size) @@ -88,30 +88,30 @@ (multiple-value-bind (val found) (retrieve-type-for type size lisp-type-table) (if found - val - t))) + val + t))) (defun mk-padding (len offset) (make-instance 'padding - :type `(array char ,len) - :offset offset - :size len - :name (gensym "PADDING"))) + :type `(array char ,len) + :offset offset + :size len + :name (gentemp "PADDING"))) (defun mk-struct (offset &rest children) - (make-instance 'struct :name (gensym "STRUCT") - :children (remove nil children) - :offset offset)) + (make-instance 'struct :name (gentemp "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)) + (make-instance 'union :name (gentemp "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)) + :size size + :offset offset + :type type)) ;;; struct tree classes @@ -146,11 +146,11 @@ (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)))) + 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)) @@ -158,24 +158,24 @@ (defun overlap-p (elt1 elt2) (unless (or (zerop (size elt1)) - (zerop (size elt2))) + (zerop (size elt2))) (or (and (<= (offset elt1) - (offset elt2)) - (< (offset elt2) - (slot-end elt1))) + (offset elt2)) + (< (offset elt2) + (slot-end elt1))) (and (<= (offset elt2) - (offset elt1)) - (< (offset elt1) - (slot-end 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))) + for overlap = (find-overlaps child new-element) + when overlap + return overlap))) (cons root overlapping-elts)))) (defmethod find-overlaps ((root value-slot) new-element) @@ -184,78 +184,78 @@ (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)))))) - + `(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))))) + 0 + (+ (size parent) (offset parent))))) (defmethod pad-to-offset-of (to-pad (parent union)) (skel (if (null (children parent)) - (offset to-pad) - (offset 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))))))) + (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)))))) + (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)) + (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))))))) + (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))))) + (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) +(defmacro identity-1 (thing &rest ignored) (declare (ignore ignored)) thing) (defun (setf identity-1) (new-thing place &rest ignored) @@ -265,15 +265,12 @@ deeply nested structures." (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))) + (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))) + (accessor-type (eql :setter))) 'c-string->lisp-string) (defun c-string->lisp-string (string &optional limit) @@ -283,11 +280,14 @@ deeply nested structures." (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) + (last-elt (min (1- upper-bound) (length new-string))) + (octets (sb-ext:string-to-octets new-string :end last-elt + :null-terminate t)) + (alien-pointer (cast alien (* unsigned-char)))) + (declare (cl:type (simple-array (unsigned-byte 8) (*)) octets)) + (declare (cl:type sb-int:index last-elt)) + (loop for i from 0 to last-elt + do (setf (deref alien-pointer i) (aref octets i))) (subseq new-string 0 last-elt))) (defgeneric accessors-for (struct-name element path)) @@ -297,31 +297,33 @@ deeply nested structures." (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))))) + (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 (cl: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 (cl:type (alien ,struct-name) struct) - (cl: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)))))) + (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) + `((declaim (inline ,(intern accessor-name) + (setf ,(intern accessor-name)))) + (defun ,(intern accessor-name) (struct) + (declare (cl: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 (cl:type (alien (* ,struct-name)) struct) + (cl: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)))))) @@ -331,66 +333,65 @@ deeply nested structures." (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)) + (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)))) + (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))) + 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))) + (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)) + (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 - (eval-when (:compile-toplevel :load-toplevel :execute) - (sb-alien:define-alien-type ,@(first struct-elements))) + (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)))) - `(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))))) + (labels ((field-name (x) + (intern (concatenate 'string + (symbol-name ',name) "-" + (symbol-name x)) + ,(symbol-package name)))) + `(sb-alien:with-alien ((,var (* ,',name) ,'(,(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)) () - (let* ((o (sb-alien:make-alien ,name)) - (c-o (cast o (* (unsigned 8))))) - ;; we have to initialize the object to all-0 before we can - ;; expect to make sensible use of it - the object returned - ;; by make-alien is initialized to all-D0 bytes. - - ;; FIXME: This should be fixed in sb-alien, where better - ;; optimizations might be possible. - (loop for i from 0 below ,size - do (setf (deref c-o i) 0)) - o)) + (let* ((o (sb-alien:make-alien ,name)) + (c-o (cast o (* (unsigned 8))))) + ;; we have to initialize the object to all-0 before we can + ;; expect to make sensible use of it - the object returned + ;; by make-alien is initialized to all-D0 bytes. + + ;; FIXME: This should be fixed in sb-alien, where better + ;; optimizations might be possible. + (loop for i from 0 below ,size + do (setf (deref c-o i) 0)) + o)) (defun ,(intern (format nil "FREE-~A" name)) (o) - (sb-alien:free-alien o))))) + (sb-alien:free-alien o))))) (defun foreign-nullp (c) "C is a pointer to 0?" - (null-alien c)) \ No newline at end of file + (null-alien c))