X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=430d8ab48d15c1b29c988108570867b41e487b89;hb=a63da5b764b6fa30e32fcda4ddac88de385c9d5b;hp=209116428cce7e905c1210de6dc72675ab7c014e;hpb=2bb9a36070147d6c21e4a99d699ec3563c021a70;p=uffi.git diff --git a/src/strings.lisp b/src/strings.lisp index 2091164..430d8ab 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -57,7 +57,7 @@ that LW/CMU automatically converts strings from c-calls." ) (defmacro free-cstring (obj) - #+(or cmu sbcl scl lispworks) (declare (ignore obj)) + (declare (ignorable obj)) #+allegro (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -99,7 +99,8 @@ that LW/CMU automatically converts strings from c-calls." ;;; Foreign string functions -(defun %convert-to-foreign-string (str foreign-encoding) +(defun %convert-to-foreign-string (str encoding) + (declare (ignorable str encoding)) #+(or cmu scl) (etypecase str (null @@ -114,25 +115,25 @@ that LW/CMU automatically converts strings from c-calls." (dotimes (i size) (declare (fixnum i)) (setf (alien:deref storage i) - (char-code (char stored-obj i)))) - (setf (alien:deref storage size) 0)) - storage))) + (char-code (char str i)))) + (setf (alien:deref storage size) 0) + storage)))) #+(and sbcl (not sb-unicode)) - (etypecase stored-obj + (etypecase str (null (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8)))) (string (locally (declare (optimize (speed 3) (safety 0))) - (let* ((size (length stored-obj)) + (let* ((size (length str)) (storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size)))) (declare (fixnum i)) (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8)))) (dotimes (i size) (declare (fixnum i)) (setf (sb-alien:deref storage i) - (char-code (char stored-obj i)))) + (char-code (char str i)))) (setf (sb-alien:deref storage size) 0)) storage))) @@ -143,8 +144,9 @@ that LW/CMU automatically converts strings from c-calls." (string (locally (declare (optimize (speed 3) (safety 0))) - (let* ((fe (or foreign-encoding *default-foreign-encoding*)) - (ife (when fe (implementation-foreign-encoding fe)))) + (let* ((fe (or encoding *default-foreign-encoding* + sb-impl::*default-external-format*)) + (ife (when fe (lookup-foreign-encoding fe)))) (if ife (let* ((octets (sb-ext:string-to-octets str :external-format ife)) (size (length octets)) @@ -153,7 +155,7 @@ that LW/CMU automatically converts strings from c-calls." (setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8)))) (dotimes (i size) (declare (fixnum i)) - (setf (sb-alien:deref storage i) (svref octets i))) + (setf (sb-alien:deref storage i) (aref octets i))) ;; terminate with 2 nulls, maybe needed for some encodings (setf (sb-alien:deref storage size) 0) (setf (sb-alien:deref storage (1+ size)) 0) @@ -166,7 +168,7 @@ that LW/CMU automatically converts strings from c-calls." (dotimes (i size) (declare (fixnum i)) (setf (sb-alien:deref storage i) - (char-code (char stored-obj i)))) + (char-code (char str i)))) (setf (sb-alien:deref storage size) 0) storage)))))) @@ -175,8 +177,8 @@ that LW/CMU automatically converts strings from c-calls." +null-cstring-pointer+ (locally (declare (optimize (speed 3) (safety 0))) - (let* ((fe (or foreign-encoding *default-foreign-encoding*)) - (ife (when fe (implementation-foreign-encoding fe)))) + (let* ((fe (or encoding *default-foreign-encoding*)) + (ife (when fe (lookup-foreign-encoding fe)))) (if ife (let* ((octets (ccl:encode-string-to-octets str :external-format ife)) (size (length octets)) @@ -201,19 +203,19 @@ that LW/CMU automatically converts strings from c-calls." ptr)) #+(or allegro lispworks) - (declare (ignore str foreign-encoding)) - + nil ) -(defmacro convert-to-foreign-string (obj &optional foreign-encoding) +(defmacro convert-to-foreign-string (obj &optional encoding) + (declare (ignorable encoding)) #+allegro (let ((stored (gensym "STR-")) - (ef (gensym "EF-")) - (nef (gensym "NEF-"))) - `(let ((,stored ,obj) - (,fe (or foreign-encoding *default-foreign-encoding*)) + (fe (gensym "FE-")) + (ife (gensym "IFE-"))) + `(let* ((,stored ,obj) + (,fe (or encoding *default-foreign-encoding*)) (,ife (when ,fe - (implementation-foreign-encoding ,fe)))) + (lookup-foreign-encoding ,fe)))) (cond ((null ,stored) 0) @@ -227,9 +229,9 @@ that LW/CMU automatically converts strings from c-calls." (fe (gensym "EF-")) (ife (gensym "NEF-"))) `(let* ((,stored ,obj) - (,fe (or ,foreign-encoding *default-foreign-encoding*)) + (,fe (or ,encoding *default-foreign-encoding*)) (,ife (when ,fe - (implementation-foreign-encoding ,fe)))) + (lookup-foreign-encoding ,fe)))) (cond ((null ,stored) +null-cstring-pointer+) @@ -239,16 +241,17 @@ that LW/CMU automatically converts strings from c-calls." (fli:convert-to-foreign-string ,stored :external-format ,ife))))) #+(or cmu scl sbcl digitool openmcl) - `(%convert-to-foreign-string ,obj (implementation-foreign-encoding - (or ,foreign-encoding *default-foreign-encoding))) + `(%convert-to-foreign-string ,obj (lookup-foreign-encoding + (or ,encoding *default-foreign-encoding*))) ) ;; Either length or null-terminated-p must be non-nil (defmacro convert-from-foreign-string (obj &key length - foreign-encoding + encoding (null-terminated-p t)) + (declare (ignorable length encoding null-terminated-p)) #+allegro (let ((stored-obj (gensym "STR-")) (fe (gensym "FE-")) @@ -256,8 +259,8 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored-obj ,obj)) (if (zerop ,stored-obj) nil - (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*)) - (,ife (when ,fe (implementation-foreign-encoding ,fe)))) + (let* ((,fe (or ,encoding *default-foreign-encoding*)) + (,ife (when ,fe (lookup-foreign-encoding ,fe)))) (if ,ife (values (excl:native-to-string @@ -268,27 +271,32 @@ that LW/CMU automatically converts strings from c-calls." (fast-native-to-string ,stored-obj ,length)))))) #+lispworks - ;; FAST-NATIVE-TO-STRING (suprisingly) works just fine with UTF-8 multibyte character strings + #| + ;; FAST-NATIVE-TO-STRING (suprisingly) works just fine to make strings + ;; for formatted printing with Lispworks and UTF-8 multibyte character strings. ;; However, without knowledge of specific-encoding, the LENGTH call in FAST-NATIVE-TO-STRING - ;; may not be incorrect for some encodings/strings. + ;; will be be incorrect for some encodings/strings and strings consist of octets rather + ;; than wide characters ;; This is a stop-gap until get tech support on why the below fails. (let ((stored-obj (gensym "STR-"))) `(let ((,stored-obj ,obj)) (if (fli:null-pointer-p ,stored-obj) nil (fast-native-to-string ,stored-obj ,length)))) + |# + #| ;; Below code doesn't work on tesing with LW 6.0 testing with a UTF-8 string. ;; fli:convert-from-foreign-string with :external-format of :UTF-8 doesn't ;; properly code multibyte characters. -#| + |# (let ((stored-obj (gensym "STR-")) (fe (gensym "FE-")) (ife (gensym "IFE-"))) `(let ((,stored-obj ,obj)) (if (fli:null-pointer-p ,stored-obj) nil - (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*)) - (,ife (when ,fe (implementation-foreign-encoding ,fe)))) + (let* ((,fe (or ,encoding *default-foreign-encoding*)) + (,ife (when ,fe (lookup-foreign-encoding ,fe)))) (if ,ife (fli:convert-from-foreign-string ,stored-obj @@ -296,7 +304,6 @@ that LW/CMU automatically converts strings from c-calls." :null-terminated-p ,null-terminated-p :external-format (list ,ife :eol-style :lf)) (fast-native-to-string ,stored-obj ,length)))))) -|# #+(or cmu scl) (let ((stored-obj (gensym))) @@ -322,18 +329,15 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored-obj ,obj)) (if (null-pointer-p ,stored-obj) nil - (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*)) - (,ife (when ,fe (implementation-foreign-encoding ,fe)))) + (let* ((,fe (or ,encoding *default-foreign-encoding*)) + (,ife (when ,fe (lookup-foreign-encoding ,fe)))) (sb-alien::c-string-to-string (sb-alien:alien-sap ,stored-obj) (or ,ife sb-impl::*default-external-format* :latin-1) 'character))))) - #+(or openmcl digitool) - (declare (ignore null-terminated-p)) #+(or openmcl digitool) (let ((stored-obj (gensym "STR-")) - (fe (gensym "FE-")) - (ife (gensym "IFE-"))) + (fe (gensym "FE-"))) `(let ((,stored-obj ,obj)) (if (ccl:%null-ptr-p ,stored-obj) nil @@ -342,7 +346,7 @@ that LW/CMU automatically converts strings from c-calls." ,stored-obj 0 ,@(if length (list length) nil)) #+openmcl - (let ((,fe (or ,foreign-encoding *default-foreign-encoding*))) + (let ((,fe (or ,encoding *default-foreign-encoding*))) (case ,fe (:utf-8 (ccl::%get-utf-8-cstring ,stored-obj)) @@ -356,6 +360,7 @@ that LW/CMU automatically converts strings from c-calls." (defmacro allocate-foreign-string (size &key (unsigned t)) + (declare (ignorable unsigned)) #+ignore (let ((array-def (gensym))) `(let ((,array-def (list 'alien:array 'c-call:char ,size))) @@ -383,29 +388,25 @@ that LW/CMU automatically converts strings from c-calls." :char) :nelems ,size) #+allegro - (declare (ignore unsigned)) - #+allegro `(ff:allocate-fobject :char :c ,size) #+(or openmcl digitool) - (declare (ignore unsigned)) - #+(or openmcl digitool) `(new-ptr ,size) ) (defun foreign-string-length (foreign-string) - #+allegro `(ff:foreign-strlen ,foreign-string) + #+allegro (ff:foreign-strlen foreign-string) #-allegro - `(loop with size = 0 - until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null) - do (incf size) - finally return size)) + (loop + for size from 0 + until (zerop (deref-array foreign-string '(:array :unsigned-char) size)) + finally (return size))) -(defmacro with-foreign-string ((foreign-string lisp-string &optional foreign-encoding) +(defmacro with-foreign-string ((foreign-string lisp-string &optional encoding) &body body) (let ((result (gensym)) (fe (gensym))) - `(let* ((,fe ,foreign-encoding) + `(let* ((,fe ,encoding) (,foreign-string (convert-to-foreign-string ,lisp-string ,fe)) (,result (progn ,@body))) (declare (dynamic-extent ,foreign-string))