X-Git-Url: http://git.kpe.io/?p=uffi.git;a=blobdiff_plain;f=src%2Fstrings.lisp;h=1e90118c174e8a10f25dda0f06224d533a7c1ff3;hp=b4c1917a052486b358b7f5c1c757d57e30a41ff7;hb=87acde9ae931ba8ac7bd486809f6dab3b2448790;hpb=51a8e53201f8883fbd093fe45936d98128a8a5fe

diff --git a/src/strings.lisp b/src/strings.lisp
index b4c1917..1e90118 100644
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: strings.lisp,v 1.8 2003/06/06 21:59:18 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -35,7 +35,7 @@ that LW/CMU automatically converts strings from c-calls."
     `(let ((,stored ,obj))
        (if (zerop ,stored)
 	   nil
-	 (values (excl:native-to-string ,stored)))))
+	   (values (excl:native-to-string ,stored)))))
   #+mcl 
   (let ((stored (gensym)))
     `(let ((,stored ,obj))
@@ -47,41 +47,53 @@ that LW/CMU automatically converts strings from c-calls."
 (defmacro convert-to-cstring (obj)
   #+(or cmu sbcl scl lispworks) obj
   #+allegro
-  `(if (null ,obj)
-    0
-    (values (excl:string-to-native ,obj)))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   0
+	   (values (excl:string-to-native ,stored)))))
   #+mcl
-  `(if (null ,obj)
-    +null-cstring-pointer+
-    (let ((ptr (new-ptr (1+ (length ,obj)))))
-      (ccl::%put-cstring ptr ,obj)
-      ptr))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   +null-cstring-pointer+
+	   (let ((ptr (new-ptr (1+ (length ,stored)))))
+	     (ccl::%put-cstring ptr ,stored)
+	     ptr))))
   )
 
 (defmacro free-cstring (obj)
   #+(or cmu sbcl scl lispworks) (declare (ignore obj))
   #+allegro
-  `(unless (zerop ,obj)
-     (ff:free-fobject ,obj))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (zerop ,stored)
+	 (ff:free-fobject ,stored))))
   #+mcl
-  `(unless (ccl:%null-ptr-p ,obj)
-     (dispose-ptr ,obj))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (ccl:%null-ptr-p ,stored)
+	 (dispose-ptr ,stored))))
   )
 
 (defmacro with-cstring ((cstring lisp-string) &body body)
   #+(or cmu sbcl scl lispworks)
   `(let ((,cstring ,lisp-string)) ,@body) 
   #+allegro
-  (let ((acl-native (gensym)))
-    `(excl:with-native-string (,acl-native ,lisp-string)
-       (let ((,cstring (if ,lisp-string ,acl-native 0)))
-	 ,@body)))
+  (let ((acl-native (gensym))
+	(stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (excl:with-native-string (,acl-native ,stored-lisp-string)
+	 (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
+	   ,@body))))
   #+mcl
-  `(if (stringp ,lisp-string)
-     (ccl:with-cstrs ((,cstring ,lisp-string))
-       ,@body)
-     (let ((,cstring +null-cstring-pointer+))
-       ,@body))
+  (let ((stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (if (stringp ,stored-lisp-string)
+	   (ccl:with-cstrs ((,cstring ,stored-lisp-string))
+	     ,@body)
+	   (let ((,cstring +null-cstring-pointer+))
+	     ,@body))))
   )
 
 (defmacro with-cstrings (bindings &rest body)
@@ -95,118 +107,154 @@ that LW/CMU automatically converts strings from c-calls."
 
 (defmacro convert-to-foreign-string (obj)
   #+lispworks
-  `(if (null ,obj)
-    +null-cstring-pointer+
-    (fli:convert-to-foreign-string ,obj :external-format '(:latin-1 :eol-style :lf)))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       `(if (null ,stored)
+	    +null-cstring-pointer+
+	    (fli:convert-to-foreign-string 
+	     ,stored
+	     :external-format '(:latin-1 :eol-style :lf)))))
   #+allegro
-  `(if (null ,obj)
-       0
-     (values (excl:string-to-native ,obj)))
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   0
+	   (values (excl:string-to-native ,stored)))))
   #+(or cmu scl)
   (let ((size (gensym))
 	(storage (gensym))
+	(stored-obj (gensym))
 	(i (gensym)))
-    `(etypecase ,obj
-      (null 
-       (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
-      (string
-       (let* ((,size (length ,obj))
-	      (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
-	 (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
-	 (locally
-	     (declare (optimize (speed 3) (safety 0)))
-	   (dotimes (,i ,size)
-	     (declare (fixnum ,i))
-	     (setf (alien:deref ,storage ,i) (char-code (char ,obj ,i))))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+	 (null 
+	  (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+	 (string
+	  (let* ((,size (length ,stored-obj))
+		 (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+	    (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+	    (locally
+		(declare (optimize (speed 3) (safety 0)))
+	      (dotimes (,i ,size)
+		(declare (fixnum ,i))
+		(setf (alien:deref ,storage ,i)
+		      (char-code (char ,stored-obj ,i))))
 	   (setf (alien:deref ,storage ,size) 0))
-	 ,storage))))
+	 ,storage)))))
   #+sbcl
   (let ((size (gensym))
 	(storage (gensym))
+	(stored-obj (gensym))
 	(i (gensym)))
-    `(etypecase ,obj
-      (null 
-       (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
-      (string
-       (let* ((,size (length ,obj))
-	      (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
-	 (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
-	 (locally
-	     (declare (optimize (speed 3) (safety 0)))
-	   (dotimes (,i ,size)
-	     (declare (fixnum ,i))
-	     (setf (sb-alien:deref ,storage ,i) (char-code (char ,obj ,i))))
-	   (setf (sb-alien:deref ,storage ,size) 0))
-	 ,storage))))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+	 (null 
+	  (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+	 (string
+	  (let* ((,size (length ,stored-obj))
+		 (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+	    (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+	    (locally
+		(declare (optimize (speed 3) (safety 0)))
+	      (dotimes (,i ,size)
+		(declare (fixnum ,i))
+		(setf (sb-alien:deref ,storage ,i)
+		      (char-code (char ,stored-obj ,i))))
+	      (setf (sb-alien:deref ,storage ,size) 0))
+	    ,storage)))))
   #+mcl
-  `(if (null ,obj)
-       +null-cstring-pointer+
-     (let ((ptr (new-ptr (1+ (length ,obj)))))
-       (ccl::%put-cstring ptr ,obj)
-       ptr))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null ,stored-obj)
+	   +null-cstring-pointer+
+	   (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
+	     (ccl::%put-cstring ptr ,stored-obj)
+	     ptr))))
   )
 
-
 ;; Either length or null-terminated-p must be non-nil
 (defmacro convert-from-foreign-string (obj &key
 					   length
 					   (locale :default)
 					   (null-terminated-p t))
   #+allegro
-  `(if (zerop ,obj)
-       nil
-     (if (eq ,locale :none)
-	 (fast-native-to-string ,obj)
-       (excl:native-to-string
-	,obj 
-	,@(when length (list :length length))
-	:truncate (not ,null-terminated-p))))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (zerop ,stored-obj)
+	   nil
+	   (if (eq ,locale :none)
+	       (fast-native-to-string ,stored-obj ,length)
+	       (values
+		(excl:native-to-string
+		 ,stored-obj 
+		 ,@(when length (list :length length))
+		 :truncate (not ,null-terminated-p)))))))
   #+lispworks
-  `(if (fli:null-pointer-p ,obj)
-       nil
-     (if (eq ,locale :none)
-	 (fast-native-to-string ,obj)
-       (fli:convert-from-foreign-string 
-	,obj
-	,@(when length (list :length length))
-	:null-terminated-p ,null-terminated-p
-	:external-format '(:latin-1 :eol-style :lf))))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (fli:null-pointer-p ,stored-obj)
+	   nil
+	   (if (eq ,locale :none)
+	       (fast-native-to-string ,stored-obj ,length)
+	       (fli:convert-from-foreign-string 
+		,stored-obj
+		,@(when length (list :length length))
+		:null-terminated-p ,null-terminated-p
+		:external-format '(:latin-1 :eol-style :lf))))))
   #+(or cmu scl)
-  `(if (null-pointer-p ,obj)
-    nil
-    (cmucl-naturalize-cstring (alien:alien-sap ,obj)
-     :length ,length
-     :null-terminated-p ,null-terminated-p))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+	   nil
+	   (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
+				     :length ,length
+				     :null-terminated-p ,null-terminated-p))))
+
   #+sbcl
-  `(if (null-pointer-p ,obj)
-    nil
-    (sbcl-naturalize-cstring (sb-alien:alien-sap ,obj)
-     :length ,length
-     :null-terminated-p ,null-terminated-p))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+	    nil
+	    (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
+				     :length ,length
+				     :null-terminated-p ,null-terminated-p))))
   #+mcl
   (declare (ignore null-terminated-p))
   #+mcl
-  `(if (ccl:%null-ptr-p ,obj)
-     nil
-     (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil)))
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (ccl:%null-ptr-p ,stored-obj)
+	   nil
+	   #+(and mcl (not openmcl)) (ccl:%get-cstring
+				      ,stored-obj 0
+				      ,@(if length (list length) nil))
+	   #+openmcl ,@(if length
+			   `((ccl:%str-from-ptr ,stored-obj ,length))
+			   `((ccl:%get-cstring ,stored-obj))))))
   )
 
 
 (defmacro allocate-foreign-string (size &key (unsigned t))
-  #+(or cmu scl)
+  #+ignore
   (let ((array-def (gensym)))
     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
        (eval `(alien:cast (alien:make-alien ,,array-def) 
 			  ,(if ,unsigned 
 			       '(* (alien:unsigned 8))
 			     '(* (alien:signed 8)))))))
+
+  #+(or cmu scl)
+  `(alien:make-alien ,(if unsigned 
+			     '(alien:unsigned 8)
+			     '(alien:signed 8))
+    ,size)
+
   #+sbcl
-  (let ((array-def (gensym)))
-    `(let ((,array-def (list 'sb-alien:array 'char ,size)))
-       (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def) 
-			  ,(if ,unsigned 
-			       '(* (sb-alien:unsigned 8))
-			     '(* (sb-alien:signed 8)))))))
+  `(sb-alien:make-alien ,(if unsigned 
+			     '(sb-alien:unsigned 8)
+			     '(sb-alien:signed 8))
+    ,size)
+
   #+lispworks
   `(fli:allocate-foreign-object :type 
 				,(if unsigned 
@@ -223,6 +271,15 @@ that LW/CMU automatically converts strings from c-calls."
   `(new-ptr ,size)
   )
 
+(defun 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))
+
+
 (defmacro with-foreign-string ((foreign-string lisp-string) &body body)
   (let ((result (gensym)))
     `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
@@ -280,69 +337,74 @@ that LW/CMU automatically converts strings from c-calls."
 	(setf (char result i) (code-char (system:sap-ref-8 sap i))))
       result)))
 
-#+sbcl
+#+(and sbcl (not sb-unicode))
 (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
-  (declare (type sb-sys:system-area-pointer sap))
+  (declare (type sb-sys:system-area-pointer sap)
+	   (type (or null fixnum) length))
   (locally
-      (declare (optimize (speed 3) (safety 0)))
-    (let ((null-terminated-length
-	   (when null-terminated-p
-	     (loop
-		 for offset of-type fixnum upfrom 0
-		 until (zerop (sb-sys:sap-ref-8 sap offset))
-		 finally (return offset)))))
-      (if length
-	  (if (and null-terminated-length
-		   (> (the fixnum length) (the fixnum null-terminated-length)))
-	      (setq length null-terminated-length))
-	(setq length null-terminated-length)))
-    (let ((result (make-string length)))
-      (sb-kernel:copy-from-system-area sap 0
-				    result (* sb-vm:vector-data-offset
-					      sb-vm:n-word-bits)
-				    (* length sb-vm:n-byte-bits))
-      result)))
+   (declare (optimize (speed 3) (safety 0)))
+   (let ((null-terminated-length
+	  (when null-terminated-p
+	    (loop
+	     for offset of-type fixnum upfrom 0
+	     until (zerop (sb-sys:sap-ref-8 sap offset))
+	     finally (return offset)))))
+     (if length
+	 (if (and null-terminated-length
+		  (> (the fixnum length) (the fixnum null-terminated-length)))
+	     (setq length null-terminated-length))
+       (setq length null-terminated-length)))
+   (let ((result (make-string length)))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+		(* length +system-copy-multiplier+))
+       result)))
+
+#+(and sbcl sb-unicode)
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type sb-sys:system-area-pointer sap)
+	   (type (or null fixnum) length))
+  (locally
+   (declare (optimize (speed 3) (safety 0)))
+   (cond
+    (null-terminated-p
+     (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+				  #+sb-unicode sb-alien:utf8-string
+				  #-sb-unicode sb-alien:c-string)))
+       (if length
+	   (copy-seq (subseq casted 0 length))
+	 (copy-seq casted))))
+    (t
+     (let ((result (make-string length)))
+       ;; this will not work in sb-unicode
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+		(* length +system-copy-multiplier+))
+       result)))))
 
 
-(def-function "strlen"
-    ((str (* :unsigned-char)))
-  :returning :unsigned-int)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+   (def-function "strlen"
+     ((str (* :unsigned-char)))
+     :returning :unsigned-int))
 
-#+(or lispworks (and allegro ics))
-(defun fast-native-to-string (s)
+(def-type char-ptr-def (* :unsigned-char))
+
+#+(or lispworks (and allegro (not ics)))
+(defun fast-native-to-string (s len)
   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 	   (type char-ptr-def s))
-  (let* ((len (strlen s))
-	 (str (make-string len)))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
     (declare (fixnum len)
-	     (simple-string str))
-    (do ((i 0))
-	((= i len))
-      (declare (fixnum i))
-      (setf (schar str i)
-	(code-char (uffi:deref-array s '(:array :unsigned-char) i)))
-      (incf i))
-    str))
+	     (type (simple-array (signed-byte 8) (*)) str))
+    (dotimes (i len str)
+      (setf (aref str i) 
+	(uffi:deref-array s '(:array :char) i)))))
 
-#+(and allegro (not ics))
-(defun fast-native-to-string (s)
+#+(and allegro ics)
+(defun fast-native-to-string (s len)
   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 	   (type char-ptr-def s))
-  (let* ((len (strlen s))
-	 (len4 (floor len 4))
-	 (str (make-string len)))
-    (declare (fixnum len)
-	     (type (simple-array (signed-byte 32) (*)) str))
-    (do ((i 0))
-	((= i len4))
-      (declare (fixnum i))
-      (setf (aref (the (simple-array (signed-byte 32) (*)) str) i)
-	(uffi:deref-array s '(:array :int) i))
-	(incf i))
-    (do ((i (* 4 len4)))
-	((= i len))
-      (declare (fixnum i))
-      (setf (aref (the (simple-array (signed-byte 8) (*)) str) i)
-	(uffi:deref-array s '(:array :unsigned-char) i))
-      (incf i))
-    str))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
+      (dotimes (i len str)
+        (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))