; 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)
(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)
(defmacro def-foreign-type (name type)
#+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
#+allegro `(ff:def-foreign-type ,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))
(defmacro def-foreign-type (name type)
#+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
#+allegro `(ff:def-foreign-type ,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))
(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)))
)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
#+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
#+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
#-x86-64 (:unsigned-long . (alien:unsigned 32))
#+x86-64 (:long . (alien:signed 64))
#+x86-64 (:unsigned-long . (alien:unsigned 64))
#-x86-64 (:unsigned-long . (alien:unsigned 32))
#+x86-64 (:long . (alien:signed 64))
#+x86-64 (:unsigned-long . (alien:unsigned 64))
#-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
#+x86-64 (:long . (sb-alien:signed 64))
#+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
#-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
#+x86-64 (:long . (sb-alien:signed 64))
#+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
(:unsigned-char . (alien:unsigned 8))
(:byte . (alien:signed 8))
(:unsigned-byte . (alien:unsigned 8))
(:short . c-call:short)
(:unsigned-short . c-call:unsigned-short)
(:unsigned-char . (alien:unsigned 8))
(:byte . (alien:signed 8))
(:unsigned-byte . (alien:unsigned 8))
(:short . c-call:short)
(:unsigned-short . c-call:unsigned-short)
+ #+#.(cl:if (cl:and (cl:find-package (cl:string '#:c-call))
+ (cl:find-symbol (cl:string '#:long-long)
+ (cl:string '#:c-call)))
+ '(and) '(or))
+ (:long-long . c-call:long-long)
+ #+#.(cl:if (cl:and (cl:find-package (cl:string '#:c-call))
+ (cl:find-symbol (cl:string '#:unsigned-long-long)
+ (cl:string '#:c-call)))
+ '(and) '(or))
+ (:unsigned-long-long . c-call:unsigned-long-long)
(:unsigned-char . (sb-alien:unsigned 8))
(:byte . (sb-alien:signed 8))
(:unsigned-byte . (sb-alien:unsigned 8))
(:short . sb-alien:short)
(:unsigned-short . sb-alien:unsigned-short)
(:unsigned-char . (sb-alien:unsigned 8))
(:byte . (sb-alien:signed 8))
(:unsigned-byte . (sb-alien:unsigned 8))
(:short . sb-alien:short)
(:unsigned-short . sb-alien:unsigned-short)
(:byte . :byte)
(:unsigned-byte . (:unsigned :byte))
(:char . :char)
(:unsigned-char . (:unsigned :char))
(:int . :int) (:unsigned-int . (:unsigned :int))
(:long . :long) (:unsigned-long . (:unsigned :long))
(:byte . :byte)
(:unsigned-byte . (:unsigned :byte))
(:char . :char)
(:unsigned-char . (:unsigned :char))
(:int . :int) (:unsigned-int . (:unsigned :int))
(:long . :long) (:unsigned-long . (:unsigned :long))
(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)
(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"
- (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)
- )
- (:struct
- #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
- #-mcl (%convert-from-uffi-type (cadr type) :struct)
- )
+ (cl:quote
+ (convert-from-uffi-type (cadr type) context))
+ (:struct-pointer
+ #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+ #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
+ )
+ (: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)
+ )
- (cons (%convert-from-uffi-type (first type) context)
- (%convert-from-uffi-type (rest type) context)))))))
+ (cons (%convert-from-uffi-type (first type) context)
+ (%convert-from-uffi-type (rest type) context)))))))
(when (char= #\a (schar (symbol-name '#:a) 0))
(pushnew :uffi-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
(when (char= #\a (schar (symbol-name '#:a) 0))
(pushnew :uffi-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
(pushnew :uffi-case-sensitive *features*)))
(defun make-lisp-name (name)
(let ((converted (substitute #\- #\_ name)))
(pushnew :uffi-case-sensitive *features*)))
(defun make-lisp-name (name)
(let ((converted (substitute #\- #\_ name)))
#+uffi-case-sensitive converted
#+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
#+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
#+uffi-case-sensitive converted
#+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
#+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))