* Version 1.5.10: Commit patch from Gary King for openmcls
13 files changed:
+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
+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)
#\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
#+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))
#+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))
`(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)))
(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)
`(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))
`(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
`(alien:slot ,obj ,slot)
#+sbcl
`(sb-alien:slot ,obj ,slot)
`(alien:slot ,obj ,slot)
#+sbcl
`(sb-alien:slot ,obj ,slot)
+ #+(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))))
)
(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))
(defsetf get-slot-value set-slot-value)
(defsetf get-slot-value set-slot-value)
`(alien:slot ,obj ,slot)
#+sbcl
`(sb-alien:slot ,obj ,slot)
`(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
`(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)))
;; 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
+ #+(or openmcl digitool)
(defun array-type (type)
(let ((result type))
(when (listp type)
(defun array-type (type)
(let ((result type))
(when (listp type)
(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))
(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)))))
))
; 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))
(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))
(* (the fixnum ,i) ,(size-of-foreign-type local-type))
,value)))
(* (the fixnum ,i) ,(size-of-foreign-type local-type))
,value)))
-#+(and mcl (not openmcl))
(defsetf deref-array deref-array-set)
(defmacro def-union (name &rest fields)
(defsetf deref-array deref-array-set)
(defmacro def-union (name &rest 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)))
`(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
`(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
#+openmcl
`(ccl::def-foreign-type nil
(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))
#+(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))
;; 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))
: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))
`(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
(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))
: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))))
#+(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))
(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)
`(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)
+ #+(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
`(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)
+ #+(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))))
)))
`(fli:free-foreign-object ,obj)
#+allegro
`(ff:free-fobject ,obj)
`(fli:free-foreign-object ,obj)
#+allegro
`(ff:free-fobject ,obj)
+ #+(or openmcl digitool)
#+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
+ #+(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)
#+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
+ #+(or openmcl digitool) obj
)
(defmacro deref-pointer (ptr type)
)
(defmacro deref-pointer (ptr type)
#+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))
(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))
(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 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)
`(fli:pointer-address ,obj)
#+allegro
obj
`(fli:pointer-address ,obj)
#+allegro
obj
+ #+(or openmcl digitool)
`(ccl:%ptr-to-int ,obj)
)
;; TYPE is evaluated.
`(ccl:%ptr-to-int ,obj)
)
;; TYPE is evaluated.
(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)))
(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)
,@body))
`(progn ,@body)))
,@body))
`(progn ,@body)))
(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*
(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)))
(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))
#+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)))
(defvar *keyword-package* (find-package "KEYWORD"))
(defvar *keyword-package* (find-package "KEYWORD"))
; 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)
obj)))
; Wrapper for unexported function we have to use
obj)))
; Wrapper for unexported function we have to use
-#+(and mcl (not openmcl))
(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)))
(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
#+(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))
+ #+(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))
`(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))
(:float . :float) (:double . :double)
(:array . :c-array)))
(:float . :float) (:double . :double)
(:array . :c-array)))
-#+(and mcl (not openmcl))
(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)
(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"
((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))
((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)))
(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)
- #+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)
- #+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)
(if (eq context :struct)
(append '(:*) (cdr result))
:address))
(if (eq context :struct)
(append '(:*) (cdr result))
:address))
- #+(and mcl (not openmcl))
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))
;; trap macros don't work right directly in the macros
;; trap macros don't work right directly in the macros
-#+(and mcl (not openmcl))
(defun new-ptr (size)
(#_NewPtr size))
(defun new-ptr (size)
(#_NewPtr size))
-#+(and mcl (not openmcl))
(defun dispose-ptr (ptr)
(#_DisposePtr ptr))
(defun dispose-ptr (ptr)
(#_DisposePtr ptr))
#+(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))
+ #+(or openmcl digitool) (ccl:%null-ptr)
)
(defmacro convert-from-cstring (obj)
)
(defmacro convert-from-cstring (obj)
(if (zerop ,stored)
nil
(values (excl:native-to-string ,stored)))))
(if (zerop ,stored)
nil
(values (excl:native-to-string ,stored)))))
+ #+(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)
(if (null ,stored)
0
(values (excl:string-to-native ,stored)))))
(if (null ,stored)
0
(values (excl:string-to-native ,stored)))))
+ #+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
`(let ((,stored ,obj))
(unless (zerop ,stored)
(ff:free-fobject ,stored))))
`(let ((,stored ,obj))
(unless (zerop ,stored)
(ff:free-fobject ,stored))))
+ #+(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)
(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))))
+ #+(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)
(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)))))
+ #+(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)
(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))))
+ #+(or openmcl digitool)
(declare (ignore null-terminated-p))
(declare (ignore null-terminated-p))
+ #+(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
(declare (ignore unsigned))
#+allegro
`(ff:allocate-fobject :char :c ,size)
(declare (ignore unsigned))
#+allegro
`(ff:allocate-fobject :char :c ,size)
+ #+(or openmcl digitool)
(declare (ignore unsigned))
(declare (ignore unsigned))
+ #+(or openmcl digitool)
(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)
(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>"
: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"))
(: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))