X-Git-Url: http://git.kpe.io/?p=uffi.git;a=blobdiff_plain;f=src%2Faggregates.lisp;h=88f373dcdbed91f9147b9d2c42f830b1cc817ed1;hp=ec1a559b2612ec5386223bed35ac0c7585654f32;hb=b86fdf882156aa45dc6e8e93a158dedf506f4233;hpb=218088774006bd9df58df318a6b3981065dfc71f diff --git a/src/aggregates.lisp b/src/aggregates.lisp index ec1a559..88f373d 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -7,13 +7,8 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id$ +;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 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) @@ -23,48 +18,48 @@ in the created in the current package. The symbol is the concatenation of the enum-name name, separator-string, and field-name" (let ((counter 0) - (cmds nil) - (constants nil)) + (cmds nil) + (constants nil)) (declare (fixnum counter)) (dolist (arg args) (let ((name (if (listp arg) (car arg) arg)) - (value (if (listp arg) - (prog1 - (setq counter (cadr arg)) - (incf counter)) - (prog1 - counter - (incf counter))))) - (setq name (intern (concatenate 'string - (symbol-name enum-name) - separator-string - (symbol-name name)))) - (push `(uffi:def-constant ,name ,value) constants))) + (value (if (listp arg) + (prog1 + (setq counter (cadr arg)) + (incf counter)) + (prog1 + counter + (incf counter))))) + (setq name (intern (concatenate 'string + (symbol-name enum-name) + separator-string + (symbol-name name)))) + (push `(uffi:def-constant ,name ,value) constants))) (setf cmds (append '(progn) - #+allegro `((ff:def-foreign-type ,enum-name :int)) - #+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)) + #+allegro `((ff:def-foreign-type ,enum-name :int)) + #+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)) + #+digitool `((def-mcl-type ,enum-name :integer)) #+openmcl `((ccl::def-foreign-type ,enum-name :int)) - (nreverse constants))) + (nreverse constants))) cmds)) (defmacro def-array-pointer (name-array type) #+allegro - `(ff:def-foreign-type ,name-array + `(ff:def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))) #+lispworks `(fli:define-c-typedef ,name-array (:c-array ,(convert-from-uffi-type type :array))) #+(or cmu scl) - `(alien:def-alien-type ,name-array + `(alien:def-alien-type ,name-array (* ,(convert-from-uffi-type type :array))) #+sbcl - `(sb-alien:define-alien-type ,name-array + `(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))) @@ -74,21 +69,21 @@ of the enum-name name, separator-string, and field-name" (let (processed) (dolist (field fields) (let* ((field-name (car field)) - (type (cadr field)) - (def (append (list field-name) - (if (eq type :pointer-self) - #+(or cmu scl) `((* (alien:struct ,name))) - #+sbcl `((* (sb-alien:struct ,name))) - #+mcl `((:* (:struct ,name))) - #+lispworks `((:pointer ,name)) - #-(or cmu sbcl scl mcl lispworks) `((* ,name)) - `(,(convert-from-uffi-type type :struct)))))) - (if variant - (push (list def) processed) - (push def processed)))) + (type (cadr field)) + (def (append (list field-name) + (if (eq type :pointer-self) + #+(or cmu scl) `((* (alien:struct ,name))) + #+sbcl `((* (sb-alien:struct ,name))) + #+(or openmcl digitool) `((:* (:struct ,name))) + #+lispworks `((:pointer ,name)) + #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)) + `(,(convert-from-uffi-type type :struct)))))) + (if variant + (push (list def) processed) + (push def processed)))) (nreverse processed))) - - + + (defmacro def-struct (name &rest fields) #+(or cmu scl) `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) @@ -98,11 +93,11 @@ 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 - nil + nil (:struct ,name ,@(process-struct-fields name fields))) ) @@ -117,15 +112,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,27 +134,27 @@ 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))) - (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))) + (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))) ) ;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8 ;; 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) - (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))))) + (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" #+(or lispworks cmu sbcl scl) (declare (ignore type)) @@ -169,35 +164,35 @@ of the enum-name name, separator-string, and field-name" #+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)) - (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits))) + (local-type (convert-from-uffi-type array-type :allocation)) + (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)) + #+digitool (let* ((array-type (array-type type)) - (local-type (convert-from-uffi-type array-type :allocation)) - (accessor (first (macroexpand `(ccl:pref obj ,local-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)))) + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)))) )) - + ; 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)) (accessor (first (macroexpand `(ccl:pref obj ,local-type)))) (settor (first (macroexpand `(setf (,accessor obj ,local-type) value))))) - `(,settor + `(,settor ,obj - (* (the fixnum ,i) ,(size-of-foreign-type local-type)) + (* (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,49 +204,57 @@ 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 - (:union ,name ,@(process-struct-fields name fields))) + `(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)) + (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 -(sb-ext:without-package-locks - (let ((copy-fn (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) - (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL") - (intern "COPY-UB8-FROM-SYSTEM" "SB-KERNEL")))) - (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)))) - (funcall copy-fn sap 0 - result (* sb-vm:vector-data-offset - sb-vm:n-word-bits) - (* len sb-vm:n-byte-bits)) - result)))))) +(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)))) + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* len +system-copy-multiplier+)) + result)))) #+cmu (defun convert-from-foreign-usb8 (s len) (let ((sap (alien:alien-sap s))) (declare (type system:system-area-pointer sap)) (locally - (declare (optimize (speed 3) (safety 0))) + (declare (optimize (speed 3) (safety 0))) (let ((result (make-array len :element-type '(unsigned-byte 8)))) - (kernel:copy-from-system-area sap 0 - result (* vm:vector-data-offset - vm:word-bits) - (* len vm:byte-bits)) - result)))) + (kernel:copy-from-system-area sap 0 + result (* vm:vector-data-offset + vm:word-bits) + (* len vm:byte-bits)) + result))))