X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fforeign-glue.lisp;h=457e45357171df5060aa6c70d4af9a7a537e19a2;hb=ecae2f9323086c64d026d4ce719590907f486c63;hp=3a083492d67f80d4bacc69d3cb1eb06620dbbde4;hpb=d4c7ab04ed10729a2cfa3321f4382d8a218ad958;p=sbcl.git

diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp
index 3a08349..457e453 100644
--- a/contrib/sb-grovel/foreign-glue.lisp
+++ b/contrib/sb-grovel/foreign-glue.lisp
@@ -65,8 +65,8 @@
 	       ;; 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))))
+					       (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
+	     t)))
 
 (defun retrieve-type-for (type size table)
   (multiple-value-bind (type-fn found)
@@ -97,13 +97,13 @@
 		 :type `(array char ,len)
 		 :offset offset
 		 :size len
-		 :name (gensym "PADDING")))
+		 :name (gentemp "PADDING")))
 (defun mk-struct (offset &rest children)
-  (make-instance 'struct :name (gensym "STRUCT")
+  (make-instance 'struct :name (gentemp "STRUCT")
 		 :children (remove nil children)
 		 :offset offset))
 (defun mk-union (offset &rest children)
-  (make-instance 'union :name (gensym "UNION")
+  (make-instance 'union :name (gentemp "UNION")
 		 :children (remove nil children)
 		 :offset offset))
 (defun mk-val (name type h-type offset size)
@@ -255,7 +255,7 @@ deeply nested structures."
 
 (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)
@@ -272,9 +272,6 @@ deeply nested structures."
 (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))
@@ -302,15 +299,17 @@ deeply nested structures."
 			       (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)
+      `((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 (type (alien ,struct-name) struct)
-		   (type ,(lisp-type-for (type root) (size root)) new-val)
+	  (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))
@@ -358,29 +357,38 @@ deeply nested structures."
 				  (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))))
+	   `(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))
+	 (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)))))
 
 (defun foreign-nullp (c)
   "C is a pointer to 0?"
-  (null-alien c))
\ No newline at end of file
+  (null-alien c))