X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=b58bbea579d8e59aeff9cea687070e8b1f29bcf2;hb=40bf78b47ea89b15698adb9c550efa4cbacafeb7;hp=a4e7476646dbfc0dea4dab2d39ed2e63ce61f0b5;hpb=da54f0f75754190f30f8585ff05bebd254aa4e40;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index a4e7476..b58bbea 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -222,6 +222,7 @@
   (assert (null result))
   (assert (typep error 'program-error)))
 
+;;; ECASE should treat a bare T as a literal key
 (multiple-value-bind (result error)
     (ignore-errors (ecase 1 (t 0)))
   (assert (null result))
@@ -247,3 +248,87 @@
   (assert (null result))
   (assert (typep error 'undefined-function))
   (assert (eq (cell-error-name error) 'and)))
+
+;;; PSETQ should behave when given complex symbol-macro arguments
+(multiple-value-bind (sequence index)
+    (symbol-macrolet ((x (aref a (incf i)))
+		      (y (aref a (incf i))))
+	(let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
+	      (i 0))
+	  (psetq x (aref a (incf i))
+		 y (aref a (incf i)))
+	  (values a i)))
+  (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
+  (assert (= index 4)))
+
+(multiple-value-bind (result error)
+    (ignore-errors
+      (let ((x (list 1 2)))
+	(psetq (car x) 3)
+	x))
+  (assert (null result))
+  (assert (typep error 'program-error)))
+
+;;; COPY-SEQ should work on known-complex vectors:
+(assert (equalp #(1)
+		(let ((v (make-array 0 :fill-pointer 0)))
+		  (vector-push-extend 1 v)
+		  (copy-seq v))))
+
+;;; to support INLINE functions inside MACROLET, it is necessary for
+;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
+;;; certain circumstances, one of which is when compile is called from
+;;; top-level.
+(assert (equal
+	 (function-lambda-expression
+	  (compile nil '(lambda (x) (block nil (print x)))))
+	 '(lambda (x) (block nil (print x)))))
+
+;;; bug 62: too cautious type inference in a loop
+(assert (nth-value
+         2
+         (compile nil
+                  '(lambda (a)
+                    (declare (optimize speed (safety 0)))
+                    (typecase a
+                      (array (loop (print (car a)))))))))
+
+;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
+;;; failure
+(compile nil
+         '(lambda (key tree collect-path-p)
+           (let ((lessp (key-lessp tree))
+                 (equalp (key-equalp tree)))
+             (declare (type (function (t t) boolean) lessp equalp))
+             (let ((path '(nil)))
+               (loop for node = (root-node tree)
+                  then (if (funcall lessp key (node-key node))
+                           (left-child node)
+                           (right-child node))
+                  when (null node)
+                  do (return (values nil nil nil))
+                  do (when collect-path-p
+                       (push node path))
+                  (when (funcall equalp key (node-key node))
+                    (return (values node path t))))))))
+
+;;; CONSTANTLY should return a side-effect-free function (bug caught
+;;; by Paul Dietz' test suite)
+(let ((i 0))
+  (let ((fn (constantly (progn (incf i) 1))))
+    (assert (= i 1))
+    (assert (= (funcall fn) 1))
+    (assert (= i 1))
+    (assert (= (funcall fn) 1))
+    (assert (= i 1))))
+
+;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
+(loop for (fun warns-p) in
+     '(((lambda (&optional *x*) *x*) t)
+       ((lambda (&optional *x* &rest y) (values *x* y)) t)
+       ((lambda (&optional *print-base*) (values *print-base*)) nil)
+       ((lambda (&optional *print-base* &rest y) (values *print-base* y)) nil)
+       ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
+       ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
+   for real-warns-p = (nth-value 1 (compile nil fun))
+   do (assert (eq warns-p real-warns-p)))