Initial support for external-formats for encoding foreign strings

diff --git a/ChangeLog b/ChangeLog
index 3b306f61355eb53fbc7a8660fc81d5c1b01b0a8d..70759801f1cec057292aa9827caf0b098b92580b 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2010-02-06 Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 1.7.4
+       * src/strings.lisp: Initial support for external-formats with
+       foreign strings.
+       
 2010-02-05 Kevin Rosenberg <kevin@rosenberg.net>
        * Version 1.7.3
        * src/primitives.lisp: Fix symbol name

diff --git a/debian/changelog b/debian/changelog
index 459a601fa52c53ba8bd9a6b9fd8b38da5dd36139..76140a93c46edcd4d205734e792de24dd8f5520e 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.7.4-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  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 a42944451c627f8c14e2a49636de5cfa933ff9db..1d5ec0ab082b6c1490d1b54a5bfcab15a48b3e7b 100644 (file)
--- 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 9bd3d25f2a38b496a690c0d13dd8cb01f425867b..b6cd204e22b8145fa69e637395214fc76eb14175 100644 (file)
--- 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 3905004cf02909af262f754d5fda90fc0575481f..e1b57d08b84afa441a52ef5eb72bd31e05db5839 100644 (file)
--- 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))))))))
   )