[Sbcl-commits] CVS: sbcl/tests compiler.impure.lisp,1.65,1.66 compiler.pure.lisp,1.131,1.132

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1392/tests

Modified Files:
	compiler.impure.lisp compiler.pure.lisp 
Log Message:
0.9.9.9:
	Fix bug #399 (gwking on #lisp / paste 16110; reduced case by 
	NJF)
	... we need to be able to derive DATA-VECTOR-REF's return type 
		when we have a SIMPLE-STRING, even if the array's type 
		isn't represented directly as an ARRAY-TYPE


Index: compiler.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure.lisp,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -d -r1.65 -r1.66
--- compiler.impure.lisp	17 Dec 2005 22:38:18 -0000	1.65
+++ compiler.impure.lisp	27 Jan 2006 22:42:56 -0000	1.66
@@ -1157,7 +1157,7 @@
                            c
                            0)))))
 
-;; Put this in a separate function.
+;;; Put this in a separate function.
 (defun test-constraint-propagation/cast (x)
   (when (the double-float (multiple-value-prog1
                               x
@@ -1168,4 +1168,37 @@
   (assert (assertoid:raises-error?
            (test-constraint-propagation/cast 1) type-error)))
 
+;;; bug #399
+(let ((result (make-array 50000 :fill-pointer 0 :adjustable t)))
+  (defun string->html (string &optional (max-length nil))
+    (when (and (numberp max-length)
+               (> max-length (array-dimension result 0)))
+      (setf result (make-array max-length :fill-pointer 0 :adjustable t)))
+    (let ((index 0)
+          (left-quote? t))
+      (labels ((add-char (it)
+                 (setf (aref result index) it)
+                 (incf index))
+               (add-string (it)
+                 (loop for ch across it do
+                       (add-char ch))))
+        (loop for char across string do
+              (cond ((char= char #\<)
+                     (add-string "&lt;"))
+                    ((char= char #\>)
+                     (add-string "&gt;"))
+                    ((char= char #\&)
+                     (add-string "&amp;"))
+                    ((char= char #\')
+                     (add-string "&#39;"))
+                    ((char= char #\newline)
+                     (add-string "<br>"))
+                    ((char= char #\")
+                     (if left-quote? (add-string "&#147;") (add-string "&#148;"))
+                     (setf left-quote? (not left-quote?)))
+                    (t
+                     (add-char char))))
+        (setf (fill-pointer result) index)
+        (coerce result 'string)))))
+
 ;;; success

Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.131
retrieving revision 1.132
diff -u -d -r1.131 -r1.132
--- compiler.pure.lisp	8 Jan 2006 02:01:43 -0000	1.131
+++ compiler.pure.lisp	27 Jan 2006 22:42:56 -0000	1.132
@@ -1915,3 +1915,9 @@
                  (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
                    (1+ x)))))
 
+;;; bug #399
+(with-test (:name :string-union-types)
+  (compile nil '(lambda (x)
+                 (declare (type (or (simple-array character (6))
+                                    (simple-array character (5))) x))
+                 (aref x 0))))