X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=f94e582ec1f0cf82e8fafa4444d052953419f8f6;hb=5ce77b3465434e396aa2d7670138a7e7741f3dae;hp=0a530bdea6f1c5e6bfa28e67cc1e182bd43c8c2a;hpb=0957d59ccfaf3db9aaf79a7f4909a40ea0ca0dcd;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 0a530bd..f94e582 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -288,16 +288,22 @@
 ;;; bug 194, fixed in part by APD "more strict type checking" patch
 ;;; (sbcl-devel 2002-08-07)
 (progn
-  #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
   (multiple-value-bind (result error)
       (ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3)))))
     (assert (null result))
     (assert (typep error 'type-error)))
-  #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
   (multiple-value-bind (result error)
       (ignore-errors (the real '(1 2 3)))
     (assert (null result))
     (assert (typep error 'type-error))))
+
+(defun bug194d ()
+  (null (ignore-errors
+          (let ((arg1 1)
+                (arg2 (identity (the real #(1 2 3)))))
+            (if (< arg1 arg2) arg1 arg2)))))
+(assert (eq (bug194d) t))
+
 
 ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
 ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
@@ -312,13 +318,10 @@
 		  *standard-input*)))
   (assert failure-p)
   (assert (raises-error? (funcall function) program-error)))
-#||
-BUG 48c, not yet fixed:
 (multiple-value-bind (function warnings-p failure-p)
     (compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s)))
   (assert failure-p)
   (assert (raises-error? (funcall function) program-error)))
-||#
 
 ;;; bug 120a: Turned out to be constraining code looking like (if foo
 ;;; <X> <X>) where <X> was optimized by the compiler to be the exact
@@ -404,21 +407,22 @@ BUG 48c, not yet fixed:
   (declare (ignore result))
   (assert (typep condition 'type-error)))
 
-;;; bug 110: the compiler flushed the argument type test and the default
-;;; case in the cond.
-
-(defun bug110 (x)
-  (declare (optimize (safety 2) (speed 3)))
-  (declare (type (or string stream) x))
-  (cond ((typep x 'string) 'string)
-        ((typep x 'stream) 'stream)
-        (t
-         'none)))
-
-(multiple-value-bind (result condition)
-    (ignore-errors (bug110 0))
-  (declare (ignore result))
-  (assert (typep condition 'type-error)))
+;;;; bug 110: the compiler flushed the argument type test and the default
+;;;; case in the cond.
+;
+;(locally (declare (optimize (safety 3) (speed 2)))
+;  (defun bug110 (x)
+;    (declare (optimize (safety 2) (speed 3)))
+;    (declare (type (or string stream) x))
+;    (cond ((typep x 'string) 'string)
+;          ((typep x 'stream) 'stream)
+;          (t
+;           'none))))
+;
+;(multiple-value-bind (result condition)
+;    (ignore-errors (bug110 0))
+;  (declare (ignore result))
+;  (assert (typep condition 'type-error)))
 
 ;;; bug 202: the compiler failed to compile a function, which derived
 ;;; type contradicted declared.
@@ -585,9 +589,9 @@ BUG 48c, not yet fixed:
                         `(lambda (f)
                            (declare (optimize (speed 2) (safety ,policy1)))
                            (multiple-value-list
-                            (the (values (integer 2 3) t)
+                            (the (values (integer 2 3) t &optional)
                               (locally (declare (optimize (safety ,policy2)))
-                                (the (values t (single-float 2f0 3f0))
+                                (the (values t (single-float 2f0 3f0) &optional)
                                   (funcall f)))))))
                (lambda () (values x y)))
     (type-error (error)
@@ -601,7 +605,6 @@ BUG 48c, not yet fixed:
 (assert (equal (check-embedded-thes 0 1  :a 3.5f0) '(:a 3.5f0)))
 (assert (typep (check-embedded-thes 0 1  2 2.5d0) 'type-error))
 
-#+nil
 (assert (equal (check-embedded-thes 3 0  2 :a) '(2 :a)))
 (assert (typep (check-embedded-thes 3 0  4 2.5f0) 'type-error))
 
@@ -612,7 +615,6 @@ BUG 48c, not yet fixed:
 (assert (equal (check-embedded-thes 3 3  2 2.5f0) '(2 2.5f0)))
 (assert (typep (check-embedded-thes 3 3  0 2.5f0) 'type-error))
 (assert (typep (check-embedded-thes 3 3  2 3.5f0) 'type-error))
-
 
 ;;; INLINE inside MACROLET
 (declaim (inline to-be-inlined))
@@ -669,6 +671,253 @@ BUG 48c, not yet fixed:
   x)
 (assert (= (bug219-b-aux2 1)
 	   (if *bug219-b-expanded-p* 3 1)))
+
+;;; bug 224: failure in unreachable code deletion
+(defmacro do-optimizations (&body body)
+  `(dotimes (.speed. 4)
+     (dotimes (.space. 4)
+       (dotimes (.debug. 4)
+         (dotimes (.compilation-speed. 4)
+           (proclaim `(optimize (speed , .speed.) (space , .space.)
+                                (debug , .debug.)
+                                (compilation-speed , .compilation-speed.)))
+           ,@body)))))
+
+(do-optimizations
+    (compile nil
+             (read-from-string
+              "(lambda () (#:localy (declare (optimize (safety 3)))
+                                    (ignore-errors (progn (values-list (car (list '(1 . 2)))) t))))")))
+
+(do-optimizations
+    (compile nil '(lambda ()
+                   (labels ((ext ()
+                              (tagbody
+                                 (labels ((i1 () (list (i2) (i2)))
+                                          (i2 () (list (int) (i1)))
+                                          (int () (go :exit)))
+                                   (list (i1) (i1) (i1)))
+                               :exit (return-from ext)
+                                 )))
+                     (list (error "nih") (ext) (ext))))))
+
+(do-optimizations
+  (compile nil '(lambda (x) (let ((y (error ""))) (list x y)))))
+
+;;; bug 223: invalid moving of global function name referencing
+(defun bug223-int (n)
+  `(int ,n))
+
+(defun bug223-wrap ()
+  (let ((old #'bug223-int))
+    (setf (fdefinition 'bug223-int)
+          (lambda (n)
+            (assert (> n 0))
+            `(ext ,@(funcall old (1- n)))))))
+(compile 'bug223-wrap)
+
+(assert (equal (bug223-int 4) '(int 4)))
+(bug223-wrap)
+(assert (equal (bug223-int 4) '(ext int 3)))
+(bug223-wrap)
+(assert (equal (bug223-int 4) '(ext ext int 2)))
+
+;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of
+;;; SPECIFIER-TYPE-NTH-ARG.  For a while, an illegal type would throw
+;;; you into the debugger on compilation.
+(defun coerce-defopt1 (x)
+  ;; illegal, but should be compilable.
+  (coerce x '(values t)))
+(defun coerce-defopt2 (x)
+  ;; illegal, but should be compilable.
+  (coerce x '(values t &optional)))
+(assert (null (ignore-errors (coerce-defopt1 3))))
+(assert (null (ignore-errors (coerce-defopt2 3))))
+
+;;; Oops.  In part of the (CATCH ..) implementation of DEBUG-RETURN,
+;;; it was possible to confuse the type deriver of the compiler
+;;; sufficiently that compiler invariants were broken (explained by
+;;; APD sbcl-devel 2003-01-11).
+
+;;; WHN's original report
+(defun debug-return-catch-break1 ()
+  (with-open-file (s "/tmp/foo"
+		     :direction :output
+		     :element-type (list
+				    'signed-byte
+				    (1+
+				     (integer-length most-positive-fixnum))))
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)))
+
+;;; APD's simplified test case
+(defun debug-return-catch-break2 (x)
+  (declare (type (vector (unsigned-byte 8)) x))
+  (setq *y* (the (unsigned-byte 8) (aref x 4))))
+
+;;; FUNCTION-LAMBDA-EXPRESSION should return something that's COMPILE
+;;; can understand.  Here's a simple test for that on a function
+;;; that's likely to return a hairier list than just a lambda:
+(macrolet ((def (fn) `(progn
+		       (declaim (inline ,fn))
+		       (defun ,fn (x) (1+ x)))))
+  (def bug228))
+(let ((x (function-lambda-expression #'bug228)))
+  (when x
+    (assert (= (funcall (compile nil x) 1) 2))))
+
+;;;
+(defun bug192b (i)
+  (dotimes (j i)
+    (declare (type (mod 4) i))
+    (unless (< i 5)
+      (print j))))
+(assert (raises-error? (bug192b 6) type-error))
+
+(defun bug192c (x y)
+  (locally (declare (type fixnum x y))
+    (+ x (* 2 y))))
+(assert (raises-error? (bug192c 1.1 2) type-error))
+
+(assert (raises-error? (progn (the real (list 1)) t) type-error))
+
+(defun bug236 (a f)
+  (declare (optimize (speed 2) (safety 0)))
+  (+ 1d0
+     (the double-float
+       (multiple-value-prog1
+           (svref a 0)
+         (unless f (return-from bug236 0))))))
+(assert (eql (bug236 #(4) nil) 0))
+
+;;; Bug reported by reported by rif on c.l.l 2003-03-05
+(defun test-type-of-special-1 (x)
+  (declare (special x)
+           (fixnum x)
+           (optimize (safety 3)))
+  (list x))
+(defun test-type-of-special-2 (x)
+  (declare (special x)
+           (fixnum x)
+           (optimize (safety 3)))
+  (list x (setq x (/ x 2)) x))
+(assert (raises-error? (test-type-of-special-1 3/2) type-error))
+(assert (raises-error? (test-type-of-special-2 3) type-error))
+(assert (equal (test-type-of-special-2 8) '(8 4 4)))
+
+;;; bug which existed in 0.8alpha.0.4 for several milliseconds before
+;;; APD fixed it in 0.8alpha.0.5
+(defun frob8alpha04 (x y)
+  (+ x y))
+(defun baz8alpha04 (this kids)
+  (flet ((n-i (&rest rest)
+	   ;; Removing the #+NIL here makes the bug go away.
+	   #+nil (format t "~&in N-I REST=~S~%" rest)
+	   (apply #'frob8alpha04 this rest)))
+    (n-i kids)))
+;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
+(assert (= (baz8alpha04 12 13) 25))
+
+;;; evaluation order in structure slot writers
+(defstruct sswo
+  a b)
+(let* ((i 0)
+       (s (make-sswo :a (incf i) :b (incf i)))
+       (l (list s :v)))
+  (assert (= (sswo-a s) 1))
+  (assert (= (sswo-b s) 2))
+  (setf (sswo-a (pop l)) (pop l))
+  (assert (eq l nil))
+  (assert (eq (sswo-a s) :v)))
+
+(defun bug249 (x)
+  (flet ((bar (y)
+           (declare (fixnum y))
+           (incf x)))
+    (list (bar x) (bar x) (bar x))))
+
+(assert (raises-error? (bug249 1.0) type-error))
+
+;;; bug reported by ohler on #lisp 2003-07-10
+(defun bug-ohler-2003-07-10 (a b)
+  (declare (optimize (speed 0) (safety 3) (space 0)
+                     (debug 1) (compilation-speed 0)))
+  (adjoin a b))
+
+;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14:
+;;; COMPILE-FILE did not bind *READTABLE*
+(let* ((source "bug-doug-mcnaught-20030914.lisp")
+       (fasl (compile-file-pathname source)))
+  (labels ((check ()
+             (assert (null (get-macro-character #\]))))
+           (full-check ()
+             (check)
+             (assert (typep *bug-doug-mcnaught-20030914*
+                            '(simple-array (unsigned-byte 4) (*))))
+             (assert (equalp *bug-doug-mcnaught-20030914* #(1 2 3)))
+             (makunbound '*bug-doug-mcnaught-20030914*)))
+    (compile-file source)
+    (check)
+    (load fasl)
+    (full-check)
+    (load source)
+    (full-check)
+    (delete-file fasl)))
+
+(defun expt-derive-type-bug (a b)
+  (unless (< a b)
+    (truncate (expt a b))))
+(assert (equal (multiple-value-list (expt-derive-type-bug 1 1))
+	       '(1 0)))
+
+;;; Problems with type checking in functions with EXPLICIT-CHECK
+;;; attribute (reported by Peter Graves)
+(loop for (fun . args) in '((= a) (/= a)
+                            (< a) (<= a) (> a) (>= a))
+      do (assert (raises-error? (apply fun args) type-error)))
+
+(defclass broken-input-stream (sb-gray:fundamental-input-stream) ())
+(defmethod sb-gray:stream-read-char ((stream broken-input-stream))
+  (throw 'break :broken))
+(assert (eql (block return
+               (handler-case
+                   (catch 'break
+                     (funcall (eval ''peek-char)
+                              1 (make-instance 'broken-input-stream))
+                     :test-broken)
+                 (type-error (c)
+                   (return-from return :good))))
+             :good))
+
+;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
+(defvar *compiler-note-count* 0)
+#-alpha ; FIXME: make a better test!
+(handler-bind ((sb-ext:compiler-note (lambda (c)
+				       (declare (ignore c))
+				       (incf *compiler-note-count*))))
+  (let ((fun
+	 (compile nil
+		  '(lambda (x)
+		    (declare (optimize speed) (fixnum x))
+		    (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+		    (values (* x 5) ; no compiler note from this
+		     (locally
+		       (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+		       ;; this one gives a compiler note
+		       (* x -5)))))))
+    (assert (= *compiler-note-count* 1))
+    (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5)))))
+
+(handler-case
+    (eval '(flet ((%f (&key) nil)) (%f nil nil)))
+  (error (c) :good)
+  (:no-error (val) (error "no error: ~S" val)))
+(handler-case
+    (eval '(labels ((%f (&key x) x)) (%f nil nil)))
+  (error (c) :good)
+  (:no-error (val) (error "no error: ~S" val)))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself