X-Git-Url: http://git.kpe.io/?p=uffi.git;a=blobdiff_plain;f=src%2Fi18n.lisp;h=2de8234f9f659cdef49de31608428368801caca9;hp=08c16ad0b54eb962721764deaa4eea9c4a34feaa;hb=64ab5edeb7412c897f089b7765bec5f24f981b47;hpb=3044928889785c0160fd021a51fbf86ad691a3a9

diff --git a/src/i18n.lisp b/src/i18n.lisp
index 08c16ad..2de8234 100644
--- a/src/i18n.lisp
+++ b/src/i18n.lisp
@@ -55,42 +55,115 @@ encoding.")
   (mapcar 'car *foreign-encoding-mapping*)
   "List of normalized names of external formats support by underlying implementation.")
 
-(defun implementation-foreign-encoding (normalized)
+(defun lookup-foreign-encoding (normalized)
   (cdr (assoc normalized *foreign-encoding-mapping* :test 'eql)))
 
-(defun foreign-encoded-string-octets (str &key foreign-encoding)
-  "Returns the octets required to represent the string when passed to a ~
-foreign function."
-  ;; AllegroCL, CCL, and Lispworks give correct value without converting
-  ;; to external-format. CLISP, like SBCL, requires conversion with external-
-  ;; format
-  (length #+(and sbcl sb-unicode)
-          (sb-ext:string-to-octets
-           str
-           :external-format (or foreign-encoding
-                                *default-foreign-encoding*
-                                :utf-8))
-          #-(and sbcl sb-unicode) str))
-
-(defun string-to-octets (str &key foreign-encoding)
-  "Converts a Lisp string to a vector of octets."
-  #-(or allegro lispworks openmcl sbcl)
-  (declare (ignore foreign-encoding))
+(defmacro string-to-octets (str &key encoding null-terminate)
+  (declare (ignorable encoding))
   #-(or allegro lispworks openmcl sbcl)
-  (map-into (make-array len :element-type '(unsigned-byte 8))
+  (map-into (make-array (length str) :element-type '(unsigned-byte 8))
             #'char-code str)
 
   #+allegro
-  (excl:string-to-native str :external-format foreign-encoding :null-terminate nil)
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (s (gensym "STR-"))
+        (nt (gensym "NT-")))
+    `(let* ((,fe (or ,encoding *default-foreign-encoding*))
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,s ,str)
+            (,nt ,null-terminate))
+       (values
+        (if ,ife
+            (excl:string-to-octets ,s :external-format ,ife :null-terminate ,nt)
+            (excl:string-to-octets ,s :null-terminate ,nt)))))
 
   #+(or lispworks openmcl)
   ;; simply reading each char-code from the LENGTH of string handles multibyte characters
   ;; just fine in testing LW 6.0 and CCL 1.4
-  (map-into (make-array len :element-type '(unsigned-byte 8))
-            #'char-code str)
+  (let ((len (gensym "LEN-"))
+        (out (gensym "OUT-")))
+    `(let ((,len (length ,str)))
+       (if (,null-terminate)
+           (progn
+             (let ((,out (map-into (make-array (1+ ,len) :element-type '(unsigned-byte 8))
+                                   #'char-code ,str)))
+               (setf (char ,out ,len) 0)
+               ,out))
+           (map-into (make-array len :element-type '(unsigned-byte 8))
+                     #'char-code str))))
+
+  #+sbcl
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (s (gensym "STR-"))
+        (nt (gensym "NT-")))
+    `(let* ((,fe (or ,encoding *default-foreign-encoding*))
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,s ,str)
+            (,nt ,null-terminate))
+       (if ,ife
+           (sb-ext:string-to-octets ,s :external-format ,ife :null-terminate ,nt)
+           (sb-ext:string-to-octets ,s :null-terminate ,nt))))
+
+)
+
+(defmacro octets-to-string (octets &key encoding)
+  "Converts a vector of octets to a Lisp string."
+  (declare (ignorable encoding))
+  #-(or allegro lispworks openmcl sbcl)
+  (let ((out (gensym "OUT-"))
+        (code (gensym "CODE-")))
+    `(with-output-to-string (,out)
+       (loop for ,code across ,octets
+          do (write-char (code-char ,code) ,out))))
+
+  #+allegro
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (oct (gensym "OCTETS-")))
+    `(let* ((,fe (or ,encoding *default-foreign-encoding*))
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,oct ,octets))
+       (values
+        (if ,ife
+            (excl:octets-to-string ,oct :external-format ,ife)
+            (excl:octets-to-string ,oct)))))
+
+  #+(or lispworks openmcl)
+  ;; With LW 6.0 and CCL 1.4, writing multibyte character just one octet at a time tests fine
+  (let ((out (gensym "OUT-"))
+        (code (gensym "CODE-")))
+    `(with-output-to-string (,out)
+       (loop for ,code across ,octets
+          do (write-char (code-char ,code) ,out))))
 
   #+sbcl
-  (sb-ext:string-to-native str :external-format foreign-encoding)
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (oct (gensym "OCTETS-")))
+    `(let* ((,fe (or ,encoding *default-foreign-encoding*))
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,oct ,octets))
+       (if ,ife
+           (sb-ext:octets-to-string ,oct :external-format ,ife)
+           (sb-ext:octets-to-string ,oct))))
 
 )
 
+(defun foreign-encoded-octet-count (str &key encoding)
+  "Returns the octets required to represent the string when passed to a ~
+foreign function."
+  (declare (ignorable encoding))
+  ;; AllegroCL 8-bit, CCL, and Lispworks give correct value without converting
+  ;; to external-format. AllegroCL 16-bit, SBCL, and CLISP requires conversion
+  ;; with external-format
+
+  #+(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
+  (length (string-to-octets str :encoding
+                            (or encoding *default-foreign-encoding*)))
+
+  #-(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
+  (length str)
+
+)