X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fobjects.lisp;fp=src%2Fobjects.lisp;h=f777f3c242d6b6dd7ffbf381bdbe81a01b135745;hb=6ab554f2441048c9c726104d4f3c6a6acccaf383;hp=33bd042e71048e36dec970f0c78e20a58f5f2386;hpb=48ce70f207ba97c0620bfaa472619f4c3c771a21;p=uffi.git diff --git a/src/objects.lisp b/src/objects.lisp index 33bd042..f777f3c 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -22,7 +22,7 @@ #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes #+clisp (values (ffi:size-of type)) - #+(and mcl (not openmcl)) + #+digitool (let ((mcl-type (ccl:find-mactype type nil t))) (if mcl-type (ccl::mactype-record-size mcl-type) @@ -43,7 +43,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) #+allegro `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) - #+mcl + #+(or openmcl digitool) `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) ) (progn @@ -55,7 +55,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) #+allegro `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c) - #+mcl + #+(or openmcl digitool) `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) ))) @@ -68,7 +68,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:free-foreign-object ,obj) #+allegro `(ff:free-fobject ,obj) - #+mcl + #+(or openmcl digitool) `(dispose-ptr ,obj) ) @@ -77,25 +77,25 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+allegro `(zerop ,obj) #+(or cmu scl) `(alien:null-alien ,obj) #+sbcl `(sb-alien:null-alien ,obj) - #+mcl `(ccl:%null-ptr-p ,obj) + #+(or openmcl digitool) `(ccl:%null-ptr-p ,obj) ) (defmacro make-null-pointer (type) - #+(or allegro mcl) (declare (ignore type)) + #+(or allegro openmcl digitool) (declare (ignore type)) #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type))) #+allegro 0 - #+mcl `(ccl:%null-ptr) + #+(or openmcl digitool) `(ccl:%null-ptr) ) (defmacro make-pointer (addr type) - #+(or allegro mcl) (declare (ignore type)) + #+(or allegro openmcl digitool) (declare (ignore type)) #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type))) #+allegro addr - #+mcl `(ccl:%int-to-ptr ,addr) + #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr) ) @@ -105,7 +105,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+lispworks `(fli:make-pointer :type '(:unsigned :char) :address (fli:pointer-address ,obj)) #+allegro obj - #+mcl obj + #+(or openmcl digitool) obj ) (defmacro deref-pointer (ptr type) @@ -115,31 +115,31 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+sbcl `(sb-alien:deref ,ptr) #+lispworks `(fli:dereference ,ptr) #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr) - #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) + #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ) -#+(and mcl (not openmcl)) +#+digitool (defmacro deref-pointer-set (ptr type value) `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) -#+(and mcl (not openmcl)) +#+digitool (defsetf deref-pointer deref-pointer-set) (defmacro ensure-char-character (obj) - #+(or (and mcl (not openmcl))) obj + #+(or digitool) obj #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj) ;; lispworks varies whether deref'ing array vs. slot access of a char #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj))) (defmacro ensure-char-integer (obj) - #+(or (and mcl (not openmcl))) `(char-code ,obj) + #+(or digitool) `(char-code ,obj) #+(or allegro cmu sbcl scl openmcl) obj ;; lispworks varies whether deref'ing array vs. slot access of a char #+lispworks `(if (integerp ,obj) ,obj (char-code ,obj))) (defmacro ensure-char-storable (obj) - #+(or lispworks (and mcl (not openmcl))) obj + #+(or lispworks digitool) obj #+(or allegro cmu sbcl scl openmcl) `(char-code ,obj)) (defmacro pointer-address (obj) @@ -151,12 +151,12 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(fli:pointer-address ,obj) #+allegro obj - #+mcl + #+(or openmcl digitool) `(ccl:%ptr-to-int ,obj) ) ;; TYPE is evaluated. -#-mcl +#-(or openmcl digitool) (defmacro with-foreign-object ((var type) &rest body) #-(or cmu sbcl lispworks scl) ; default version `(let ((,var (allocate-foreign-object ,type))) @@ -189,7 +189,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ,@body) ) -#-mcl +#-(or openmcl digitool) (defmacro with-foreign-objects (bindings &rest body) (if bindings `(with-foreign-object ,(car bindings) @@ -197,7 +197,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ,@body)) `(progn ,@body))) -#+mcl +#+(or openmcl digitool) (defmacro with-foreign-objects (bindings &rest body) (let ((params nil) type count) (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* @@ -210,7 +210,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (push (list (first spec) (* count (size-of-foreign-type type))) params)) `(ccl:%stack-block ,params ,@body))) -#+mcl +#+(or openmcl digitool) (defmacro with-foreign-object ((var type) &rest body) `(with-foreign-objects ((,var ,type)) ,@body))