-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
#-(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))
(: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)
+
+)