X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Feval.impure.lisp;h=d50708e4fb2cabcd163b684b1f84442077872d70;hb=062283b901155792f65775491aea51481c56faaa;hp=a7f44b78a5dcb4cf8c61901a4aee86f17f6c1e5f;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index a7f44b7..d50708e 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -100,6 +100,58 @@ (assert (constantp (find-class 'symbol))) (assert (constantp #p"")) +;;; More CONSTANTP tests +;;; form constantp sb-int:constant-form-value +(dolist (test '((t t t) + (x nil) + ('x t x) + (:keyword t :keyword) + (42 t 42) + ((if t :ok x) t :ok) + ((if t x :no) nil) + ((progn + (error "oops") + t) nil) + ((progn 1 2 3) t 3) + ((block foo :good) t :good) + ((block foo + (return-from foo t)) nil) + ((progv + (list (gensym)) + '(1) + (+ 1)) nil) + ((progv + '(x) + (list (random 2)) + x) nil) + ((progv + '(x) + '(1) + (1+ x)) t 2) + ((progv '(x) '(t) + (if x 1 2)) t 1) + ((unwind-protect 1 nil) t 1) + ((unwind-protect 1 + (xxx)) nil) + ((the integer 1) t 1) + ((the integer (+ 1 1)) t 2) + ((the integer (foo)) nil) + ((the symbol 1) nil) + ((the "bad type" 1) nil) + ((multiple-value-prog1 + (+ 1 1) + :nada) t 2) + ((multiple-value-prog1 + :nada + (/ 1 0)) nil) + ((/ 1 0) nil) + ((/ 1 1) t 1) + ((+ 1 2) t 3))) + (destructuring-bind (form c &optional v) test + (assert (eql (constantp form) c)) + (when c + (assert (eql v (sb-int:constant-form-value form)))))) + ;;; DEFPARAMETER must assign a dynamic variable (let ((var (gensym))) (assert (equal (eval `(list (let ((,var 1)) @@ -136,5 +188,110 @@ (with-output-to-string (*standard-output*) (eval '(progn (princ ".") (let ((x 42)) t) (princ ".")))))) +;;; IF +(defun true () t) +(defun false () nil) +(defmacro oops () (throw :oops (list))) +(defun test-eval (ok form) (assert (eq ok (catch :oops (eval form))))) +(test-eval t '(if (false) (oops) t)) +(test-eval t '(if (true) t (oops))) +(test-eval nil '(if (not (if (false) t)) (oops))) + +;;; TAGBODY + +;;; As of SBCL 1.0.1.8, TAGBODY should not accept duplicate go tags, +;;; yet choked on two duplicate tags. Note that this test asserts a +;;; failure. +(with-test (:name :tagbody-dual-go-tags) + (progn + (defun tagbody-dual-go-tags () + (restart-case + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'NOT-AN-ERROR)))) + (tagbody :A :A) nil) + (NOT-AN-ERROR () t))) + (assert (tagbody-dual-go-tags)))) + +;;; Ensure that NIL is a valid go tag. +(with-test (:name :tagbody-nil-is-valid-tag) + (progn + (defun tagbody-nil-is-valid-tag () + (tagbody (go NIL) NIL) t) + (assert (tagbody-nil-is-valid-tag)))) + +;;; top-level DECLARE is formally undefined, but we want it to raise +;;; an error rather than silently return NIL. +(defvar *scratch*) +(with-test (:name :toplevel-declare) + (assert (raises-error? (eval '(declare (type pathname *scratch*)))))) + +(with-test (:name (eval :no-compiler-notes)) + (handler-bind ((sb-ext:compiler-note #'error)) + (let ((sb-ext:*evaluator-mode* :compile)) + (eval '(let ((x 42)) + (if nil x))) + (eval '(let ((* 13)) + (let ((x 42) + (y *)) + (declare (optimize speed)) + (+ x y))))))) + +(with-test (:name :bug-238) + (let ((sb-ext:*evaluator-mode* :compile)) + (handler-bind ((sb-ext:compiler-note #'error)) + (eval '(defclass bug-238 () ())) + (eval '(defmethod bug-238 ((x bug-238) (bug-238 bug-238)) + (call-next-method))) + (eval '(handler-case + (with-input-from-string (*query-io* " no") + (yes-or-no-p)) + (simple-type-error () 'error))) + t))) + +(with-test (:name :bug-524707 :skipped-on '(not :sb-eval)) + (let ((*evaluator-mode* :interpret) + (lambda-form '(lambda (x) (declare (fixnum x)) (1+ x)))) + (let ((fun (eval lambda-form))) + (assert (equal lambda-form (function-lambda-expression fun)))))) + +(with-test (:name (eval :source-context-in-compiler)) + (let ((noise (with-output-to-string (*error-output*) + (let ((*evaluator-mode* :compile)) + (eval `(defun source-context-test (x) y)))))) + (with-input-from-string (s noise) + (assert (equal "; in: DEFUN SOURCE-CONTEXT-TEST" (read-line s)))))) + +(with-test (:name (eval :empty-let-is-not-toplevel)) + (let ((sb-ext:*evaluator-mode* :compile)) + (eval `(let () + (defmacro empty-let-is-not-toplevel-x () :macro) + (defun empty-let-is-not-toplevel-fun () + (empty-let-is-not-toplevel-x)))) + (eval `(defun empty-let-is-not-toplevel-x () :fun)) + (assert (eq :fun (empty-let-is-not-toplevel-fun)))) + ;; While at it, test that we get the late binding under + ;; interpreter mode. + #+sb-eval + (let ((sb-ext:*evaluator-mode* :interpret)) + (eval `(let () + (defmacro empty-let-is-not-toplevel-x () :macro) + (defun empty-let-is-not-toplevel-fun () + (empty-let-is-not-toplevel-x)))) + (assert (eq :macro (empty-let-is-not-toplevel-fun))) + (eval `(defun empty-let-is-not-toplevel-x () :fun)) + (assert (eq :fun (empty-let-is-not-toplevel-fun))))) + +(with-test (:name (eval function-lambda-expression)) + (assert (equal `(sb-int:named-lambda eval-fle-1 (x) + (block eval-fle-1 + (+ x 1))) + (function-lambda-expression + (eval `(progn + (defun eval-fle-1 (x) (+ x 1)) + #'eval-fle-1))))) + (assert (equal `(lambda (x y z) (+ x 1 y z)) + (function-lambda-expression + (eval `(lambda (x y z) (+ x 1 y z))))))) + ;;; success -(sb-ext:quit :unix-status 104)