X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=6b01a474db4c1e3425f6beb6e8c16c8cad50fda8;hb=35f870eecfcaaba496d54e0f290b09e63884f74c;hp=45d030b7cb539d719ad11041c48c232e09c2d309;hpb=dc47746daf73c65126a80b723ad52b8327b06960;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 45d030b..6b01a47 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -15,7 +15,12 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + +(load "test-util.lisp") (load "assertoid.lisp") +(use-package "TEST-UTIL") (use-package "ASSERTOID") ;;; Old CMU CL code assumed that the names of "keyword" arguments are @@ -1123,4 +1128,292 @@ ans))))))) (if (and (minusp nn) (oddp nn)) (- besn) besn)))) + +;;; bug 233b: lvar lambda-var equality in constraint propagation + +;; Put this in a separate function. +(defun test-constraint-propagation/ref () + (let ((x nil)) + (if (multiple-value-prog1 x (setq x t)) + 1 + x))) + +(test-util:with-test (:name (:compiler :constraint-propagation :ref)) + (assert (eq t (test-constraint-propagation/ref)))) + +;; Put this in a separate function. +(defun test-constraint-propagation/typep (x y) + (if (typep (multiple-value-prog1 x (setq x y)) + 'double-float) + (+ x 1d0) + (+ x 2))) + +(test-util:with-test (:name (:compiler :constraint-propagation :typep)) + (assert (= 6.0d0 (test-constraint-propagation/typep 1d0 5)))) + +(test-util:with-test (:name (:compiler :constraint-propagation :eq/eql)) + (assert (eq :right (let ((c :wrong)) + (if (eq (let ((x c)) + (setq c :right) + x) + :wrong) + c + 0))))) + +;;; Put this in a separate function. +(defun test-constraint-propagation/cast (x) + (when (the double-float (multiple-value-prog1 + x + (setq x (1+ x)))) + x)) + +(test-util:with-test (:name (:compiler :constraint-propagation :cast)) + (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 "<")) + ((char= char #\>) + (add-string ">")) + ((char= char #\&) + (add-string "&")) + ((char= char #\') + (add-string "'")) + ((char= char #\newline) + (add-string "
")) + ((char= char #\") + (if left-quote? (add-string "“") (add-string "”")) + (setf left-quote? (not left-quote?))) + (t + (add-char char)))) + (setf (fill-pointer result) index) + (coerce result 'string))))) + +;;; Callign thru constant symbols +(require :sb-introspect) + +(declaim (inline target-fun)) +(defun target-fun (arg0 arg1) + (+ arg0 arg1)) +(declaim (notinline target-fun)) + +(defun test-target-fun-called (fun res) + (assert (member #'target-fun + (sb-introspect:find-function-callees #'caller-fun-1))) + (assert (equal (funcall fun) res))) + +(defun caller-fun-1 () + (funcall 'target-fun 1 2)) +(test-target-fun-called #'caller-fun-1 3) + +(defun caller-fun-2 () + (declare (inline target-fun)) + (apply 'target-fun 1 '(3))) +(test-target-fun-called #'caller-fun-2 4) + +(defun caller-fun-3 () + (flet ((target-fun (a b) + (- a b))) + (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4)))) +(test-target-fun-called #'caller-fun-3 (list -3 5)) + +;;; Reported by NIIMI Satoshi +;;; Subject: [Sbcl-devel] compilation error with optimization +;;; Date: Sun, 09 Apr 2006 17:36:05 +0900 +(defun test-minimal-debug-info-for-unstored-but-used-parameter (n a) + (declare (optimize (speed 3) + (debug 1))) + (if (= n 0) + 0 + (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a))) + +;;; &KEY arguments with non-constant defaults. +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) x) +(defstruct tricky-defaults + (fun #'identity :type function) + (num (opaque-identity 3) :type fixnum)) +(macrolet ((frob (form expected-expected-type) + `(handler-case ,form + (type-error (c) (assert (eq (type-error-expected-type c) + ',expected-expected-type))) + (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals))))) + (frob (make-tricky-defaults :fun 3) function) + (frob (make-tricky-defaults :num #'identity) fixnum)) + +(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3))) + (declare (optimize safety) (type integer key)) + key)))) + (assert (= (funcall fun) 3)) + (assert (= (funcall fun :key 17) 17)) + (handler-case (funcall fun :key t) + (type-error (c) (assert (eq (type-error-expected-type c) 'integer))) + (:no-error (&rest vals) (error "no error")))) + +;;; Basic compiler-macro expansion +(define-compiler-macro test-cmacro-0 () ''expanded) + +(assert (eq 'expanded (funcall (lambda () (test-cmacro-0))))) + +;;; FUNCALL forms in compiler macros, lambda-list parsing +(define-compiler-macro test-cmacro-1 + (&whole whole a &optional b &rest c &key d) + (list whole a b c d)) + +(macrolet ((test (form a b c d) + `(let ((form ',form)) + (destructuring-bind (whole a b c d) + (funcall (compiler-macro-function 'test-cmacro-1) form nil) + (assert (equal whole form)) + (assert (eql a ,a)) + (assert (eql b ,b)) + (assert (equal c ,c)) + (assert (eql d ,d))))) ) + (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3) + (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13)) + +;;; FUNCALL forms in compiler macros, expansions +(define-compiler-macro test-cmacro-2 () ''ok) + +(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2))))) +(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2))))) + +;;; Shadowing of compiler-macros by local functions +(define-compiler-macro test-cmacro-3 () ''global) + +(defmacro find-cmacro-3 (&environment env) + (compiler-macro-function 'test-cmacro-3 env)) + +(assert (funcall (lambda () (find-cmacro-3)))) +(assert (not (funcall (lambda () (flet ((test-cmacro-3 ())) + (find-cmacro-3)))))) +(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (test-cmacro-3)))))) +(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (funcall #'test-cmacro-3)))))) +(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local)) + (funcall 'test-cmacro-3)))))) + +;;; Local NOTINLINE & INLINE +(defun test-cmacro-4 () 'fun) +(define-compiler-macro test-cmacro-4 () ''macro) + +(assert (eq 'fun (funcall (lambda () + (declare (notinline test-cmacro-4)) + (test-cmacro-4))))) + +(assert (eq 'macro (funcall (lambda () + (declare (inline test-cmacro-4)) + (test-cmacro-4))))) + +;;; SETF function compiler macros +(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok) + +(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot))))) +(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot))))) + +;;; Step instrumentation breaking type-inference +(handler-bind ((warning #'error)) + (assert (= 42 (funcall (compile nil '(lambda (v x) + (declare (optimize sb-c:insert-step-conditions)) + (if (typep (the function x) 'fixnum) + (svref v (the function x)) + (funcall x)))) + nil (constantly 42))))) + +;;; bug 368: array type intersections in the compiler +(defstruct e368) +(defstruct i368) +(defstruct g368 + (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null))) +(defstruct s368 + (g368 (error "missing :G368") :type g368 :read-only t)) +(declaim (ftype (function (fixnum (vector i368) e368) t) r368)) +(declaim (ftype (function (fixnum (vector e368)) t) h368)) +(defparameter *h368-was-called-p* nil) +(defun nsu (vertices e368) + (let ((i368s (g368-i368s (make-g368)))) + (let ((fuis (r368 0 i368s e368))) + (format t "~&FUIS=~S~%" fuis) + (or fuis (h368 0 i368s))))) +(defun r368 (w x y) + (declare (ignore w x y)) + nil) +(defun h368 (w x) + (declare (ignore w x)) + (setf *h368-was-called-p* t) + (make-s368 :g368 (make-g368))) +(let ((nsu (nsu #() (make-e368)))) + (format t "~&NSU returned ~S~%" nsu) + (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*) + (assert (s368-p nsu)) + (assert *h368-was-called-p*)) + +;;; bug 367: array type intersections in the compiler +(defstruct e367) +(defstruct i367) +(defstruct g367 + (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null))) +(defstruct s367 + (g367 (error "missing :G367") :type g367 :read-only t)) +(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367)) +(declaim (ftype (function ((vector e367)) (values)) h367)) +(defun frob-367 (v w) + (let ((x (g367-i367s (make-g367)))) + (let* ((y (or (r367 x w) + (h367 x))) + (z (s367-g367 y))) + (format t "~&Y=~S Z=~S~%" y z) + (g367-i367s z)))) +(defun r367 (x y) (declare (ignore x y)) nil) +(defun h367 (x) (declare (ignore x)) (values)) +(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367))) + (assert (not res)) + (assert (typep err 'type-error))) + +(handler-case + (delete-file (compile-file "circ-tree-test.lisp")) + (storage-condition (e) + (error e))) + +;;; warnings due to step-insturmentation +(defclass debug-test-class () ()) +(handler-case + (compile nil '(lambda () + (declare (optimize (debug 3))) + (defmethod print-object ((x debug-test-class) s) + (call-next-method)))) + ((and (not style-warning) warning) (e) + (error e))) + +;;; program-error from bad lambda-list keyword +(assert (eq :ok + (handler-case + (funcall (lambda (&whole x) + (list &whole x))) + (program-error () + :ok)))) +(assert (eq :ok + (handler-case + (let ((*evaluator-mode* :interpret)) + (funcall (eval '(lambda (&whole x) + (list &whole x))))) + (program-error () + :ok)))) + ;;; success