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

        * Version 1.5.10: Commit patch from Gary King for openmcls

diff --git a/ChangeLog b/ChangeLog
index ef92a5b98cb6d21846105c3218514b0ad63a0ea0..df73e443cbdcd845a4de9f058d9cb4d7c4e57605 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2006-04-17 Kevin Rosenberg (kevin@rosenberg.net)
+       * Version 1.5.10: Commit patch from Gary King for openmcl's
+       feature list change
+       

 2005-11-14 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 1.5.7
        * src/strings.lisp: Add with-foreign-strings by James Biel
 2005-11-14 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 1.5.7
        * src/strings.lisp: Add with-foreign-strings by James Biel

diff --git a/debian/changelog b/debian/changelog
index f44a544903890a7954e8530b9306945601b648a5..c0d662348e34bd2ffd6d7643cbb48417ce2d2c3c 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.5.10-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon, 17 Apr 2006 18:05:56 -0600
+

 cl-uffi (1.5.9-1) unstable; urgency=low
 
   * add GNU uname (closes: 355924)
 cl-uffi (1.5.9-1) unstable; urgency=low
 
   * add GNU uname (closes: 355924)

diff --git a/examples/union.lisp b/examples/union.lisp
index 2b45c50f9a825b2d1c73289b54f1659f900eb723..c7022d83a79db2600e4b64166a2234c78a0a273a 100644 (file)
--- a/examples/union.lisp
+++ b/examples/union.lisp
@@ -66,7 +66,7 @@
               #\A
               :test #'eql
               :fail-info "Error with union character")
               #\A
               :test #'eql
               :fail-info "Error with union character")

-    #-(or sparc sparc-v9 mcl)
+    #-(or sparc sparc-v9 openmcl digitool)

 ;;    (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
 ;;            t
 ;;            :fail-info
 ;;    (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
 ;;            t
 ;;            :fail-info

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index 5d0059c03dc1f94f9cdab67a97ec18d741351345..e660b0b17b4c09c6daefa19feeef4016601e6783 100644 (file)
--- a/src/aggregates.lisp
+++ b/src/aggregates.lisp
@@ -42,7 +42,7 @@ of the enum-name name, separator-string, and field-name"
                       #+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))
                       #+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))
+                       #+digitool `((def-mcl-type ,enum-name :integer))

                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
                       (nreverse constants)))
     cmds))
                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
                       (nreverse constants)))
     cmds))


@@ -61,7 +61,7 @@ of the enum-name name, separator-string, and field-name"
   #+sbcl
   `(sb-alien:define-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))
+  #+digitool

   `(def-mcl-type ,name-array '(:array ,type))
   #+openmcl
   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
   `(def-mcl-type ,name-array '(:array ,type))
   #+openmcl
   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))


@@ -76,9 +76,9 @@ of the enum-name name, separator-string, and field-name"
                          (if (eq type :pointer-self)
                              #+(or cmu scl) `((* (alien:struct ,name)))
                              #+sbcl `((* (sb-alien:struct ,name)))
                          (if (eq type :pointer-self)
                              #+(or cmu scl) `((* (alien:struct ,name)))
                              #+sbcl `((* (sb-alien:struct ,name)))

-                             #+mcl `((:* (:struct ,name)))
+                             #+(or openmcl digitool) `((:* (:struct ,name)))

                              #+lispworks `((:pointer ,name))
                              #+lispworks `((:pointer ,name))

-                             #-(or cmu sbcl scl mcl lispworks) `((* ,name))
+                             #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))

                              `(,(convert-from-uffi-type type :struct))))))
        (if variant
            (push (list def) processed)
                              `(,(convert-from-uffi-type type :struct))))))
        (if variant
            (push (list def) processed)


@@ -95,7 +95,7 @@ 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))
   `(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
   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
   #+openmcl
   `(ccl::def-foreign-type


@@ -114,15 +114,15 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
   `(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))))
   )
 
   `(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))
 
 (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)
 
 
 (defsetf get-slot-value set-slot-value)
 
 


