+2006-05-11 Kevin Rosenberg (kevin@rosenberg.net)
+ * Version 1.5.11: Export new macro DEF-POINTER-VAR based on patch from
+ James Bielman to support defining variables on platforms which
+ support saving objects, such as openmcl
+
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
+cl-uffi (1.5.11-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Tue, 9 May 2006 09:33:59 -0600
+
cl-uffi (1.5.10-1) unstable; urgency=low
* New upstream
#+clisp (values (ffi:size-of type))
#+digitool
(let ((mcl-type (ccl:find-mactype type nil t)))
- (if mcl-type
+ (if mcl-type
(ccl::mactype-record-size mcl-type)
(ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
#+openmcl (ccl::%foreign-type-or-record-size type :bytes)
))
-
+
(defmacro allocate-foreign-object (type &optional (size :unspecified))
"Allocates an instance of TYPE. If size is specified, then allocate
an array of TYPE with size SIZE. The TYPE parameter is evaluated."
#+(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 digitool) `(char-code ,obj)
#+(or allegro cmu sbcl scl openmcl) obj
#+allegro
obj
#+(or openmcl digitool)
- `(ccl:%ptr-to-int ,obj)
+ `(ccl:%ptr-to-int ,obj)
)
;; TYPE is evaluated.
(setf type (nth 1 type)))
(push (list (first spec) (* count (size-of-foreign-type type))) params))
`(ccl:%stack-block ,params ,@body)))
-
+
#+(or openmcl digitool)
(defmacro with-foreign-object ((var type) &rest body)
- `(with-foreign-objects ((,var ,type))
+ `(with-foreign-objects ((,var ,type))
,@body))
#+lispworks
(lisp-implementation-type)))
#+(or allegro openmcl)
-(defun convert-external-name (name)
+(defun convert-external-name (name)
"Add an underscore to NAME if necessary for the ABI."
#+(or macosx darwinppc-target) (concatenate 'string "_" name)
#-(or macosx darwinppc-target) name)
`(define-symbol-macro ,lisp-name
'(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
(lisp-implementation-type)))))
+
+
+;;; Define a special variable, like DEFVAR, that will be initialized
+;;; to a pointer which may need to be reset when a saved image is
+;;; loaded. This is needed for OpenMCL, which sets pointers to "dead
+;;; macptrs" when a saved image is loaded.
+;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE
+(defmacro def-pointer-var (name value &optional doc)
+ #-openmcl `(defvar ,name ,value ,doc)
+ #+openmcl `(ccl::defloadvar ,name ,value ,doc))
(defpackage #:uffi
(:use #:cl)
- (:export
-
+ (:export
+
;; immediate types
#:def-constant
#:def-foreign-type
#:def-type
#:null-char-p
-
+
;; aggregate types
#:def-enum
#:def-struct
#:def-array-pointer
#:deref-array
#:def-union
-
+
;; objects
#:allocate-foreign-object
#:free-foreign-object
#:with-cast-pointer
#:def-foreign-var
#:convert-from-foreign-usb8
-
+ #:def-pointer-var
+
;; string functions
#:convert-from-cstring
#:convert-to-cstring
#:with-foreign-string
#:with-foreign-strings
#:foreign-string-length
-
+
;; function call
#:def-function
(in-package #:uffi)
-(defvar +null-cstring-pointer+
+(def-pointer-var +null-cstring-pointer+
#+(or cmu sbcl scl) nil
#+allegro 0
#+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
"Converts a string from a c-call. Same as convert-from-foreign-string, except
that LW/CMU automatically converts strings from c-calls."
#+(or cmu sbcl lispworks scl) obj
- #+allegro
+ #+allegro
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (zerop ,stored)
nil
(values (excl:native-to-string ,stored)))))
- #+(or openmcl digitool)
+ #+(or openmcl digitool)
(let ((stored (gensym)))
`(let ((,stored ,obj))
(if (ccl:%null-ptr-p ,stored)
(defmacro with-cstring ((cstring lisp-string) &body body)
#+(or cmu sbcl scl lispworks)
- `(let ((,cstring ,lisp-string)) ,@body)
+ `(let ((,cstring ,lisp-string)) ,@body)
#+allegro
(let ((acl-native (gensym))
(stored-lisp-string (gensym)))
`(let ((,stored ,obj))
(if (null ,stored)
+null-cstring-pointer+
- (fli:convert-to-foreign-string
+ (fli:convert-to-foreign-string
,stored
:external-format '(:latin-1 :eol-style :lf)))))
#+allegro
(i (gensym)))
`(let ((,stored-obj ,obj))
(etypecase ,stored-obj
- (null
+ (null
(alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
(string
(let* ((,size (length ,stored-obj))
(i (gensym)))
`(let ((,stored-obj ,obj))
(etypecase ,stored-obj
- (null
+ (null
(sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
(string
(let* ((,size (length ,stored-obj))
(fast-native-to-string ,stored-obj ,length)
(values
(excl:native-to-string
- ,stored-obj
+ ,stored-obj
,@(when length (list :length length))
:truncate (not ,null-terminated-p)))))))
#+lispworks
nil
(if (eq ,locale :none)
(fast-native-to-string ,stored-obj ,length)
- (fli:convert-from-foreign-string
+ (fli:convert-from-foreign-string
,stored-obj
,@(when length (list :length length))
:null-terminated-p ,null-terminated-p
#+ignore
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
- (eval `(alien:cast (alien:make-alien ,,array-def)
- ,(if ,unsigned
+ (eval `(alien:cast (alien:make-alien ,,array-def)
+ ,(if ,unsigned
'(* (alien:unsigned 8))
'(* (alien:signed 8)))))))
#+(or cmu scl)
- `(alien:make-alien ,(if unsigned
+ `(alien:make-alien ,(if unsigned
'(alien:unsigned 8)
'(alien:signed 8))
,size)
#+sbcl
- `(sb-alien:make-alien ,(if unsigned
+ `(sb-alien:make-alien ,(if unsigned
'(sb-alien:unsigned 8)
'(sb-alien:signed 8))
,size)
#+lispworks
- `(fli:allocate-foreign-object :type
- ,(if unsigned
- ''(:unsigned :char)
+ `(fli:allocate-foreign-object :type
+ ,(if unsigned
+ ''(:unsigned :char)
:char)
:nelems ,size)
#+allegro
(declare (fixnum len)
(type (simple-array (signed-byte 8) (*)) str))
(dotimes (i len str)
- (setf (aref str i)
+ (setf (aref str i)
(uffi:deref-array s '(:array :char) i)))))
#+(and allegro ics)
projects / uffi.git / commitdiff