From: Kevin M. Rosenberg Date: Wed, 10 May 2006 00:42:59 +0000 (+0000) Subject: r10934: 2006-05-11 Kevin Rosenberg (kevin@rosenberg.net) X-Git-Tag: v1.6.1~26 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=996ef9dcf5bf917a6a0e977a23b9cafb522c107c r10934: 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 --- diff --git a/ChangeLog b/ChangeLog index df73e44..3a13943 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,12 @@ +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 diff --git a/debian/changelog b/debian/changelog index c0d6623..f1048b8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.5.11-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Tue, 9 May 2006 09:33:59 -0600 + cl-uffi (1.5.10-1) unstable; urgency=low * New upstream diff --git a/src/objects.lisp b/src/objects.lisp index f777f3c..42a5af3 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -24,12 +24,12 @@ #+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." @@ -130,7 +130,7 @@ 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 @@ -152,7 +152,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+allegro obj #+(or openmcl digitool) - `(ccl:%ptr-to-int ,obj) + `(ccl:%ptr-to-int ,obj) ) ;; TYPE is evaluated. @@ -209,10 +209,10 @@ an array of TYPE with size SIZE. The TYPE parameter 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 @@ -243,7 +243,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (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) @@ -278,3 +278,13 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." `(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)) diff --git a/src/package.lisp b/src/package.lisp index 963a16e..bdce95b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -15,14 +15,14 @@ (defpackage #:uffi (:use #:cl) - (:export - + (:export + ;; immediate types #:def-constant #:def-foreign-type #:def-type #:null-char-p - + ;; aggregate types #:def-enum #:def-struct @@ -31,7 +31,7 @@ #:def-array-pointer #:deref-array #:def-union - + ;; objects #:allocate-foreign-object #:free-foreign-object @@ -52,7 +52,8 @@ #:with-cast-pointer #:def-foreign-var #:convert-from-foreign-usb8 - + #:def-pointer-var + ;; string functions #:convert-from-cstring #:convert-to-cstring @@ -65,7 +66,7 @@ #:with-foreign-string #:with-foreign-strings #:foreign-string-length - + ;; function call #:def-function diff --git a/src/strings.lisp b/src/strings.lisp index 69f1f02..f41113b 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -15,7 +15,7 @@ (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)) @@ -26,13 +26,13 @@ "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) @@ -74,7 +74,7 @@ that LW/CMU automatically converts strings from c-calls." (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))) @@ -107,7 +107,7 @@ that LW/CMU automatically converts strings from c-calls." `(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 @@ -123,7 +123,7 @@ that LW/CMU automatically converts strings from c-calls." (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)) @@ -144,7 +144,7 @@ that LW/CMU automatically converts strings from c-calls." (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)) @@ -182,7 +182,7 @@ that LW/CMU automatically converts strings from c-calls." (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 @@ -192,7 +192,7 @@ that LW/CMU automatically converts strings from c-calls." 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 @@ -234,27 +234,27 @@ that LW/CMU automatically converts strings from c-calls." #+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 @@ -398,7 +398,7 @@ that LW/CMU automatically converts strings from c-calls." (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)