@@ -136,7 +136,7 @@ of the enum-name name, separator-string, and field-name"
   `(alien:slot ,obj ,slot)
   #+sbcl
   `(sb-alien:slot ,obj ,slot)
   `(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:field-info ,type ,slot))))
   #+openmcl
   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))


@@ -147,7 +147,7 @@ of the enum-name name, separator-string, and field-name"
 ;; below
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;; so we could allow '(:array :long) or deref with other type like :long only
 ;; 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)
   (defun array-type (type)
     (let ((result type))
       (when (listp type)


@@ -173,7 +173,7 @@ of the enum-name name, separator-string, and field-name"
        (ccl::%foreign-type-or-record local-type)
        `(* ,i ,element-size-in-bits)
        nil))
        (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)))))
     (let* ((array-type (array-type type))
           (local-type (convert-from-uffi-type array-type :allocation))
           (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))


@@ -183,7 +183,7 @@ of the enum-name name, separator-string, and field-name"
     ))
   
 ; this expands to the %set-xx functions which has different params than %put-xx
     ))
   
 ; 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))
 (defmacro deref-array-set (obj type i value)
   (let* ((array-type (array-type type))
          (local-type (convert-from-uffi-type array-type :allocation))


@@ -194,7 +194,7 @@ of the enum-name name, separator-string, and field-name"
       (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 
       ,value)))
 
       (* (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)
 (defsetf deref-array deref-array-set)
 
 (defmacro def-union (name &rest fields)


@@ -206,7 +206,7 @@ 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)))
   `(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 
   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
   #+openmcl
   `(ccl::def-foreign-type nil 

diff --git a/src/functions.lisp b/src/functions.lisp
index 415401fbb51248f331e005ebe1bbdf3c365a6496..dc7dca2841e45874ca33066a865b9547ac01708c 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -17,12 +17,12 @@
 
 (defun process-function-args (args)
   (if (null args)
 
 (defun process-function-args (args)
   (if (null args)

-      #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
+      #+(or lispworks cmu sbcl scl cormanlisp digitool) nil

       #+allegro '(:void)
       #+openmcl (values nil nil)
 
       ;; args not null
       #+allegro '(:void)
       #+openmcl (values nil nil)
 
       ;; args not null

-      #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
+      #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)

       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))
       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))


@@ -47,7 +47,7 @@
     #+(or cmu sbcl scl)
     ;(list name type :in)
     `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
     #+(or cmu sbcl scl)
     ;(list name type :in)
     `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))

-    #+(or allegro lispworks (and mcl (not openmcl)))
+    #+(or allegro lispworks digitool)

     (if (and (listp type) (listp (car type)))
        (append (list name) type)
       (list name type))
     (if (and (listp type) (listp (car type)))
        (append (list name) type)
       (list name type))


@@ -169,7 +169,7 @@
 ;; name is either a string representing foreign name, or a list
 ;; of foreign-name as a string and lisp name as a symbol
 (defmacro %def-function (names args &key module returning)
 ;; name is either a string representing foreign name, or a list
 ;; of foreign-name as a string and lisp name as a symbol
 (defmacro %def-function (names args &key module returning)

-  #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+  #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))

   
   (let* ((result-type (convert-from-uffi-type returning :return))
         (function-args (process-function-args args))
   
   (let* ((result-type (convert-from-uffi-type returning :return))
         (function-args (process-function-args args))


@@ -198,7 +198,7 @@
        :result-type ,result-type
       :language :ansi-c
        #-macosx :calling-convention #-macosx :cdecl)
        :result-type ,result-type
       :language :ansi-c
        #-macosx :calling-convention #-macosx :cdecl)

-    #+(and mcl (not openmcl))
+    #+digitool

     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args

diff --git a/src/libraries.lisp b/src/libraries.lisp
index 275aee1bb799e6984d050c77e0f4a42b16636d32..a8d09c3f2dc7781e4b772eed46369e31f0ef7805 100644 (file)
--- a/src/libraries.lisp
+++ b/src/libraries.lisp
@@ -76,7 +76,7 @@ library type if type is not specified."
 
 (defun load-foreign-library (filename &key module supporting-libraries
                                           force-load)
 
 (defun load-foreign-library (filename &key module supporting-libraries
                                           force-load)

-  #+(or allegro mcl sbcl) (declare (ignore module supporting-libraries))
+  #+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries))

   #+(or cmu scl) (declare (ignore module))
   #+lispworks (declare (ignore supporting-libraries))
 
   #+(or cmu scl) (declare (ignore module))
   #+lispworks (declare (ignore supporting-libraries))
 


@@ -118,7 +118,7 @@ library type if type is not specified."
                                                 :connection-style :immediate)
        #+allegro (load filename)
        #+openmcl (ccl:open-shared-library filename)
                                                 :connection-style :immediate)
        #+allegro (load filename)
        #+openmcl (ccl:open-shared-library filename)

-       #+(and mcl (not openmcl)) (ccl:add-to-shared-library-search-path filename t)
+       #+digitool (ccl:add-to-shared-library-search-path filename t)

        
        (push filename *loaded-libraries*)
        t))))
        
        (push filename *loaded-libraries*)
        t))))

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))
     #+(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)
     (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)
        `(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
        `(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)
        `(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))))
        )))
 
        `(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)
   `(fli:free-foreign-object ,obj)
   #+allegro
   `(ff:free-fobject ,obj)

