Diff of /contrib/sb-grovel/foreign-glue.lisp [79cc56] .. [4898ef] Maximize Restore

  Switch to side-by-side view

--- 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))))))
-	     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 (gentemp "PADDING")))
+                 :type `(array char ,len)
+                 :offset offset
+                 :size len
+                 :name (gentemp "PADDING")))
 (defun mk-struct (offset &rest children)
   (make-instance 'struct :name (gentemp "STRUCT")
-		 :children (remove nil children)
-		 :offset offset))
+                 :children (remove nil children)
+                 :offset offset))
 (defun mk-union (offset &rest children)
   (make-instance 'union :name (gentemp "UNION")
-		 :children (remove nil children)
-		 :offset offset))
+                 :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,73 +184,73 @@
 
 (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))
@@ -265,12 +265,12 @@
 (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)))
+                                  (accessor-type (eql :setter)))
   'c-string->lisp-string)
 
 (defun c-string->lisp-string (string &optional limit)
@@ -280,10 +280,10 @@
 (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))))
+         (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)))
+          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)))
 
@@ -294,33 +294,33 @@
 
 (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))))))
+               (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))))))
+                         (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))))))
 
 
 
@@ -330,64 +330,64 @@
 (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
        (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))))
-	   `(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)))))
+         (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?"