Fix comparison for dereference

[uffi.git] / src / strings.lisp

diff --git a/src/strings.lisp b/src/strings.lisp
index 209116428cce7e905c1210de6dc72675ab7c014e..430d8ab48d15c1b29c988108570867b41e487b89 100644 (file)
--- a/src/strings.lisp
+++ b/src/strings.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
 ;;;;
@@ -57,7 +57,7 @@ that LW/CMU automatically converts strings from c-calls."
   )
 
 (defmacro free-cstring (obj)
-  #+(or cmu sbcl scl lispworks) (declare (ignore obj))
+  (declare (ignorable obj))
   #+allegro
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
@@ -99,7 +99,8 @@ that LW/CMU automatically converts strings from c-calls."
 
 ;;; 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
@@ -114,25 +115,25 @@ that LW/CMU automatically converts strings from c-calls."
          (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)))
 
@@ -143,8 +144,9 @@ that LW/CMU automatically converts strings from c-calls."
     (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))
@@ -153,7 +155,7 @@ that LW/CMU automatically converts strings from c-calls."
                (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)
@@ -166,7 +168,7 @@ that LW/CMU automatically converts strings from c-calls."
                (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))))))
 
@@ -175,8 +177,8 @@ that LW/CMU automatically converts strings from c-calls."
       +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))
@@ -201,19 +203,19 @@ that LW/CMU automatically converts strings from c-calls."
         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-"))
-        (ef (gensym "EF-"))
-        (nef (gensym "NEF-")))
-    `(let ((,stored ,obj)
-            (,fe (or foreign-encoding *default-foreign-encoding*))
+        (fe (gensym "FE-"))
+        (ife (gensym "IFE-")))
+    `(let* ((,stored ,obj)
+            (,fe (or encoding *default-foreign-encoding*))
             (,ife (when ,fe
-                    (implementation-foreign-encoding ,fe))))
+                    (lookup-foreign-encoding ,fe))))
        (cond
          ((null ,stored)
           0)
@@ -227,9 +229,9 @@ that LW/CMU automatically converts strings from c-calls."
         (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+)
@@ -239,16 +241,17 @@ that LW/CMU automatically converts strings from c-calls."
           (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-"))
@@ -256,8 +259,8 @@ that LW/CMU automatically converts strings from c-calls."
     `(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
@@ -268,27 +271,32 @@ that LW/CMU automatically converts strings from c-calls."
                  (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
@@ -296,7 +304,6 @@ that LW/CMU automatically converts strings from c-calls."
                   :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)))
@@ -322,18 +329,15 @@ that LW/CMU automatically converts strings from c-calls."
     `(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-"))
-        (ife (gensym "IFE-")))
+        (fe (gensym "FE-")))
     `(let ((,stored-obj ,obj))
        (if (ccl:%null-ptr-p ,stored-obj)
            nil
@@ -342,7 +346,7 @@ that LW/CMU automatically converts strings from c-calls."
             ,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))
@@ -356,6 +360,7 @@ that LW/CMU automatically converts strings from c-calls."
 
 
 (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)))
@@ -383,29 +388,25 @@ that LW/CMU automatically converts strings from c-calls."
                                    :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)
-  #+allegro `(ff:foreign-strlen ,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 (zerop (deref-array foreign-string '(:array :unsigned-char) size))
+     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))