-  #+mcl
+  #+(or openmcl digitool)

   `(dispose-ptr ,obj)
   )
 
   `(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)
   #+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)
   )
 
 (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
   #+(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)
   )
 
 (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
   #+(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
   #+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)
   )
 
 (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)
   #+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))
 
 (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)
 (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 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 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)
   #+(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
   `(fli:pointer-address ,obj)
   #+allegro
   obj

-  #+mcl
+  #+(or openmcl digitool)

   `(ccl:%ptr-to-int ,obj)  
   )
 
 ;; TYPE is evaluated.
   `(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)))
 (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)
   )
 
     ,@body)
   )
 

-#-mcl
+#-(or openmcl digitool)

 (defmacro with-foreign-objects (bindings &rest body)
   (if bindings
       `(with-foreign-object ,(car bindings)
 (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)))
 
          ,@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*
 (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)))
                                 
       (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))
 (defmacro with-foreign-object ((var type) &rest body)
   `(with-foreign-objects ((,var ,type)) 
      ,@body))

diff --git a/src/os.lisp b/src/os.lisp
index bd95f05385db385547ab0551ec6662b712f4126c..9c316e4a23401cf8b1ac10e8f894bbe8bf8b95d1 100644 (file)
--- a/src/os.lisp
+++ b/src/os.lisp
@@ -25,9 +25,9 @@
   #+gcl (si:getenv (string var))
   #+lispworks (lw:environment-variable (string var))
   #+lucid (lcl:environment-variable (string var))
   #+gcl (si:getenv (string var))
   #+lispworks (lw:environment-variable (string var))
   #+lucid (lcl:environment-variable (string var))

-  #+mcl (ccl::getenv var)
+  #+(or openmcl digitool) (ccl::getenv var)

   #+sbcl (sb-ext:posix-getenv var)
   #+sbcl (sb-ext:posix-getenv var)

-  #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl)
+  #-(or allegro clisp cmu gcl lispworks lucid openmcl digitool sbcl)

   (error 'not-implemented :proc (list 'getenv var)))
 
 
   (error 'not-implemented :proc (list 'getenv var)))
 
 

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 6eafe7ffcd68a83b1c48641802f36fbc8bab0e33..81110254a4596e94a3c9c7a0f06c88ce422d063f 100644 (file)
--- a/src/primitives.lisp
+++ b/src/primitives.lisp
@@ -15,10 +15,10 @@
 
 (in-package #:uffi)
 
 
 (in-package #:uffi)
 

-#+mcl
+#+(or openmcl digitool)

 (defvar *keyword-package* (find-package "KEYWORD"))
 
 (defvar *keyword-package* (find-package "KEYWORD"))
 

-#+mcl
+#+(or openmcl digitool)

 ; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
 ; So this provides a function to convert any quoted symbols to keywords.
 (defun keyword (obj)
 ; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
 ; So this provides a function to convert any quoted symbols to keywords.
 (defun keyword (obj)


@@ -36,7 +36,7 @@
          obj)))
 
 ; Wrapper for unexported function we have to use
          obj)))
 
 ; Wrapper for unexported function we have to use

-#+(and mcl (not openmcl))
+#+digitool

 (defmacro def-mcl-type (name type)
   `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
 
 (defmacro def-mcl-type (name type)
   `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
 


@@ -50,8 +50,8 @@
 (defmacro def-type (name type)
   "Generates a (deftype) statement for CL. Currently, only CMUCL
 supports takes advantage of this optimization."
 (defmacro def-type (name type)
   "Generates a (deftype) statement for CL. Currently, only CMUCL
 supports takes advantage of this optimization."

-  #+(or lispworks allegro mcl cormanlisp)  (declare (ignore type))
-  #+(or lispworks allegro mcl cormanlisp) `(deftype ,name () t)
+  #+(or lispworks allegro openmcl digitool cormanlisp)  (declare (ignore type))
+  #+(or lispworks allegro openmcl digitool cormanlisp) `(deftype ,name () t)

   #+(or cmu scl)
   `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
   #+sbcl
   #+(or cmu scl)
   `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
   #+sbcl


@@ -68,11 +68,11 @@ supports takes advantage of this optimization."
   #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
   #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
   #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
   #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
   #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
   #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((mcl-type (convert-from-uffi-type type :type)))
     (unless (or (keywordp mcl-type) (consp mcl-type))
       (setf mcl-type `(quote ,mcl-type)))
   (let ((mcl-type (convert-from-uffi-type type :type)))
     (unless (or (keywordp mcl-type) (consp mcl-type))
       (setf mcl-type `(quote ,mcl-type)))

-    #+(and mcl (not openmcl))
+    #+digitool

     `(def-mcl-type ,(keyword name) ,mcl-type)
     #+openmcl
     `(ccl::def-foreign-type ,(keyword name) ,mcl-type))  
     `(def-mcl-type ,(keyword name) ,mcl-type)
     #+openmcl
     `(ccl::def-foreign-type ,(keyword name) ,mcl-type))  


