r1712: *** empty log message ***

[uffi.git] / src / aggregates.cl

diff --git a/src/aggregates.cl b/src/aggregates.cl
index bf163c892a254c4d76a8b20ba20488814cfd7685..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,24 +7,13 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; Copyright (c) 2002 Kevin M. Rosenberg
+;;;; $Id: aggregates.cl,v 1.8 2002/03/23 12:58:12 kevin Exp $

 ;;;;
 ;;;;

-;;;; $Id: aggregates.cl,v 1.2 2002/03/10 11:13:07 kevin Exp $
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg

 ;;;;
 ;;;;

-;;;; This file is part of the UFFI. 
-;;;;
-;;;; UFFI is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License (version 2) as
-;;;; published by the Free Software Foundation.
-;;;;
-;;;; UFFI is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with UFFI; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

 ;;;; *************************************************************************
 
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 ;;;; *************************************************************************
 
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))


@@ -37,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) 


@@ -59,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)))


@@ -85,17 +75,17 @@ 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))

   )
 
 
   )
 
 

-(defmacro get-slot-value (obj slot type)
+(defmacro get-slot-value (obj type slot)

   #+(or lispworks cmu) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+(or lispworks cmu) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)


@@ -105,7 +95,7 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   )
 
   `(alien:slot ,obj ,slot)
   )
 

-(defmacro get-slot-pointer (obj slot type)
+(defmacro get-slot-pointer (obj type slot)

   #+(or lispworks cmu) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)
   #+(or lispworks cmu) (declare (ignore type))
   #+allegro
   `(ff:fslot-value-typed ,type :c ,obj ,slot)


@@ -115,7 +105,7 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   )
 
   `(alien:slot ,obj ,slot)
   )
 

-(defmacro deref-array (obj i type)
+(defmacro deref-array (obj type i)

   "Returns a field from a row"
   #+(or lispworks cmu) (declare (ignore type))
   #+cmu  `(alien:deref ,obj ,i)
   "Returns a field from a row"
   #+(or lispworks cmu) (declare (ignore type))
   #+cmu  `(alien:deref ,obj ,i)


@@ -123,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)))
+)