X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=0bdeeabe277a0338f6c37bd2439de584da76e39d;hb=895cdddc64ad069c4d8173a21d0d5ce47b79e919;hp=1e90118c174e8a10f25dda0f06224d533a7c1ff3;hpb=87acde9ae931ba8ac7bd486809f6dab3b2448790;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index 1e90118..0bdeeab 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -9,34 +9,30 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; UFFI users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg ;;;; ************************************************************************* (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)) - #+mcl (ccl:%null-ptr) + #+(or openmcl digitool) (ccl:%null-ptr) ) (defmacro convert-from-cstring (obj) "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))))) - #+mcl + #+(or openmcl digitool) (let ((stored (gensym))) `(let ((,stored ,obj)) (if (ccl:%null-ptr-p ,stored) @@ -52,7 +48,7 @@ that LW/CMU automatically converts strings from c-calls." (if (null ,stored) 0 (values (excl:string-to-native ,stored))))) - #+mcl + #+(or openmcl digitool) (let ((stored (gensym))) `(let ((,stored ,obj)) (if (null ,stored) @@ -69,7 +65,7 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored ,obj)) (unless (zerop ,stored) (ff:free-fobject ,stored)))) - #+mcl + #+(or openmcl digitool) (let ((stored (gensym))) `(let ((,stored ,obj)) (unless (ccl:%null-ptr-p ,stored) @@ -78,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))) @@ -86,7 +82,7 @@ that LW/CMU automatically converts strings from c-calls." (excl:with-native-string (,acl-native ,stored-lisp-string) (let ((,cstring (if ,stored-lisp-string ,acl-native 0))) ,@body)))) - #+mcl + #+(or openmcl digitool) (let ((stored-lisp-string (gensym))) `(let ((,stored-lisp-string ,lisp-string)) (if (stringp ,stored-lisp-string) @@ -109,11 +105,11 @@ that LW/CMU automatically converts strings from c-calls." #+lispworks (let ((stored (gensym))) `(let ((,stored ,obj)) - `(if (null ,stored) - +null-cstring-pointer+ - (fli:convert-to-foreign-string - ,stored - :external-format '(:latin-1 :eol-style :lf))))) + (if (null ,stored) + +null-cstring-pointer+ + (fli:convert-to-foreign-string + ,stored + :external-format '(:latin-1 :eol-style :lf))))) #+allegro (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -127,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)) @@ -148,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)) @@ -162,7 +158,7 @@ that LW/CMU automatically converts strings from c-calls." (char-code (char ,stored-obj ,i)))) (setf (sb-alien:deref ,storage ,size) 0)) ,storage))))) - #+mcl + #+(or openmcl digitool) (let ((stored-obj (gensym))) `(let ((,stored-obj ,obj)) (if (null ,stored-obj) @@ -186,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 @@ -196,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 @@ -218,14 +214,14 @@ that LW/CMU automatically converts strings from c-calls." (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj) :length ,length :null-terminated-p ,null-terminated-p)))) - #+mcl + #+(or openmcl digitool) (declare (ignore null-terminated-p)) - #+mcl + #+(or openmcl digitool) (let ((stored-obj (gensym))) `(let ((,stored-obj ,obj)) (if (ccl:%null-ptr-p ,stored-obj) nil - #+(and mcl (not openmcl)) (ccl:%get-cstring + #+digitool (ccl:%get-cstring ,stored-obj 0 ,@(if length (list length) nil)) #+openmcl ,@(if length @@ -238,36 +234,36 @@ 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 (declare (ignore unsigned)) #+allegro `(ff:allocate-fobject :char :c ,size) - #+mcl + #+(or openmcl digitool) (declare (ignore unsigned)) - #+mcl + #+(or openmcl digitool) `(new-ptr ,size) ) @@ -288,6 +284,11 @@ that LW/CMU automatically converts strings from c-calls." (free-foreign-object ,foreign-string) ,result))) +(defmacro with-foreign-strings (bindings &body body) + `(with-foreign-string ,(car bindings) + ,@(if (cdr bindings) + `((with-foreign-strings ,(cdr bindings) ,@body)) + body))) ;; Modified from CMUCL's source to handle non-null terminated strings #+cmu @@ -388,19 +389,20 @@ that LW/CMU automatically converts strings from c-calls." (def-type char-ptr-def (* :unsigned-char)) -#+(or lispworks (and allegro (not ics))) +#+(or (and allegro (not ics)) (and lispworks (not lispworks5))) (defun fast-native-to-string (s len) (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) (type char-ptr-def s)) (let* ((len (or len (strlen s))) (str (make-string len))) (declare (fixnum len) - (type (simple-array (signed-byte 8) (*)) str)) + (type (simple-array #+lispworks base-char + #-lispworks (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) +#+(or (and allegro ics) lispworks5) (defun fast-native-to-string (s len) (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) (type char-ptr-def s))