r10100: move function so that deref-array macro is defined

[uffi.git] / src / aggregates.lisp

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index e22f22b53d875839651901c388da77c0df421e20..5fdc9081d430acc5e83ec570f01d3d99764d00f2 100644 (file)
--- a/src/aggregates.lisp
+++ b/src/aggregates.lisp
@@ -2,12 +2,12 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          aggregates.cl
+;;;; Name:          aggregates.lisp
 ;;;; Purpose:       UFFI source to handle aggregate types
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: aggregates.lisp,v 1.5 2002/11/23 19:07:11 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -16,8 +16,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
+(in-package #:uffi)
 
 (defmacro def-enum (enum-name args &key (separator-string "#"))
   "Creates a constants for a C type enum list, symbols are created
@@ -81,7 +80,8 @@ of the enum-name name, separator-string, and field-name"
                              #+(or cmu scl) `((* (alien:struct ,name)))
                              #+sbcl `((* (sb-alien:struct ,name)))
                              #+mcl `((:* (:struct ,name)))
-                             #-(or cmu sbcl scl mcl) `((* ,name))
+                             #+lispworks `((:pointer ,name))
+                             #-(or cmu sbcl scl mcl lispworks) `((* ,name))
                              `(,(convert-from-uffi-type type :struct))))))
        (if variant
            (push (list def) processed)
@@ -118,7 +118,8 @@ of the enum-name name, separator-string, and field-name"
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
   #+mcl
-  `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
+  `(ccl:pref ,obj ,(intern (concatenate 'string (symbol-name type) "." (symbol-name slot))
+                         :keyword))
   )
 
 #+mcl
@@ -161,20 +162,29 @@ of the enum-name name, separator-string, and field-name"
   "Returns a field from a row"
   #+(or lispworks cmu sbcl scl) (declare (ignore type))
   #+(or cmu scl)  `(alien:deref ,obj ,i)
-  #+sbcl  `(sb-alien:deref ,obj ,i)
-  #+lispworks `(fli:dereference ,obj :index ,i)
-  #+allegro `(ff:fslot-value-typed (quote (convert-from-uffi-type ,type :type)) :c ,obj ,i)
-  #+mcl
+  #+sbcl `(sb-alien:deref ,obj ,i)
+  #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
+  #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+  #+openmcl
   (let* ((array-type (array-type type))
          (local-type (convert-from-uffi-type array-type :allocation))
-         (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
-    `(,accessor 
+        (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+    (ccl::%foreign-access-form
+     obj
+     (ccl::%foreign-type-or-record local-type)
+     `(* ,i ,element-size-in-bits)
+     nil))
+  #+(and mcl (not openmcl))
+  (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
-#+mcl
+#+(and mcl (not openmcl))
 (defmacro deref-array-set (obj type i value)
   (let* ((array-type (array-type type))
          (local-type (convert-from-uffi-type array-type :allocation))
@@ -185,7 +195,7 @@ of the enum-name name, separator-string, and field-name"
       (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 
       ,value)))
 
-#+mcl
+#+(and mcl (not openmcl))
 (defsetf deref-array deref-array-set)
 
 (defmacro def-union (name &rest fields)
@@ -203,3 +213,37 @@ of the enum-name name, separator-string, and field-name"
   `(ccl::def-foreign-type nil 
                          (:union ,name ,@(process-struct-fields name fields)))
 )
+
+
+#-(or sbcl cmu)
+(defun convert-from-foreign-usb8 (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+          (fixnum len))
+  (let ((a (make-array len :element-type '(unsigned-byte 8))))
+    (dotimes (i len a)
+      (declare (fixnum i))
+      (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
+
+#+sbcl
+(defun convert-from-foreign-usb8 (s len)
+  (declare (type sb-sys:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((result (make-array len :element-type '(unsiged-byte 8))))
+      (sb-kernel:copy-from-system-area s 0
+                                      result (* sb-vm:vector-data-offset
+                                                sb-vm:n-word-bits)
+                                      (* len sb-vm:n-byte-bits))
+      result)))
+
+#+cmu
+(defun convert-from-foreign-usb8 (s le)
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((result (make-array len :element-type '(unsiged-byte 8))))
+      (kernel:copy-from-system-area s 0
+                                   result (* vm:vector-data-offset
+                                             vm:word-bits)
+                                   (* len vm:byte-bits))
+      result)))