@@ -194,7 +194,7 @@ supports takes advantage of this optimization."
       (:float . :float) (:double . :double)
       (:array . :c-array)))
 
       (:float . :float) (:double . :double)
       (:array . :c-array)))
 

-#+(and mcl (not openmcl))
+#+digitool

 (setq *type-conversion-list*
      '((* . :pointer) (:void . :void)
        (:short . :short) (:unsigned-short . :unsigned-short)
 (setq *type-conversion-list*
      '((* . :pointer) (:void . :void)
        (:short . :short) (:unsigned-short . :unsigned-short)


@@ -234,8 +234,8 @@ supports takes advantage of this optimization."
   (let ((found-type (gethash type +type-conversion-hash+)))
     (if found-type
        found-type
   (let ((found-type (gethash type +type-conversion-hash+)))
     (if found-type
        found-type

-      #-mcl type
-      #+mcl (keyword type))))
+      #-(or openmcl digitool) type
+      #+(or openmcl digitool) (keyword type))))

 
 (defun %convert-from-uffi-type (type context)
   "Converts from a uffi type to an implementation specific type"
 
 (defun %convert-from-uffi-type (type context)
   "Converts from a uffi type to an implementation specific type"


@@ -255,7 +255,7 @@ supports takes advantage of this optimization."
        ((and (eq context :return)
             (eq type :cstring))
        (basic-convert-from-uffi-type :cstring-returning))
        ((and (eq context :return)
             (eq type :cstring))
        (basic-convert-from-uffi-type :cstring-returning))

-       #+(and mcl (not openmcl))
+       #+digitool

        ((and (eq type :void) (eq context :return)) nil)
        (t
        (basic-convert-from-uffi-type type)))
        ((and (eq type :void) (eq context :return)) nil)
        (t
        (basic-convert-from-uffi-type type)))


@@ -264,16 +264,16 @@ supports takes advantage of this optimization."
        (cl:quote
         (convert-from-uffi-type (cadr type) context))
        (:struct-pointer
        (cl:quote
         (convert-from-uffi-type (cadr type) context))
        (:struct-pointer

-        #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
-        #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct)
+        #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+        #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)

         )
        (:struct
         )
        (:struct

-        #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
-        #-mcl (%convert-from-uffi-type (cadr type) :struct)
+        #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+        #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)

         )
        (:union
         )
        (:union

-       #+mcl `(:union ,(%convert-from-uffi-type (cadr type) :union))
-       #-mcl (%convert-from-uffi-type (cadr type) :union)
+       #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+       #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)

        )
        (t
        (cons (%convert-from-uffi-type (first type) context) 
        )
        (t
        (cons (%convert-from-uffi-type (first type) context) 


@@ -288,7 +288,7 @@ supports takes advantage of this optimization."
       (if (eq context :struct)
          (append '(:*) (cdr result))
        :address))
       (if (eq context :struct)
          (append '(:*) (cdr result))
        :address))

-     #+(and mcl (not openmcl))
+     #+digitool

      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
      (t result))))
 
      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
      (t result))))
 

diff --git a/src/readmacros-mcl.lisp b/src/readmacros-mcl.lisp
index 3bf8f4619ede69ed8b79546cac53118617ecc99d..561bf550d12ad93ac72cbbdff640f7eecb5bae01 100644 (file)
--- a/src/readmacros-mcl.lisp
+++ b/src/readmacros-mcl.lisp
@@ -17,11 +17,11 @@
 
 
 ;; trap macros don't work right directly in the macros
 
 
 ;; trap macros don't work right directly in the macros

-#+(and mcl (not openmcl))
+#+digitool

 (defun new-ptr (size)
   (#_NewPtr size))
 
 (defun new-ptr (size)
   (#_NewPtr size))
 

-#+(and mcl (not openmcl))
+#+digitool

 (defun dispose-ptr (ptr)
   (#_DisposePtr ptr))
 
 (defun dispose-ptr (ptr)
   (#_DisposePtr ptr))
 

diff --git a/src/strings.lisp b/src/strings.lisp
index ebdffebadf4893287c870b97cd5879ecf6462993..69f1f02836f9fbf0ff37b21af145a076029ed091 100644 (file)
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -19,7 +19,7 @@
     #+(or cmu sbcl scl) nil
     #+allegro 0
     #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
     #+(or cmu sbcl scl) nil
     #+allegro 0
     #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))

-    #+mcl (ccl:%null-ptr)
+    #+(or openmcl digitool) (ccl:%null-ptr)

 )
 
 (defmacro convert-from-cstring (obj)
 )
 
 (defmacro convert-from-cstring (obj)


@@ -32,7 +32,7 @@ that LW/CMU automatically converts strings from c-calls."
        (if (zerop ,stored)
           nil
           (values (excl:native-to-string ,stored)))))
        (if (zerop ,stored)
           nil
           (values (excl:native-to-string ,stored)))))

-  #+mcl 
+  #+(or openmcl digitool) 

   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (if (ccl:%null-ptr-p ,stored)
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (if (ccl:%null-ptr-p ,stored)


@@ -48,7 +48,7 @@ that LW/CMU automatically converts strings from c-calls."
        (if (null ,stored)
           0
           (values (excl:string-to-native ,stored)))))
        (if (null ,stored)
           0
           (values (excl:string-to-native ,stored)))))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (if (null ,stored)
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (if (null ,stored)


@@ -65,7 +65,7 @@ that LW/CMU automatically converts strings from c-calls."
     `(let ((,stored ,obj))
        (unless (zerop ,stored)
         (ff:free-fobject ,stored))))
     `(let ((,stored ,obj))
        (unless (zerop ,stored)
         (ff:free-fobject ,stored))))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (unless (ccl:%null-ptr-p ,stored)
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
        (unless (ccl:%null-ptr-p ,stored)


@@ -82,7 +82,7 @@ that LW/CMU automatically converts strings from c-calls."
        (excl:with-native-string (,acl-native ,stored-lisp-string)
         (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
           ,@body))))
        (excl:with-native-string (,acl-native ,stored-lisp-string)
         (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
           ,@body))))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((stored-lisp-string (gensym)))
     `(let ((,stored-lisp-string ,lisp-string))
        (if (stringp ,stored-lisp-string)
   (let ((stored-lisp-string (gensym)))
     `(let ((,stored-lisp-string ,lisp-string))
        (if (stringp ,stored-lisp-string)


@@ -158,7 +158,7 @@ that LW/CMU automatically converts strings from c-calls."
                      (char-code (char ,stored-obj ,i))))
              (setf (sb-alien:deref ,storage ,size) 0))
            ,storage)))))
                      (char-code (char ,stored-obj ,i))))
              (setf (sb-alien:deref ,storage ,size) 0))
            ,storage)))))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((stored-obj (gensym)))
     `(let ((,stored-obj ,obj))
        (if (null ,stored-obj)
   (let ((stored-obj (gensym)))
     `(let ((,stored-obj ,obj))
        (if (null ,stored-obj)


@@ -214,14 +214,14 @@ that LW/CMU automatically converts strings from c-calls."
            (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
                                     :length ,length
                                     :null-terminated-p ,null-terminated-p))))
            (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
                                     :length ,length
                                     :null-terminated-p ,null-terminated-p))))

