X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=d36c958df49828ac906fa476d0c68b6c7b359927;hb=b3e7d6608689a639cb774e2ce15bb5bacaed5179;hp=cadd0b07358dc2978b012fe9005b08af59903c66;hpb=f22313c8b2cb104a088b8d901688f73c20a6161a;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index cadd0b0..d36c958 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1440,3 +1440,211 @@ (type (unsigned-byte 32) x y)) (logand #xffffffff (ash x y)))) 1 257))) + +;;; code instrumenting problems +(compile nil + '(lambda () + (declare (optimize (debug 3))) + (list (the integer (if nil 14 t))))) + +(compile nil + '(LAMBDA (A B C D) + (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD)) + (DECLARE + (OPTIMIZE (SPEED 1) + (SPACE 1) + (SAFETY 1) + (DEBUG 3) + (COMPILATION-SPEED 0))) + (MASK-FIELD (BYTE 7 26) + (PROGN + (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1) + B)))) + +(compile nil + '(lambda (buffer i end) + (declare (optimize (debug 3))) + (loop (when (not (eql 0 end)) (return))) + (let ((s (make-string end))) + (setf (schar s i) (schar buffer i)) + s))) + +;;; check that constant string prefix and suffix don't cause the +;;; compiler to emit code deletion notes. +(handler-bind ((sb-ext:code-deletion-note #'error)) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :prefix "(") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :per-line-prefix ";") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :suffix ">") + (print x s))))) + +;;; MISC.427: loop analysis requires complete DFO structure +(assert (eql 17 (funcall + (compile + nil + '(lambda (a) + (declare (notinline list reduce logior)) + (declare (optimize (safety 2) (compilation-speed 1) + (speed 3) (space 2) (debug 2))) + (logior + (let* ((v5 (reduce #'+ (list 0 a)))) + (declare (dynamic-extent v5)) + v5)))) + 17))) + +;;; MISC.434 +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -8431780939320 1571817471932) a)) + (declare (type (integer -4085 0) b)) + (declare (ignorable a b)) + (declare + (optimize (space 2) + (compilation-speed 0) + #+sbcl (sb-c:insert-step-conditions 0) + (debug 2) + (safety 0) + (speed 3))) + (let ((*s5* 0)) + (dotimes (iv1 2 0) + (let ((*s5* + (elt '(1954479092053) + (min 0 + (max 0 + (if (< iv1 iv1) + (lognand iv1 (ash iv1 (min 53 iv1))) + iv1)))))) + 0))))) + -7639589303599 -1368))) + +(compile + nil + '(lambda (a b) + (declare (type (integer) a)) + (declare (type (integer) b)) + (declare (ignorable a b)) + (declare (optimize (space 2) (compilation-speed 0) + (debug 0) (safety 0) (speed 3))) + (dotimes (iv1 2 0) + (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass + (print (if (< iv1 iv1) + (logand (ash iv1 iv1) 1) + iv1))))) + +;;; MISC.435: lambda var substitution in a deleted code. +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d) + (declare (notinline aref logandc2 gcd make-array)) + (declare + (optimize (space 0) (safety 0) (compilation-speed 3) + (speed 3) (debug 1))) + (progn + (tagbody + (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) + (declare (dynamic-extent v2)) + (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) + tag2) + 0))) + 3021871717588 -866608 -2 -17194))) + +;;; MISC.436, 438: lost reoptimization +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -2917822 2783884) a)) + (declare (type (integer 0 160159) b)) + (declare (ignorable a b)) + (declare + (optimize (compilation-speed 1) + (speed 3) + (safety 3) + (space 0) + ; #+sbcl (sb-c:insert-step-conditions 0) + (debug 0))) + (if + (oddp + (loop for + lv1 + below + 2 + count + (logbitp 0 + (1- + (ash b + (min 8 + (count 0 + '(-10197561 486 430631291 + 9674068)))))))) + b + 0))) + 1265797 110757))) + +(assert (zerop (funcall + (compile + nil + ' (lambda (a) + (declare (type (integer 0 1696) a)) + ; (declare (ignorable a)) + (declare (optimize (space 2) (debug 0) (safety 1) + (compilation-speed 0) (speed 1))) + (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) + 805))) + +;;; bug #302 +(assert (compile + nil + '(lambda (s ei x y) + (declare (type (simple-array function (2)) s) (type ei ei)) + (funcall (aref s ei) x y)))) + +;;; MISC.320: ir1-transform can create an intercomponent reference to +;;; a DEFINED-FUN. +(assert (eql 102 (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 3) (space 0) (safety 2) + (debug 2) (compilation-speed 0))) + (catch 'ct2 + (elt '(102) + (flet ((%f12 () (rem 0 -43))) + (multiple-value-call #'%f12 (values)))))))))) + +;;; MISC.437: lost reoptimization after FLUSH-DEST +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d e) + (declare (notinline values complex eql)) + (declare + (optimize (compilation-speed 3) + (speed 3) + (debug 1) + (safety 1) + (space 0))) + (flet ((%f10 + (f10-1 f10-2 f10-3 + &optional (f10-4 (ignore-errors 0)) (f10-5 0) + &key &allow-other-keys) + (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) + (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) + 80043 74953652306 33658947 -63099937105 -27842393))) + +;;; bug #351 -- program-error for malformed LET and LET*, including those +;;; resulting from SETF of LET. +(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops))) + (compile nil '(lambda () (let* :bogus-let* :oops))) + (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) + (assert (functionp fun)) + (multiple-value-bind (res err) (ignore-errors (funcall fun)) + (assert (not res)) + (assert (typep err 'program-error))))