X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=src%2Fi18n.lisp;h=a46b5354b01f43c331bb20e54d2c3d7434581363;hb=refs%2Ftags%2Fv2.1.0;hp=08c16ad0b54eb962721764deaa4eea9c4a34feaa;hpb=3044928889785c0160fd021a51fbf86ad691a3a9;p=uffi.git diff --git a/src/i18n.lisp b/src/i18n.lisp index 08c16ad..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,42 +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 &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) + #+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 - (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 - (sb-ext:string-to-native str :external-format foreign-encoding) + (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) + +)