Version 1.8.4: Impoved detection of long-long type for CMUCL

[uffi.git] / src / i18n.lisp

diff --git a/src/i18n.lisp b/src/i18n.lisp
index 1d5ec0ab082b6c1490d1b54a5bfcab15a48b3e7b..1d6a485145458426532d4d568d079cd9bcf5d5cd 100644 (file)
--- a/src/i18n.lisp
+++ b/src/i18n.lisp
@@ -18,13 +18,13 @@
       (and openmcl openmcl-unicode-strings))
 (pushnew 'no-i18n cl:*features*)
 
       (and openmcl openmcl-unicode-strings))
 (pushnew 'no-i18n cl:*features*)
 

-(defvar *default-external-format*
+(defvar *default-foreign-encoding*

   nil
   "Normalized name of default external character format to use
 for foreign string conversions. nil means use implementation default
 encoding.")
 
   nil
   "Normalized name of default external character format to use
 for foreign string conversions. nil means use implementation default
 encoding.")
 

-(defvar *external-format-mapping*
+(defvar *foreign-encoding-mapping*

     #+(and lispworks unicode)
     '((:ascii . :ascii) (:latin-1 . :latin-1) (:ucs-2 . :unicode)
       (:utf-8 . :utf-8) (:jis . :jis) (:sjis . :sjis) (:gbk . :gbk))
     #+(and lispworks unicode)
     '((:ascii . :ascii) (:latin-1 . :latin-1) (:ucs-2 . :unicode)
       (:utf-8 . :utf-8) (:jis . :jis) (:sjis . :sjis) (:gbk . :gbk))


@@ -51,9 +51,106 @@ encoding.")
     nil
   "Mapping between normalized external format name and implementation name.")
 
     nil
   "Mapping between normalized external format name and implementation name.")
 

-(defvar *external-formats*
-  (mapcar 'car *external-format-mapping*)
+(defvar *foreign-encodings*
+  (mapcar 'car *foreign-encoding-mapping*)

   "List of normalized names of external formats support by underlying implementation.")
 
   "List of normalized names of external formats support by underlying implementation.")
 

-(defun map-normalized-external-format (normalized)
-  (cdr (assoc normalized *external-format-mapping* :test 'eql)))
+(defun lookup-foreign-encoding (normalized)
+  (cdr (assoc normalized *foreign-encoding-mapping* :test 'eql)))
+
+(defmacro string-to-octets (str &key (encoding *default-foreign-encoding*))
+  "Converts a Lisp string to a vector of octets."
+  (declare (ignorable encoding))
+  #-(or allegro lispworks openmcl sbcl)
+  (map-into (make-array (length str) :element-type '(unsigned-byte 8))
+            #'char-code str)
+
+  #+allegro
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (s (gensym "STR-")))
+    `(let* ((,fe ,encoding)
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,s ,str))
+       (values
+        (if ,ife
+            (excl:string-to-octets ,s :external-format ,ife :null-terminate nil)
+            (excl:string-to-octets ,s :null-terminate nil)))))
+
+  #+(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 (length str) :element-type '(unsigned-byte 8))
+            #'char-code str)
+
+  #+sbcl
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (s (gensym "STR-")))
+    `(let* ((,fe ,encoding)
+            (,ife (when ,fe (lookup-foreign-encoding ,fe)))
+            (,s ,str))
+       (if ,ife
+           (sb-ext:string-to-octets ,s :external-format ,ife)
+           (sb-ext:string-to-octets ,s))))
+
+)
+
+(defmacro octets-to-string (octets &key (encoding *default-foreign-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 ,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
+  (let ((fe (gensym "FE-"))
+        (ife (gensym "IFE-"))
+        (oct (gensym "OCTETS-")))
+    `(let* ((,fe ,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 *default-foreign-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 encoding))
+
+  #-(or (and allegro ics) (and sbcl sb-unicode) (and clisp i18n))
+  (length str)
+
+)