+2004-04-15 Kevin Rosenberg (kevin@rosenberg.net)
+ * src/objects.lisp: Add new functions:
+ MAKE-POINTER and POINTER-ADDRESS
+
2004-04-13 Kevin Rosenberg (kevin@rosenberg.net)
- * str/string.lisp: Add new FOREIGN-STRING-LENGTH
+ * src/string.lisp: Add new FOREIGN-STRING-LENGTH
2003-08-15 Kevin Rosenberg (kevin@rosenberg.net)
* Added with-cast-pointer and def-foreign-var (patches submitted
+cl-uffi (1.4.10-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 15 Apr 2004 01:59:37 -0600
+
cl-uffi (1.4.9-1) unstable; urgency=low
* New upstream
))
-(defun make-lisp-name (name)
- (let ((converted (substitute #\- #\_ name)))
- (intern
- #+case-sensitive converted
- #-case-sensitive (string-upcase converted))))
#+mcl `(ccl:%null-ptr)
)
+(defmacro make-pointer (addr type)
+ #+(or allegro mcl) (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
+ #+mcl `(ccl:%int-to-ptr addr)
+ )
+
+(defmacro pointer-address (ptr)
+ #+allegro ptr
+ #+(or cmu scl) `(system:sap-int (alien:alien-sap ,ptr))
+ #+sbcl `(sb-sys:sap-int (sb-alien:alien-sap ,ptr))
+ #+lispworks `(fli:pointer-address ,ptr)
+ #+mcl `(ccl:%ptr-to-int ,ptr))
+
(defmacro char-array-to-pointer (obj)
#+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
#+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
#:ensure-char-integer
#:null-pointer-p
#:make-null-pointer
+ #:make-pointer
+ #:pointer-address
#:+null-cstring-pointer+
#:char-array-to-pointer
#:with-cast-pointer
(make-hash-table :size 20 :test #'eq))
)
-#+(or cmu sbcl scl)
-(defvar *cmu-sbcl-def-type-list* nil)
-
#+(or cmu scl)
(defvar *cmu-sbcl-def-type-list*
'((:char . (alien:signed 8))
(:unsigned-long . (alien:unsigned 32))
(:float . alien:single-float)
(:double . alien:double-float)
+ (:void . t)
)
"Conversions in CMUCL for def-foreign-type are different than in def-function")
+
#+sbcl
(defvar *cmu-sbcl-def-type-list*
'((:char . (sb-alien:signed 8))
(:unsigned-long . (sb-alien:unsigned 32))
(:float . sb-alien:single-float)
(:double . sb-alien:double-float)
+ (:void . t)
)
"Conversions in SBCL for def-foreign-type are different than in def-function")
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))
+
+(defun make-lisp-name (name)
+ (let ((converted (substitute #\- #\_ name)))
+ (intern
+ #+case-sensitive converted
+ #-case-sensitive (string-upcase converted))))
(defmacro allocate-foreign-string (size &key (unsigned t))
- #+(or cmu scl)
+ #+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
'(* (alien:unsigned 8))
'(* (alien:signed 8)))))))
+
+ #+(or cmu scl)
+ `(alien:make-alien ,(if unsigned
+ '(alien:unsigned 8)
+ '(alien:signed 8))
+ ,size)
+
#+sbcl
- (let ((array-def (gensym)))
- `(let ((,array-def (list 'sb-alien:array 'char ,size)))
- (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def)
- ,(if ,unsigned
- '(* (sb-alien:unsigned 8))
- '(* (sb-alien:signed 8)))))))
+ `(sb-alien:make-alien ,(if unsigned
+ '(sb-alien:unsigned 8)
+ '(sb-alien:signed 8))
+ ,size)
+
#+lispworks
`(fli:allocate-foreign-object :type
,(if unsigned
#+allegro `(ff:foreign-strlen ,foreign-string)
#-allegro
`(loop with size = 0
- until (char= (deref-array ,ptr '(:array :unsigned-char) size) #\Null)
+ until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
do (incf size)
finally return size))