;;;; Purpose: UFFI source to handle aggregate types
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
;;;; Purpose: UFFI source to handle aggregate types
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(defmacro def-enum (enum-name args &key (separator-string "#"))
"Creates a constants for a C type enum list, symbols are created
(defmacro def-enum (enum-name args &key (separator-string "#"))
"Creates a constants for a C type enum list, symbols are created
(setf cmds (append '(progn)
#+allegro `((ff:def-foreign-type ,enum-name :int))
#+lispworks `((fli:define-c-typedef ,enum-name :int))
(setf cmds (append '(progn)
#+allegro `((ff:def-foreign-type ,enum-name :int))
#+lispworks `((fli:define-c-typedef ,enum-name :int))
- #+cmu `((alien:def-alien-type ,enum-name alien:signed))
- #+sbcl `((sb-alien:def-alien-type ,enum-name sb-alien:signed))
+ #+(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))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
(nreverse constants)))
#+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
#+openmcl `((ccl::def-foreign-type ,enum-name :int))
(nreverse constants)))
#+lispworks
`(fli:define-c-typedef ,name-array
(:c-array ,(convert-from-uffi-type type :array)))
#+lispworks
`(fli:define-c-typedef ,name-array
(:c-array ,(convert-from-uffi-type type :array)))
`(alien:def-alien-type ,name-array
(* ,(convert-from-uffi-type type :array)))
#+sbcl
`(alien:def-alien-type ,name-array
(* ,(convert-from-uffi-type type :array)))
#+sbcl
(* ,(convert-from-uffi-type type :array)))
#+(and mcl (not openmcl))
`(def-mcl-type ,name-array '(:array ,type))
(* ,(convert-from-uffi-type type :array)))
#+(and mcl (not openmcl))
`(def-mcl-type ,name-array '(:array ,type))
#+sbcl `((* (sb-alien:struct ,name)))
#+mcl `((:* (:struct ,name)))
#+sbcl `((* (sb-alien:struct ,name)))
#+mcl `((:* (:struct ,name)))
- #-(or cmu sbcl mcl) `((* ,name))
+ #+lispworks `((:pointer ,name))
+ #-(or cmu sbcl scl mcl 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)
`(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
#+sbcl
`(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
#+sbcl
- `(sb-alien:def-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
+ `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
#+allegro
`(ff:fslot-value-typed ,type :c ,obj ,slot)
#+lispworks
`(fli:foreign-slot-value ,obj ,slot)
#+allegro
`(ff:fslot-value-typed ,type :c ,obj ,slot)
#+lispworks
`(fli:foreign-slot-value ,obj ,slot)
#+allegro
`(ff:fslot-value-typed ,type :c ,obj ,slot)
#+lispworks
`(fli:foreign-slot-pointer ,obj ,slot)
#+allegro
`(ff:fslot-value-typed ,type :c ,obj ,slot)
#+lispworks
`(fli:foreign-slot-pointer ,obj ,slot)
- #+(or lispworks cmu sbcl) (declare (ignore type))
- #+cmu `(alien:deref ,obj ,i)
+ #+(or lispworks cmu sbcl scl) (declare (ignore type))
+ #+(or cmu scl) `(alien:deref ,obj ,i)
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
#+mcl
(let* ((array-type (array-type type))
#+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
#+mcl
(let* ((array-type (array-type type))
`(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
#+lispworks
`(fli:define-c-union ,name ,@(process-struct-fields name fields))
`(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
#+lispworks
`(fli:define-c-union ,name ,@(process-struct-fields name fields))
`(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
#+sbcl
`(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
#+sbcl
- `(sb-alien:def-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
+ `(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
#+(and mcl (not openmcl))
`(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
#+openmcl