[bknr-cvs] r2526 - branches/trunk-reorg/thirdparty/uffi-1.6.0/src

[hhubner at common-lisp.net]

Author: hhubner
Date: Mon Feb 18 03:38:51 2008
New Revision: 2526

Modified:
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
Log:
fix :pointer-self for unions

Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	(original)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	Mon Feb 18 03:38:51 2008
@@ -67,40 +67,48 @@
   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
   )
 
-(defun process-struct-fields (name fields &optional (variant nil))
+(defun process-aggregate-fields (name fields &key (variant nil) (aggregate-type :struct))
   (let (processed)
     (dolist (field fields)
       (let* ((field-name (car field))
 	     (type (cadr field))
 	     (def (append (list field-name)
-			  (if (eq type :pointer-self)
-			      #+(or cmu scl) `((* (alien:struct ,name)))
-			      #+sbcl `((* (sb-alien:struct ,name)))
-			      #+(or openmcl digitool) `((:* (:struct ,name)))
-			      #+lispworks `((:pointer ,name))
-			      #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
-			      `(,(convert-from-uffi-type type :struct))))))
+                          (if (eq type :pointer-self)
+                            (ecase aggregate-type
+                              (:struct 
+                               #+(or cmu scl) `((* (alien:struct ,name)))
+                               #+sbcl `((* (sb-alien:struct ,name)))
+                               #+(or openmcl digitool) `((:* (:struct ,name)))
+                               #+lispworks `((:pointer ,name))
+                               #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)))
+                              (:union
+                               #+(or cmu scl) `((* (alien:union ,name)))
+                               #+sbcl `((* (sb-alien:union ,name)))
+                               #+(or openmcl digitool) `((:* (:union ,name)))
+                               #+lispworks `((:pointer ,name))
+                               #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))))
+                            `(,(convert-from-uffi-type type aggregate-type))))))
 	(if variant
 	    (push (list def) processed)
-	  (push def processed))))
+            (push def processed))))
     (nreverse processed)))
 	
 	    
 (defmacro def-struct (name &rest fields)
   #+(or cmu scl)
-  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-aggregate-fields name fields)))
   #+sbcl
-  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
+  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-aggregate-fields name fields)))
   #+allegro
-  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+  `(ff:def-foreign-type ,name (:struct ,@(process-aggregate-fields name fields)))
   #+lispworks
-  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+  `(fli:define-c-struct ,name ,@(process-aggregate-fields name fields))
   #+digitool
-  `(ccl:defrecord ,name ,@(process-struct-fields name fields))
+  `(ccl:defrecord ,name ,@(process-aggregate-fields name fields))
   #+openmcl
   `(ccl::def-foreign-type
     nil 
-    (:struct ,name ,@(process-struct-fields name fields)))
+    (:struct ,name ,@(process-aggregate-fields name fields)))
   )
 
 
@@ -192,19 +200,26 @@
 
 (defmacro def-union (name &rest fields)
   #+allegro
-  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+  `(ff:def-foreign-type ,name (:union ,@(process-aggregate-fields name fields
+                                                                  :aggregate-type :union)))
   #+lispworks
-  `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+  `(fli:define-c-union ,name ,@(process-aggregate-fields name fields
+                                                         :aggregate-type :union))
   #+(or cmu scl)
-  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+  `(alien:def-alien-type ,name (alien:union ,name ,@(process-aggregate-fields name fields
+                                                                              :aggregate-type :union)))
   #+sbcl
-  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
+  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-aggregate-fields name fields
+                                                                                       :aggregate-type :union)))
   #+digitool
-  `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+  `(ccl:defrecord ,name (:variant ,@(process-aggregate-fields name fields
+                                                              :variant t
+                                                              :aggregate-type :union)))
   #+openmcl
   `(ccl::def-foreign-type nil 
-			  (:union ,name ,@(process-struct-fields name fields)))
-)
+    (:union ,name ,@(process-aggregate-fields name fields
+                                              :aggregate-type :union)))
+  )
 
 
 #-(or sbcl cmu)