-  #+mcl
+  #+(or openmcl digitool)

   (declare (ignore null-terminated-p))
   (declare (ignore null-terminated-p))

-  #+mcl
+  #+(or openmcl digitool)

   (let ((stored-obj (gensym)))
     `(let ((,stored-obj ,obj))
        (if (ccl:%null-ptr-p ,stored-obj)
           nil
   (let ((stored-obj (gensym)))
     `(let ((,stored-obj ,obj))
        (if (ccl:%null-ptr-p ,stored-obj)
           nil

-          #+(and mcl (not openmcl)) (ccl:%get-cstring
+          #+digitool (ccl:%get-cstring

                                      ,stored-obj 0
                                      ,@(if length (list length) nil))
           #+openmcl ,@(if length
                                      ,stored-obj 0
                                      ,@(if length (list length) nil))
           #+openmcl ,@(if length


@@ -261,9 +261,9 @@ that LW/CMU automatically converts strings from c-calls."
   (declare (ignore unsigned))
   #+allegro
   `(ff:allocate-fobject :char :c ,size)
   (declare (ignore unsigned))
   #+allegro
   `(ff:allocate-fobject :char :c ,size)

-  #+mcl
+  #+(or openmcl digitool)

   (declare (ignore unsigned))
   (declare (ignore unsigned))

-  #+mcl
+  #+(or openmcl digitool)

   `(new-ptr ,size)
   )
 
   `(new-ptr ,size)
   )
 

