r2784: *** empty log message ***

[uffi.git] / src-mcl / aggregates.cl

diff --git a/src-mcl/aggregates.cl b/src-mcl/aggregates.cl
index eb4be75059bdccf7a50c14373d4173914d4a3fb0..b59615a31c17e370eb1ffd6617426d97d9359e86 100644 (file)
--- a/src-mcl/aggregates.cl
+++ b/src-mcl/aggregates.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: aggregates.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
+;;;; $Id: aggregates.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and John DeSoi
@@ -48,7 +48,8 @@ of the enum-name name, separator-string, and field-name"
                       #+allegro `((ff:def-foreign-type ,enum-name :int))
                       #+lispworks `((fli:define-c-typedef ,enum-name :int))
                       #+cmu `((alien:def-alien-type ,enum-name alien:signed))
-                       #+mcl `((def-mcl-type ,enum-name :integer))
+                       #-openmcl `((def-mcl-type ,enum-name :integer))
+                       #+openmcl `((ccl::def-foreign-type ,enum-name :int))
                       (nreverse constants)))
     cmds))
 
@@ -58,13 +59,37 @@ of the enum-name name, separator-string, and field-name"
   `(def-mcl-type ,name-array '(:array ,type)))
 
 
-; this is how rref expands array slot access (minus adding the struct offset)
+
+; so we could allow '(:array :long) or deref with other type like :long only
+(defun array-type (type)
+  (let ((result type))
+    (when (listp type)
+      (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+        (when (and (listp type-list) (eq (car type-list) :array))
+          (setf result (cadr type-list)))))
+    result))
+
+
 (defmacro deref-array (obj type i)
   "Returns a field from a row"
-  `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
+  (let* ((array-type (array-type type))
+         (local-type (convert-from-uffi-type array-type :allocation))
+         (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+    `(,accessor 
+      ,obj
+      (* (the fixnum ,i) ,(size-of-foreign-type local-type)))))
+
 
+; this expands to the %set-xx functions which has different params than %put-xx
 (defmacro deref-array-set (obj type i value)
-    `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
+  (let* ((array-type (array-type type))
+         (local-type (convert-from-uffi-type array-type :allocation))
+         (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
+         (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
+    `(,settor 
+      ,obj
+      (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 
+      ,value)))
 
 (defsetf deref-array deref-array-set)
 
@@ -84,23 +109,45 @@ of the enum-name name, separator-string, and field-name"
           (push def processed))))
     (nreverse processed)))
        
-           
+#-openmcl
 (defmacro def-struct (name &rest fields)
   `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
 
-
+#-openmcl
 (defmacro def-union (name &rest fields)
   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
 
 
+#+openmcl
+(defmacro def-struct (name &rest fields)
+  `(ccl::def-foreign-type nil 
+     (:struct ,name ,@(process-struct-fields name fields nil))))
+
+#+openmcl
+(defmacro def-union (name &rest fields)
+  `(ccl::def-foreign-type nil 
+     (:union ,name ,@(process-struct-fields name fields nil))))
+
 ; Assuming everything is pointer based - no support for Mac handles
 (defmacro get-slot-value (obj type slot) ;use setf to set values
-   `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
+   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))))
+
+(defmacro set-slot-value (obj type slot value) ;use setf to set values
+   `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
+
 
+(defsetf get-slot-value set-slot-value)
 
+
+#-openmcl
 (defmacro get-slot-pointer (obj type slot)
   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
 
+#+openmcl
+(defmacro get-slot-pointer (obj type slot)
+  `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
+     (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))))
+
 
 
 #| a few simple tests