r1608: Reworked LW cstring to use built-in LW conversion

[uffi.git] / src / aggregates.cl

diff --git a/src/aggregates.cl b/src/aggregates.cl
index b0438d9a4c501e9756b3113ae71e2d7ce1f50479..06dca81fe691b5fde374bc25abecf846db839c5e 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.7 2002/03/21 07:56:45 kevin Exp $

 ;;;;
 ;;;;

-;;;; $Id: aggregates.cl,v 1.1 2002/03/09 19:55:33 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) 


@@ -62,7 +52,7 @@ of the enum-name name, separator-string, and field-name"
 (defmacro def-array (name-array type)
   #+allegro
   `(ff:def-foreign-type ,name-array 
 (defmacro def-array (name-array type)
   #+allegro
   `(ff:def-foreign-type ,name-array 

-       (:struct (:my-field (:array ,(convert-from-uffi-type type :array)))))
+       (:array ,(convert-from-uffi-type type :array)))

   #+lispworks
   `(fli:define-c-typedef ,name-array
        (:pointer (:pointer ,(convert-from-uffi-type type :array))))
   #+lispworks
   `(fli:define-c-typedef ,name-array
        (:pointer (:pointer ,(convert-from-uffi-type type :array))))


@@ -71,11 +61,11 @@ of the enum-name name, separator-string, and field-name"
        (* ,(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,15 +105,21 @@ 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)
   #+lispworks `(fli:dereference ,obj :index ,i)
   "Returns a field from a row"
   #+(or lispworks cmu) (declare (ignore type))
   #+cmu  `(alien:deref ,obj ,i)
   #+lispworks `(fli:dereference ,obj :index ,i)

-  #+allegro `(ff:fslot-value-typed ,type :c ,obj ':my-field ,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)))
+)