Initial support for external-formats for encoding foreign strings

[uffi.git] / src / strings.lisp

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))))))))
   )