diff --git a/tests/union.lisp b/tests/union.lisp
index 1806a9cdf7aee6dd2c2e130e49c3711a5ef6b9eb..d067bd02446ad343524d51063df473ee8a08f525 100644 (file)
--- a/tests/union.lisp
+++ b/tests/union.lisp
@@ -45,7 +45,7 @@
      (uffi:get-slot-value *u* 'tunion1 'char))
   65)
 
      (uffi:get-slot-value *u* 'tunion1 'char))
   65)
 

-#-(or sparc sparc-v9 mcl)
+#-(or sparc sparc-v9 openmcl digitool)

 (deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
 
 
 (deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
 
 

diff --git a/uffi.asd b/uffi.asd
index 3f17945ade9bdf7ce3f0ecd4525226d6aa5ab5d1..ab174172024a5c567c425e6b151bed791fd74cc9 100644 (file)
--- a/uffi.asd
+++ b/uffi.asd
@@ -16,7 +16,7 @@
 (defpackage #:uffi-system (:use #:asdf #:cl))
 (in-package #:uffi-system)
 
 (defpackage #:uffi-system (:use #:asdf #:cl))
 (in-package #:uffi-system)
 

-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)

 (defsystem uffi
   :name "uffi"
   :author "Kevin Rosenberg <kevin@rosenberg.net>"
 (defsystem uffi
   :name "uffi"
   :author "Kevin Rosenberg <kevin@rosenberg.net>"


@@ -31,7 +31,7 @@
            :components
            ((:file "package")
             (:file "primitives" :depends-on ("package"))
            :components
            ((:file "package")
             (:file "primitives" :depends-on ("package"))

-            #+mcl (:file "readmacros-mcl" :depends-on ("package"))
+            #+(or openmcl digitool) (:file "readmacros-mcl" :depends-on ("package"))

             (:file "objects" :depends-on ("primitives"))
             (:file "aggregates" :depends-on ("primitives"))
             (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))
             (:file "objects" :depends-on ("primitives"))
             (:file "aggregates" :depends-on ("primitives"))
             (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))


@@ -40,7 +40,7 @@
             (:file "os" :depends-on ("package"))))
    ))
 
             (:file "os" :depends-on ("package"))))
    ))
 

-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)

 (defmethod perform ((o test-op) (c (eql (find-system 'uffi))))
   (oos 'load-op 'uffi-tests)
   (oos 'test-op 'uffi-tests :force t))
 (defmethod perform ((o test-op) (c (eql (find-system 'uffi))))
   (oos 'load-op 'uffi-tests)
   (oos 'test-op 'uffi-tests :force t))