From 27073cc090c29aa5dcf9ed9becdf3e73b937b0bb Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Sat, 6 Feb 2010 20:12:21 -0700 Subject: [PATCH] Initial support for external-formats for encoding foreign strings --- ChangeLog | 5 ++ debian/changelog | 6 +++ src/i18n.lisp | 22 +++++---- src/package.lisp | 4 +- src/strings.lisp | 117 +++++++++++++++++++++++++++++++++-------------- 5 files changed, 108 insertions(+), 46 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3b306f6..7075980 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2010-02-06 Kevin Rosenberg + * Version 1.7.4 + * src/strings.lisp: Initial support for external-formats with + foreign strings. + 2010-02-05 Kevin Rosenberg * Version 1.7.3 * src/primitives.lisp: Fix symbol name diff --git a/debian/changelog b/debian/changelog index 459a601..76140a9 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.7.4-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Sat, 06 Feb 2010 20:10:09 -0700 + cl-uffi (1.7.3-1) unstable; urgency=low * New upstream diff --git a/src/i18n.lisp b/src/i18n.lisp index a429444..1d5ec0a 100644 --- a/src/i18n.lisp +++ b/src/i18n.lisp @@ -18,13 +18,13 @@ (and openmcl openmcl-unicode-strings)) (pushnew 'no-i18n cl:*features*) -(defvar *default-external-character-encoding* +(defvar *default-external-format* nil - "Normalized name of default external character encoding to use + "Normalized name of default external character format to use for foreign string conversions. nil means use implementation default encoding.") -(defvar *external-encoding-mapping* +(defvar *external-format-mapping* #+(and lispworks unicode) '((:ascii . :ascii) (:latin-1 . :latin-1) (:ucs-2 . :unicode) (:utf-8 . :utf-8) (:jis . :jis) (:sjis . :sjis) (:gbk . :gbk)) @@ -42,16 +42,18 @@ encoding.") (:gbk . charset:gbk) (:euc-jp . charset:euc-jp)) #+(and openmcl openmcl-unicode-strings) '((:ascii . :ascii) (:latin-1 . :iso-8859-1) (:utf-8 . :utf-8) - (:ucs-2 . :ucs-2) (:euc-jp . :euc-jp)) + (:ucs-2 . :ucs-2) + #+nil (:euc-jp . :euc-jp) + ) #-(or (and lispworks unicode) (and sbcl sb-unicode) (and allegro ics) (and clisp unicode) (and openmcl openmcl-unicode-strings)) nil - "Mapping between normalized external encoding name and implementation name.") + "Mapping between normalized external format name and implementation name.") -(defvar *external-character-encodings* - (mapcar 'car *external-encoding-mapping*) - "List of normalized names of external encodings support by underlying implementation.") +(defvar *external-formats* + (mapcar 'car *external-format-mapping*) + "List of normalized names of external formats support by underlying implementation.") -(defun map-normalized-external-encoding (normalized) - (cdr (assoc normalized *external-encoding-mapping* :test 'eql))) +(defun map-normalized-external-format (normalized) + (cdr (assoc normalized *external-format-mapping* :test 'eql))) diff --git a/src/package.lisp b/src/package.lisp index 9bd3d25..b6cd204 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -83,8 +83,8 @@ ;; Internatialization #:no-i18n - #:*default-external-character-encoding* - #:*external-character-encodings* + #:*default-external-format* + #:*external-formats* )) 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)))))))) ) -- 2.34.1