X-Git-Url: http://git.kpe.io/?p=uffi.git;a=blobdiff_plain;f=src%2Fstrings.lisp;h=e1b57d08b84afa441a52ef5eb72bd31e05db5839;hp=3905004cf02909af262f754d5fda90fc0575481f;hb=27073cc090c29aa5dcf9ed9becdf3e73b937b0bb;hpb=52cbd471d05ae817c0f19aa01e0880233a06f630 diff --git a/src/strings.lisp b/src/strings.lisp index 3905004..e1b57d0 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -29,7 +29,14 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored ,obj)) (if (zerop ,stored) nil - (values (excl:native-to-string ,stored))))) + (values + (excl:native-to-string + ,stored + :external-format + (if *default-external-format* + (map-normalized-external-format + *default-external-format*) + :default)))))) #+(or openmcl digitool) (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -45,7 +52,13 @@ that LW/CMU automatically converts strings from c-calls." `(let ((,stored ,obj)) (if (null ,stored) 0 - (values (excl:string-to-native ,stored))))) + (values (excl:string-to-native + ,stored + :external-format + (if *default-external-format* + (map-normalized-external-format + *default-external-format*) + :default)))))) #+(or openmcl digitool) (let ((stored (gensym))) `(let ((,stored ,obj)) @@ -77,14 +90,21 @@ that LW/CMU automatically converts strings from c-calls." (let ((acl-native (gensym)) (stored-lisp-string (gensym))) `(let ((,stored-lisp-string ,lisp-string)) - (excl:with-native-string (,acl-native ,stored-lisp-string) + (excl:with-native-string (,acl-native ,stored-lisp-string + :external-format + (if *default-external-format* + (map-normalized-external-format + *default-external-format*) + :default)) (let ((,cstring (if ,stored-lisp-string ,acl-native 0))) ,@body)))) #+(or openmcl digitool) (let ((stored-lisp-string (gensym))) `(let ((,stored-lisp-string ,lisp-string)) (if (stringp ,stored-lisp-string) - (ccl:with-cstrs ((,cstring ,stored-lisp-string)) + (ccl:with-encoded-cstrs + (or *default-external-format* :iso-8859-1) + ((,cstring ,stored-lisp-string)) ,@body) (let ((,cstring +null-cstring-pointer+)) ,@body)))) @@ -99,21 +119,28 @@ that LW/CMU automatically converts strings from c-calls." ;;; Foreign string functions -(defmacro convert-to-foreign-string (obj) +(defmacro convert-to-foreign-string (obj &optional external-format) #+lispworks - (let ((stored (gensym))) - `(let ((,stored ,obj)) + (let ((stored (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored ,obj) + (,ef (map-normalized-external-format + (or external-format *default-external-format*)))) (if (null ,stored) +null-cstring-pointer+ (fli:convert-to-foreign-string ,stored - :external-format '(:latin-1 :eol-style :lf))))) + :external-format ,ef)))) #+allegro - (let ((stored (gensym))) - `(let ((,stored ,obj)) + (let ((stored (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored ,obj) + (,ef (map-normalized-external-format + (or external-format *default-external-format*)))) (if (null ,stored) 0 - (values (excl:string-to-native ,stored))))) + (values (excl:string-to-native ,stored :external-format + (or ,ef :default)))))) #+(or cmu scl) (let ((size (gensym)) (storage (gensym)) @@ -168,33 +195,40 @@ that LW/CMU automatically converts strings from c-calls." ;; Either length or null-terminated-p must be non-nil (defmacro convert-from-foreign-string (obj &key - length - (locale :default) - (null-terminated-p t)) + length + external-format + (null-terminated-p t)) #+allegro - (let ((stored-obj (gensym))) - `(let ((,stored-obj ,obj)) + (let ((stored-obj (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored-obj ,obj) + (,ef (map-normalized-external-format + (or ,external-format *default-external-format*)))) (if (zerop ,stored-obj) nil - (if (eq ,locale :none) - (fast-native-to-string ,stored-obj ,length) + (if ,ef (values (excl:native-to-string ,stored-obj ,@(when length (list :length length)) - :truncate (not ,null-terminated-p))))))) + :truncate (not ,null-terminated-p) + :external-format ,ef)) + (fast-native-to-string ,stored-obj ,length))))) #+lispworks - (let ((stored-obj (gensym))) - `(let ((,stored-obj ,obj)) + (let ((stored-obj (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored-obj ,obj) + (,ef (map-normalized-external-format + (or ,external-format *default-external-format*)))) (if (fli:null-pointer-p ,stored-obj) nil - (if (eq ,locale :none) - (fast-native-to-string ,stored-obj ,length) + (if ,ef (fli:convert-from-foreign-string ,stored-obj ,@(when length (list :length length)) :null-terminated-p ,null-terminated-p - :external-format '(:latin-1 :eol-style :lf)))))) + :external-format (list ,ef)) + (fast-native-to-string ,stored-obj ,length))))) #+(or cmu scl) (let ((stored-obj (gensym))) `(let ((,stored-obj ,obj)) @@ -205,26 +239,41 @@ that LW/CMU automatically converts strings from c-calls." :null-terminated-p ,null-terminated-p)))) #+sbcl - (let ((stored-obj (gensym))) - `(let ((,stored-obj ,obj)) + (let ((stored-obj (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored-obj ,obj) + (,ef (map-normalized-external-format + (or ,external-format *default-external-format*)))) (if (null-pointer-p ,stored-obj) nil - (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj) - :length ,length - :null-terminated-p ,null-terminated-p)))) + (if ,ef + (sb-alien::c-string-to-string (sb-alien:alien-sap ,stored-obj) + ,ef 'character) + (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj) + :length ,length + :null-terminated-p ,null-terminated-p))))) #+(or openmcl digitool) (declare (ignore null-terminated-p)) #+(or openmcl digitool) - (let ((stored-obj (gensym))) - `(let ((,stored-obj ,obj)) + (let ((stored-obj (gensym "STR-")) + (ef (gensym "EF-"))) + `(let ((,stored-obj ,obj) + (,ef (map-normalized-external-format + (or ,external-format *default-external-format*)))) (if (ccl:%null-ptr-p ,stored-obj) nil #+digitool (ccl:%get-cstring ,stored-obj 0 ,@(if length (list length) nil)) - #+openmcl ,@(if length - `((ccl:%str-from-ptr ,stored-obj ,length)) - `((ccl:%get-cstring ,stored-obj)))))) + #+openmcl (case ,ef + (:utf-8 + (ccl::%get-utf-8-cstring ,stored-obj)) + (:ucs-2 + (ccl::%get-native-utf-16-cstring ,stored-obj)) + (t + ,@(if length + `((ccl:%str-from-ptr ,stored-obj ,length)) + `((ccl:%get-cstring ,stored-obj)))))))) )