r2246: *** empty log message ***

[uffi.git] / src / aggregates.cl

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

 ;;;; *************************************************************************
 ;;;; 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.10 2002/04/06 19:53:08 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)))
+)