X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Faggregates.lisp;h=5d0059c03dc1f94f9cdab67a97ec18d741351345;hb=c4533c02d3f2ebd53178c93de2dee09ca39fe0e7;hp=a1d8a67d69c1b74cbad780ae9fb2dd4ebbec1610;hpb=a95b9a217335917d96b8c0cced4f49c3e4846115;p=uffi.git diff --git a/src/aggregates.lisp b/src/aggregates.lisp index a1d8a67..5d0059c 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -2,22 +2,18 @@ ;;;; ************************************************************************* ;;;; 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.1 2002/09/30 10:02:36 kevin Exp $ +;;;; $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. ;;;; ************************************************************************* -(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 @@ -44,7 +40,8 @@ of the enum-name name, separator-string, and field-name" (setf cmds (append '(progn) #+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)) + #+(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)) #+openmcl `((ccl::def-foreign-type ,enum-name :int)) (nreverse constants))) @@ -58,9 +55,12 @@ of the enum-name name, separator-string, and field-name" #+lispworks `(fli:define-c-typedef ,name-array (:c-array ,(convert-from-uffi-type type :array))) - #+cmu + #+(or cmu scl) `(alien:def-alien-type ,name-array (* ,(convert-from-uffi-type type :array))) + #+sbcl + `(sb-alien:define-alien-type ,name-array + (* ,(convert-from-uffi-type type :array))) #+(and mcl (not openmcl)) `(def-mcl-type ,name-array '(:array ,type)) #+openmcl @@ -74,9 +74,11 @@ of the enum-name name, separator-string, and field-name" (type (cadr field)) (def (append (list field-name) (if (eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) + #+(or cmu scl) `((* (alien:struct ,name))) + #+sbcl `((* (sb-alien:struct ,name))) #+mcl `((:* (:struct ,name))) - #-(or cmu mcl) `((* ,name)) + #+lispworks `((:pointer ,name)) + #-(or cmu sbcl scl mcl lispworks) `((* ,name)) `(,(convert-from-uffi-type type :struct)))))) (if variant (push (list def) processed) @@ -85,8 +87,10 @@ of the enum-name name, separator-string, and field-name" (defmacro def-struct (name &rest fields) - #+cmu + #+(or cmu scl) `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) + #+sbcl + `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields))) #+allegro `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) #+lispworks @@ -101,13 +105,15 @@ of the enum-name name, separator-string, and field-name" (defmacro get-slot-value (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) + #+(or lispworks cmu sbcl scl) (declare (ignore type)) #+allegro `(ff:fslot-value-typed ,type :c ,obj ,slot) #+lispworks `(fli:foreign-slot-value ,obj ,slot) - #+cmu + #+(or cmu scl) `(alien:slot ,obj ,slot) + #+sbcl + `(sb-alien:slot ,obj ,slot) #+mcl `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ) @@ -121,13 +127,15 @@ of the enum-name name, separator-string, and field-name" (defmacro get-slot-pointer (obj type slot) - #+(or lispworks cmu) (declare (ignore type)) + #+(or lispworks cmu sbcl scl) (declare (ignore type)) #+allegro `(ff:fslot-value-typed ,type :c ,obj ,slot) #+lispworks `(fli:foreign-slot-pointer ,obj ,slot) - #+cmu + #+(or cmu scl) `(alien:slot ,obj ,slot) + #+sbcl + `(sb-alien:slot ,obj ,slot) #+(and mcl (not openmcl)) `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))) #+openmcl @@ -135,34 +143,47 @@ 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) (declare (ignore type)) - #+cmu `(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) +;; 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 - (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)))) - ) - + (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 -#+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)) @@ -173,7 +194,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) @@ -181,11 +202,61 @@ of the enum-name name, separator-string, and field-name" `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) #+lispworks `(fli:define-c-union ,name ,@(process-struct-fields name fields)) - #+cmu + #+(or cmu scl) `(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)) `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))) #+openmcl `(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 +(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))) + (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))))