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)