X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fi18n.lisp;h=a46b5354b01f43c331bb20e54d2c3d7434581363;hb=HEAD;hp=e2d204a33a4eb752220aff41a98f382464bfba01;hpb=f14760717eb60ac01bb854986d9e4ba9eacdf8bc;p=uffi.git diff --git a/src/i18n.lisp b/src/i18n.lisp index e2d204a..a46b535 100644 --- a/src/i18n.lisp +++ b/src/i18n.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -16,15 +16,15 @@ #-(or (and lispworks unicode) (and sbcl sb-unicode) (and allegro ics) (and clisp i18n) (and openmcl openmcl-unicode-strings)) -(pushnew 'no-i18n *features*) +(pushnew 'no-i18n cl:*features*) -(defvar *default-external-character-encoding* +(defvar *default-foreign-encoding* 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 *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)) @@ -42,16 +42,165 @@ 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 *foreign-encodings* + (mapcar 'car *foreign-encoding-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 lookup-foreign-encoding (normalized) + (cdr (assoc normalized *foreign-encoding-mapping* :test 'eql))) + +(defmacro string-to-octets (str &key encoding null-terminate) + (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-")) + (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))))) + + #+ccl + ;; simply reading each char-code from the LENGTH of string handles + ;; multibyte characters in testing with CCL 1.5 + (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)))) + + #+lispworks + ;; simply reading each char-code from the LENGTH of string handles multibyte characters + ;; just fine in testing LW 6.0 and CCL 1.4 + (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))))) + + #+lispworks + ;; With LW 6.0, writing multibyte character just one octet at a time + ;; produces expected formatted output, but strings lengths are too + ;; long and consists only of octets, not wide characters + ;; + ;; Below technique of using fli:convert-from-foreign-string works tp + ;; correctly create string of wide-characters. However, errors occur + ;; during formatted printing of such strings with an error such as + ;; "#\U+30D3 is not of type BASE-CHAR" + (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)) + (fli:with-dynamic-foreign-objects + ((ptr (:unsigned :byte) :initial-contents (coerce ,oct 'list))) + (fli:convert-from-foreign-string ptr + :length (length ,oct) + :null-terminated-p nil + :external-format ,ife)))) + + #+(or ccl openmcl) + ;; With CCL 1.5, 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 (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) + +)