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

[uffi.git] / src / objects.lisp

diff --git a/src/objects.lisp b/src/objects.lisp
index 33bd042e71048e36dec970f0c78e20a58f5f2386..f777f3c242d6b6dd7ffbf381bdbe81a01b135745 100644 (file)
--- 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))