X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Faggregates.lisp;h=f02f2033e29dfbd460927cca138eb844d7877302;hb=5d4295830e68c889ba2df9d9f88e896a70f20d7a;hp=5fdc9081d430acc5e83ec570f01d3d99764d00f2;hpb=7b35c93f34d7fbab2e7d487b42be5b1cb1aaa73a;p=uffi.git diff --git a/src/aggregates.lisp b/src/aggregates.lisp index 5fdc908..f02f203 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -118,8 +118,7 @@ of the enum-name name, separator-string, and field-name" #+sbcl `(sb-alien:slot ,obj ,slot) #+mcl - `(ccl:pref ,obj ,(intern (concatenate 'string (symbol-name type) "." (symbol-name slot)) - :keyword)) + `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ) #+mcl @@ -147,42 +146,45 @@ of the enum-name name, separator-string, and field-name" (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))) ) -; so we could allow '(:array :long) or deref with other type like :long only -#+mcl -(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" - #+(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 :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)) - (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)))) - ) - +;; 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 + (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" + #+(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 :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)) + (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 #+(and mcl (not openmcl)) (defmacro deref-array-set (obj type i value) @@ -224,26 +226,40 @@ 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) - (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))) + (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 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))) +(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))) + (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))))