r10917: 2006-04-17 Kevin Rosenberg (kevin@rosenberg.net)

[uffi.git] / src / aggregates.lisp

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index c6624074dd2a07baeaa46bbad95da468bd32ef89..e660b0b17b4c09c6daefa19feeef4016601e6783 100644 (file)
--- a/src/aggregates.lisp
+++ b/src/aggregates.lisp
@@ -9,11 +9,8 @@
 ;;;;
 ;;;; $Id$
 ;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
 ;;;;
-;;;; 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.
 ;;;; *************************************************************************
 
 (in-package #:uffi)
@@ -45,7 +42,7 @@ of the enum-name name, separator-string, and field-name"
                       #+lispworks `((fli:define-c-typedef ,enum-name :int))
                       #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
                       #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
-                       #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
+                       #+digitool `((def-mcl-type ,enum-name :integer))
                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
                       (nreverse constants)))
     cmds))
@@ -64,7 +61,7 @@ of the enum-name name, separator-string, and field-name"
   #+sbcl
   `(sb-alien:define-alien-type ,name-array 
     (* ,(convert-from-uffi-type type :array)))
-  #+(and mcl (not openmcl))
+  #+digitool
   `(def-mcl-type ,name-array '(:array ,type))
   #+openmcl
   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
@@ -79,9 +76,9 @@ of the enum-name name, separator-string, and field-name"
                          (if (eq type :pointer-self)
                              #+(or cmu scl) `((* (alien:struct ,name)))
                              #+sbcl `((* (sb-alien:struct ,name)))
-                             #+mcl `((:* (:struct ,name)))
+                             #+(or openmcl digitool) `((:* (:struct ,name)))
                              #+lispworks `((:pointer ,name))
-                             #-(or cmu sbcl scl mcl lispworks) `((* ,name))
+                             #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
                              `(,(convert-from-uffi-type type :struct))))))
        (if variant
            (push (list def) processed)
@@ -98,7 +95,7 @@ of the enum-name name, separator-string, and field-name"
   `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
   #+lispworks
   `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
-  #+(and mcl (not openmcl))
+  #+digitool
   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
   #+openmcl
   `(ccl::def-foreign-type
@@ -117,15 +114,15 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
-  #+mcl
+  #+(or openmcl digitool)
   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
   )
 
-#+mcl
+#+(or openmcl digitool)
 (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))
 
-#+mcl
+#+(or openmcl digitool)
 (defsetf get-slot-value set-slot-value)
 
 
@@ -139,7 +136,7 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
-  #+(and mcl (not openmcl))
+  #+digitool
   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
   #+openmcl
   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
@@ -150,7 +147,7 @@ of the enum-name name, separator-string, and field-name"
 ;; below
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;; so we could allow '(:array :long) or deref with other type like :long only
-  #+mcl
+  #+(or openmcl digitool)
   (defun array-type (type)
     (let ((result type))
       (when (listp type)
@@ -176,7 +173,7 @@ of the enum-name name, separator-string, and field-name"
        (ccl::%foreign-type-or-record local-type)
        `(* ,i ,element-size-in-bits)
        nil))
-    #+(and mcl (not openmcl))
+    #+digitool
     (let* ((array-type (array-type type))
           (local-type (convert-from-uffi-type array-type :allocation))
           (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
@@ -186,7 +183,7 @@ of the enum-name name, separator-string, and field-name"
     ))
   
 ; this expands to the %set-xx functions which has different params than %put-xx
-#+(and mcl (not openmcl))
+#+digitool
 (defmacro deref-array-set (obj type i value)
   (let* ((array-type (array-type type))
          (local-type (convert-from-uffi-type array-type :allocation))
@@ -197,7 +194,7 @@ of the enum-name name, separator-string, and field-name"
       (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 
       ,value)))
 
-#+(and mcl (not openmcl))
+#+digitool
 (defsetf deref-array deref-array-set)
 
 (defmacro def-union (name &rest fields)
@@ -209,7 +206,7 @@ of the enum-name name, separator-string, and field-name"
   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
   #+sbcl
   `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
-  #+(and mcl (not openmcl))
+  #+digitool
   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
   #+openmcl
   `(ccl::def-foreign-type nil 
@@ -226,18 +223,30 @@ of the enum-name name, separator-string, and field-name"
       (declare (fixnum i))
       (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
 
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb-ext:without-package-locks
+      (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                  (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+                                  (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
+    (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                         (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+                                         0))
+    (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                             sb-vm:n-byte-bits
+                                             1))))
+  
+
 #+sbcl
 (defun convert-from-foreign-usb8 (s len)
   (let ((sap (sb-alien:alien-sap s)))
     (declare (type sb-sys:system-area-pointer sap))
     (locally
-       (declare (optimize (speed 3) (safety 0)))
-      (let ((result (make-array len :element-type '(unsigned-byte 8))))
-       (sb-kernel:copy-from-system-area sap 0
-                                        result (* sb-vm:vector-data-offset
-                                                  sb-vm:n-word-bits)
-                                        (* len sb-vm:n-byte-bits))
-       result))))
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((result (make-array len :element-type '(unsigned-byte 8))))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+               (* len +system-copy-multiplier+))
+       result))))
 
 #+cmu
 (defun convert-from-foreign-usb8 (s len)