r1709: *** empty log message ***

[uffi.git] / src / aggregates.cl

diff --git a/src/aggregates.cl b/src/aggregates.cl
index 931aae79450cc54b5680c9348cef30e5508c0956..3fc32a34f093a2096ae06ce2779f5b4c778e42a6 100644 (file)
--- a/src/aggregates.cl
+++ b/src/aggregates.cl
@@ -1,4 +1,4 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: ANSI-Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;


@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; $Id: aggregates.cl,v 1.4 2002/03/14 21:03:12 kevin Exp $
+;;;; $Id: aggregates.cl,v 1.8 2002/03/23 12:58:12 kevin Exp $

 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -26,6 +26,7 @@ of the enum-name name, separator-string, and field-name"
   (let ((counter 0)
        (cmds nil)
        (constants nil))
   (let ((counter 0)
        (cmds nil)
        (constants nil))

+    (declare (fixnum counter))

     (dolist (arg args)
       (let ((name (if (listp arg) (car arg) arg))
            (value (if (listp arg) 
     (dolist (arg args)
       (let ((name (if (listp arg) (car arg) arg))
            (value (if (listp arg) 


@@ -48,23 +49,23 @@ of the enum-name name, separator-string, and field-name"
     cmds))
 
 
     cmds))
 
 

-(defmacro def-array (name-array type)
+(defmacro def-array-pointer (name-array type)

   #+allegro
   `(ff:def-foreign-type ,name-array 
   #+allegro
   `(ff:def-foreign-type ,name-array 

-       (:array ,(convert-from-uffi-type type :array)))
+    (:array ,(convert-from-uffi-type type :array)))

   #+lispworks
   `(fli:define-c-typedef ,name-array
   #+lispworks
   `(fli:define-c-typedef ,name-array

-       (:pointer (:pointer ,(convert-from-uffi-type type :array))))
+    (:c-array ,(convert-from-uffi-type type :array)))

   #+cmu
   `(alien:def-alien-type ,name-array 
   #+cmu
   `(alien:def-alien-type ,name-array 

-       (* ,(convert-from-uffi-type type :array)))
+    (* ,(convert-from-uffi-type type :array)))

   )
 
   )
 

-(defun process-struct-args (name args)
+(defun process-struct-fields (name fields)

   (let (processed)
   (let (processed)

-    (dolist (arg args)
-      (let ((field-name (car arg))
-           (type (cadr arg)))
+    (dolist (field fields)
+      (let ((field-name (car field))
+           (type (cadr field)))

        (push (append (list field-name)
                    (if (eq type :pointer-self)
                        #+cmu `((* (alien:struct ,name)))
        (push (append (list field-name)
                    (if (eq type :pointer-self)
                        #+cmu `((* (alien:struct ,name)))


@@ -74,13 +75,13 @@ of the enum-name name, separator-string, and field-name"
     (nreverse processed)))
        
            
     (nreverse processed)))
        
            

-(defmacro def-struct (name &rest args)
+(defmacro def-struct (name &rest fields)

   #+cmu
   #+cmu

-  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args)))
+  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))

   #+allegro
   #+allegro

-  `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args)))
+  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))

   #+lispworks
   #+lispworks

-  `(fli:define-c-struct ,name ,@(process-struct-args name args))
+  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))

   )
 
 
   )
 
 


@@ -112,7 +113,13 @@ of the enum-name name, separator-string, and field-name"
   #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i)
   )
 
   #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i)
   )
 

-
-
+(defmacro def-union (name &rest fields)
+  #+allegro
+  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+  #+lispworks
+  `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+  #+cmu
+  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+)