-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
)
(defmacro free-cstring (obj)
- #+(or cmu sbcl scl lispworks) (declare (ignore obj))
+ (declare (ignorable obj))
#+allegro
(let ((stored (gensym)))
`(let ((,stored ,obj))
;;; Foreign string functions
-(defun %convert-to-foreign-string (str foreign-encoding)
+(defun %convert-to-foreign-string (str encoding)
+ (declare (ignorable str encoding))
#+(or cmu scl)
(etypecase str
(null
(dotimes (i size)
(declare (fixnum i))
(setf (alien:deref storage i)
- (char-code (char stored-obj i))))
- (setf (alien:deref storage size) 0))
- storage)))
+ (char-code (char str i))))
+ (setf (alien:deref storage size) 0)
+ storage))))
#+(and sbcl (not sb-unicode))
- (etypecase stored-obj
+ (etypecase str
(null
(sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
(string
(locally
(declare (optimize (speed 3) (safety 0)))
- (let* ((size (length stored-obj))
+ (let* ((size (length str))
(storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ size))))
(declare (fixnum i))
(setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
(dotimes (i size)
(declare (fixnum i))
(setf (sb-alien:deref storage i)
- (char-code (char stored-obj i))))
+ (char-code (char str i))))
(setf (sb-alien:deref storage size) 0))
storage)))
(string
(locally
(declare (optimize (speed 3) (safety 0)))
- (let* ((fe (or foreign-encoding *default-foreign-encoding*))
- (ife (when fe (implementation-foreign-encoding fe))))
+ (let* ((fe (or encoding *default-foreign-encoding*
+ sb-impl::*default-external-format*))
+ (ife (when fe (lookup-foreign-encoding fe))))
(if ife
(let* ((octets (sb-ext:string-to-octets str :external-format ife))
(size (length octets))
(setq storage (sb-alien:cast storage (* (sb-alien:unsigned 8))))
(dotimes (i size)
(declare (fixnum i))
- (setf (sb-alien:deref storage i) (svref octets i)))
+ (setf (sb-alien:deref storage i) (aref octets i)))
;; terminate with 2 nulls, maybe needed for some encodings
(setf (sb-alien:deref storage size) 0)
(setf (sb-alien:deref storage (1+ size)) 0)
(dotimes (i size)
(declare (fixnum i))
(setf (sb-alien:deref storage i)
- (char-code (char stored-obj i))))
+ (char-code (char str i))))
(setf (sb-alien:deref storage size) 0)
storage))))))
+null-cstring-pointer+
(locally
(declare (optimize (speed 3) (safety 0)))
- (let* ((fe (or foreign-encoding *default-foreign-encoding*))
- (ife (when fe (implementation-foreign-encoding fe))))
+ (let* ((fe (or encoding *default-foreign-encoding*))
+ (ife (when fe (lookup-foreign-encoding fe))))
(if ife
(let* ((octets (ccl:encode-string-to-octets str :external-format ife))
(size (length octets))
ptr))
#+(or allegro lispworks)
- (declare (ignore str foreign-encoding))
-
+ nil
)
-(defmacro convert-to-foreign-string (obj &optional foreign-encoding)
+(defmacro convert-to-foreign-string (obj &optional encoding)
+ (declare (ignorable encoding))
#+allegro
(let ((stored (gensym "STR-"))
(fe (gensym "FE-"))
(ife (gensym "IFE-")))
`(let* ((,stored ,obj)
- (,fe (or foreign-encoding *default-foreign-encoding*))
+ (,fe (or encoding *default-foreign-encoding*))
(,ife (when ,fe
- (implementation-foreign-encoding ,fe))))
+ (lookup-foreign-encoding ,fe))))
(cond
((null ,stored)
0)
(fe (gensym "EF-"))
(ife (gensym "NEF-")))
`(let* ((,stored ,obj)
- (,fe (or ,foreign-encoding *default-foreign-encoding*))
+ (,fe (or ,encoding *default-foreign-encoding*))
(,ife (when ,fe
- (implementation-foreign-encoding ,fe))))
+ (lookup-foreign-encoding ,fe))))
(cond
((null ,stored)
+null-cstring-pointer+)
(fli:convert-to-foreign-string ,stored :external-format ,ife)))))
#+(or cmu scl sbcl digitool openmcl)
- `(%convert-to-foreign-string ,obj (implementation-foreign-encoding
- (or ,foreign-encoding *default-foreign-encoding*)))
+ `(%convert-to-foreign-string ,obj (lookup-foreign-encoding
+ (or ,encoding *default-foreign-encoding*)))
)
;; Either length or null-terminated-p must be non-nil
(defmacro convert-from-foreign-string (obj &key
length
- foreign-encoding
+ encoding
(null-terminated-p t))
+ (declare (ignorable length encoding null-terminated-p))
#+allegro
(let ((stored-obj (gensym "STR-"))
(fe (gensym "FE-"))
`(let ((,stored-obj ,obj))
(if (zerop ,stored-obj)
nil
- (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
- (,ife (when ,fe (implementation-foreign-encoding ,fe))))
+ (let* ((,fe (or ,encoding *default-foreign-encoding*))
+ (,ife (when ,fe (lookup-foreign-encoding ,fe))))
(if ,ife
(values
(excl:native-to-string
(fast-native-to-string ,stored-obj ,length))))))
#+lispworks
- ;; FAST-NATIVE-TO-STRING (suprisingly) works just fine with UTF-8 multibyte character strings
+ #|
+ ;; FAST-NATIVE-TO-STRING (suprisingly) works just fine to make strings
+ ;; for formatted printing with Lispworks and UTF-8 multibyte character strings.
;; However, without knowledge of specific-encoding, the LENGTH call in FAST-NATIVE-TO-STRING
- ;; may not be incorrect for some encodings/strings.
+ ;; will be be incorrect for some encodings/strings and strings consist of octets rather
+ ;; than wide characters
;; This is a stop-gap until get tech support on why the below fails.
(let ((stored-obj (gensym "STR-")))
`(let ((,stored-obj ,obj))
(if (fli:null-pointer-p ,stored-obj)
nil
(fast-native-to-string ,stored-obj ,length))))
+ |#
+ #|
;; Below code doesn't work on tesing with LW 6.0 testing with a UTF-8 string.
;; fli:convert-from-foreign-string with :external-format of :UTF-8 doesn't
;; properly code multibyte characters.
-#|
+ |#
(let ((stored-obj (gensym "STR-"))
(fe (gensym "FE-"))
(ife (gensym "IFE-")))
`(let ((,stored-obj ,obj))
(if (fli:null-pointer-p ,stored-obj)
nil
- (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
- (,ife (when ,fe (implementation-foreign-encoding ,fe))))
+ (let* ((,fe (or ,encoding *default-foreign-encoding*))
+ (,ife (when ,fe (lookup-foreign-encoding ,fe))))
(if ,ife
(fli:convert-from-foreign-string
,stored-obj
:null-terminated-p ,null-terminated-p
:external-format (list ,ife :eol-style :lf))
(fast-native-to-string ,stored-obj ,length))))))
-|#
#+(or cmu scl)
(let ((stored-obj (gensym)))
`(let ((,stored-obj ,obj))
(if (null-pointer-p ,stored-obj)
nil
- (let* ((,fe (or ,foreign-encoding *default-foreign-encoding*))
- (,ife (when ,fe (implementation-foreign-encoding ,fe))))
+ (let* ((,fe (or ,encoding *default-foreign-encoding*))
+ (,ife (when ,fe (lookup-foreign-encoding ,fe))))
(sb-alien::c-string-to-string (sb-alien:alien-sap ,stored-obj)
(or ,ife sb-impl::*default-external-format* :latin-1)
'character)))))
- #+(or openmcl digitool)
- (declare (ignore null-terminated-p))
#+(or openmcl digitool)
(let ((stored-obj (gensym "STR-"))
(fe (gensym "FE-")))
,stored-obj 0
,@(if length (list length) nil))
#+openmcl
- (let ((,fe (or ,foreign-encoding *default-foreign-encoding*)))
+ (let ((,fe (or ,encoding *default-foreign-encoding*)))
(case ,fe
(:utf-8
(ccl::%get-utf-8-cstring ,stored-obj))
(defmacro allocate-foreign-string (size &key (unsigned t))
+ (declare (ignorable unsigned))
#+ignore
(let ((array-def (gensym)))
`(let ((,array-def (list 'alien:array 'c-call:char ,size)))
:char)
:nelems ,size)
#+allegro
- (declare (ignore unsigned))
- #+allegro
`(ff:allocate-fobject :char :c ,size)
#+(or openmcl digitool)
- (declare (ignore unsigned))
- #+(or openmcl digitool)
`(new-ptr ,size)
)
-(defun foreign-string-length (foreign-string)
+(defmacro foreign-string-length (foreign-string)
#+allegro `(ff:foreign-strlen ,foreign-string)
#-allegro
- `(loop with size = 0
- until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
- do (incf size)
- finally return size))
+ `(loop
+ for size from 0
+ until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
+ finally (return size)))
-(defmacro with-foreign-string ((foreign-string lisp-string &optional foreign-encoding)
+(defmacro with-foreign-string ((foreign-string lisp-string &optional encoding)
&body body)
(let ((result (gensym))
(fe (gensym)))
- `(let* ((,fe ,foreign-encoding)
+ `(let* ((,fe ,encoding)
(,foreign-string (convert-to-foreign-string ,lisp-string ,fe))
(,result (progn ,@body)))
(declare (dynamic-extent ,foreign-string))