X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fi18n.lisp;h=a46b5354b01f43c331bb20e54d2c3d7434581363;hb=HEAD;hp=47a06db565268760cd5e6d3840c4a8683abc4932;hpb=01066b26a984761a2c9372871bba3697984a4456;p=uffi.git diff --git a/src/i18n.lisp b/src/i18n.lisp index 47a06db..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 ;;;; @@ -55,19 +55,152 @@ 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 &optional foreign-encoding) +(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." - ;; 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)) + (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) + +)