tests/fast-eval.impure.lisp

   1 ;;;; various tests of the new interpreter
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 #-sb-fasteval
  15 (sb-ext:exit :code 104)
  16
  17 (setf sb-ext:*evaluator-mode* :interpret)
  18
  19 (in-package sb-interpreter)
  20
  21 (test-util:with-test (:name :type-checker-for-function)
  22   ;; The test for (FUNCTION (HAIR) (MORE-HAIR)) is just FUNCTIONP.
  23   ;; The test for not that is (NOT FUNCTION).
  24   (assert (eq (type-checker (specifier-type '(function (cons) cons)))
  25               #'functionp))
  26   (assert (type-checker (specifier-type
  27                          '(not (function (integer) integer))))))
  28
  29 (defvar *invocation-count* 0)
  30
  31 (defmacro what-cell (x)
  32   (incf *invocation-count*)
  33   `(car ,x))
  34
  35 (defun foo (x &optional (howmuch 1)) (incf (what-cell x) howmuch))
  36
  37 (test-util:with-test (:name :interpreter-macro-cache-flush)
  38   (let ((cell (cons 0 0)))
  39     (foo cell)
  40     (foo cell)
  41     (foo cell)
  42     (assert (= *invocation-count* 1)) ; once only
  43     (assert (= (car cell) 3))
  44     (defmacro what-cell (x)
  45       (incf *invocation-count*)
  46       `(cdr ,x))
  47     ;; Even though INCF's definition is unchanged, the expansion of INCF
  48     ;; is invalidated by the change to the definition of WHAT-CELL.
  49     (foo cell 10)
  50     (foo cell 10)
  51     (foo cell 10)
  52     (assert (= *invocation-count* 2)) ; once more
  53     (assert (= (cdr cell) 30))))
  54
  55 (test-util:with-test (:name :interpreter-eval-if-cond-nil-nil)
  56   (let ((x 0))
  57     (flet ((foo () (setq x 1)))
  58       ;; this was accidentally optimizing out the call to FOO
  59       (if (foo) nil nil)
  60       (assert (= x 1)))))
  61
  62 (defmacro expect-type-error (form)
  63   `(handler-case ,form
  64      (type-error ())
  65      (:no-error () (error "Should have gotten a TYPE-ERROR"))))
  66
  67 (defmacro expect-bad-key-error (form)
  68   `(handler-case ,form
  69     (error (c)
  70       (assert (search "not in the allowed set"
  71                       (write-to-string c :escape nil))))
  72     (:no-error () (error "Expected an error"))))
  73
  74 (defmacro expect-odd-keys-error (form)
  75   `(handler-case ,form
  76      (error (c)
  77        (assert (search "odd number" (simple-condition-format-control c))))
  78      (:no-error () (error "Expected an error"))))
  79
  80 (test-util:with-test (:name :interpreter-keyword-parsing)
  81   ;; Keyword parsing
  82   ;; No error - &allow-other-keys was specified.
  83   (validate-keywords '(:foo 3 :bar 2 :baz 3) 1 #(:foo))
  84
  85   (expect-odd-keys-error (validate-keywords '(:bar) 1 #(:foo)))
  86
  87   ;; :ALLOW-OTHER-KEYS key is always allowed even if its value is nil.
  88   (validate-keywords '(:a 1 :allow-other-keys nil :b 2)
  89                      (ash 3 3) #(:a :b :c))
  90
  91   ;; :X is not allowed
  92   (expect-bad-key-error
  93    (validate-keywords '(:a 1 :x nil :b 2) (ash 3 3) #(:a :b :c)))
  94
  95   ;; As with all keywords, only the first value matters.
  96   (expect-bad-key-error
  97    (validate-keywords '(:a 1 :allow-other-keys nil :allow-other-keys t :x 2)
  98                       (ash 3 3) #(:a :b :c)))
  99
 100   ;; here it's T
 101   (validate-keywords '(:a 1 :allow-other-keys t :allow-other-keys nil :x 2)
 102                      (ash 3 3) #(:a :b :c))
 103   ;; here we short-cicuit after seeing T but still have to check for ODDP
 104   (expect-odd-keys-error
 105    (validate-keywords '(:a 1 :allow-other-keys t :allow-other-keys nil :x)
 106                       (ash 3 3) #(:a :b :c)))
 107
 108   (defun foo (x &optional b c &key akey) (list x b c akey))
 109   ;; The ODDP check occurs only on actual args that remain after
 110   ;; processing optional arguments.
 111   ;; No errors should result from these calls.
 112   (foo 1 2)
 113   (foo 1 2 3)
 114   (foo 1 2 3 :akey 'hi))
 115
 116 (test-util:with-test (:name :interpreter-type-checking)
 117
 118   (expect-type-error (the integer (values 'a 1 2)))
 119
 120   ;; "Just do it"
 121   (locally (declare (optimize (safety 0))) (the integer (values 'a 1 2)))
 122
 123   ;; THE returns multiple values even if not a VALUES type-specifier.
 124   (let ((l (multiple-value-call #'list
 125              (the integer (values 1 'foo 'bar)))))
 126     (assert (= (length l) 3)))
 127
 128   ;; Too many values in a "strict" THE form are not permitted.
 129   (expect-type-error (the (values integer &optional) (values 1 2)))
 130
 131   ;; A trailing type of which NIL is a member (so LIST,SYMBOL,T at least)
 132   ;; causes (THE VALUES ...) to accept absence of a value. By definition the
 133   ;; missing values are NIL. While this seems liberal, so far as VALUES
 134   ;; expressing a shape similar to DESTRUCTURING-BIND, CLHS draws attention
 135   ;; to it specifically:
 136   ;;
 137   ;;  "It is permissible for _form_ to yield a different number of values than
 138   ;;  are specified by value-type, provided that the values for which types are
 139   ;;  declared are indeed of those types. Missing values are treated as nil
 140   ;;  for the purpose of checking their types"
 141   (dolist (trailing-type '(symbol t))
 142     (eval `(the (values integer ,trailing-type) 4))
 143     (eval `(the (values integer ,trailing-type) (values 4 'foo)))
 144     (eval `(the (values integer ,trailing-type) (values 4 'foo 5))))
 145
 146   ;; But a strict THE form does not allow this liberty.
 147   (expect-type-error (the (values integer symbol &optional) 4))
 148
 149   (defun f () 'hi)
 150   (defun g (x) (length (string x)))
 151   (defun h ()
 152     (let* ((x (f))
 153            (x (g x)))
 154       (declare (fixnum x))
 155       x))
 156
 157   ;; The first binding of X in h is to a symbol, which is fine.
 158   ;; The FIXNUM declaration applies to the _second_ binding named X.
 159   (h)
 160
 161   ;; The SETQ is not valid because X is restricted to fixnum.
 162   (expect-type-error
 163    (let* ((x 3)
 164           (y (setq x 'fred)))
 165      (declare (fixnum x))))
 166
 167   (defun foo1 ()
 168     (the (values integer symbol &optional string) (bar)))
 169   (defun foo2 ()
 170     (the (values integer symbol string) (bar)))
 171   (defun foo3 ()
 172     (the (values integer &optional) (bar)))
 173
 174   (defun bar () (values 1 'hi))
 175
 176   (foo1) ; ok
 177   (expect-type-error (foo2)) ; didn't get a string as 3rd value
 178   (expect-type-error (foo3)) ; got too many values
 179
 180   (expect-type-error
 181    (the (values integer symbol string) (bar)))
 182
 183   (defun no-vals () (values))
 184
 185   (handler-case (let ((x (the integer (no-vals)))) x)
 186     (simple-error ())
 187     (:no-error () (error "Should have gotten an ERROR")))
 188
 189   (defmacro nice-macro (a b)
 190     (declare (type (member :first :second) a))
 191     (case a
 192       (:first `(car ,b))
 193       (:second `(cadr ,b))))
 194
 195   (assert (equal (macroexpand-1 '(nice-macro :first (x)))
 196                  '(car (x))))
 197   ;; macro should fail.
 198   (expect-type-error (macroexpand '(nice-macro :third (x))))
 199
 200   ;; SETQ of MUMBLE which is a "free" (not bound) typed special variable
 201   (expect-type-error
 202    (let* ((foo 3) (baz foo))
 203       (declare (special foo mumble) (real mumble))
 204       (setq mumble 'a)))
 205
 206   (expect-type-error
 207    (let ((x 3))
 208       (declare (special x) (integer x))
 209       ; (print x)
 210       (let ((x 'a))
 211         (declare (symbol x))
 212         ; (print x)
 213         (locally (declare (special x))
 214           ; (print x)
 215           ;; this references the special X, not the lexical X
 216           (setq x 'foo)))))
 217
 218   ;; This works due to short-circuiting within TYPEP
 219   (let ((x 3)) (declare (type (or integer blurf) x)) x)
 220
 221   ;; This fails because the unknown type is tested first
 222   (handler-case (let ((x 3)) (declare (type (or blurf integer) x)) x)
 223     (simple-error ()) ; "unknown type"
 224     (:no-error () "Expected an ERROR")))
 225
 226 (test-util:with-test (:name :tagbody-if-optimizer)
 227   (assert
 228    (string= "ABC"
 229             (with-output-to-string (*standard-output*)
 230              (tagbody
 231               (go :a)
 232               :b
 233               (princ :b)
 234               (if nil (go :b))
 235               (go :c)
 236               :a
 237               (princ :a)
 238               (go :b)
 239               :c
 240               (princ :c))))))
 241
 242 (macrolet ((foo= (x y) `(= (the fixnum ,x) (the fixnum ,y))))
 243   (declare (optimize speed))
 244   (declaim (inline foo-compare))
 245   (defun foo-compare (a b) (foo= a b)))
 246
 247 (test-util:with-test (:name :inline-lexenv-not-too-hairy)
 248   (assert (sb-c::fun-name-inline-expansion 'foo-compare)))
 249
 250 (defmacro use-hairy-env (x &environment e)
 251   (list 'list
 252         (eql (sb-interpreter::env-from-lexenv e) :compile)
 253         (sb-int:eval-in-lexenv x e)))
 254
 255 ;;; Assert that USE-HAIRY-ENV can be invoked such that when it calls
 256 ;;; EVAL-IN-LEXENV on an environment object that is too complex,
 257 ;;; it works anyway. Of course don't actually do this :-)
 258 ;;; Arguably the interpreter could be modified such that it only chokes
 259 ;;; if you _actually_ try to reference parts of the complex lexenv
 260 ;;; that you're not allowed to, but that's a whole other ball of wax.
 261 (test-util:with-test (:name :eval-in-complex-lexenv)
 262   (let ((answer
 263          (funcall (compile nil '(lambda (a) (cons a (use-hairy-env (+ 1 2)))))
 264                   45)))
 265     (assert (eql (first answer) 45))
 266     ;; ensure that the lambda environment could not be handled by the interpreter
 267     (assert (eql (second answer) t))
 268     (assert (eql (third answer) 3))))
 269
 270 (test-util:with-test (:name :exited-block)
 271   (handler-case (funcall (let ((x 1)) (block b (lambda () (return-from b)))))
 272     (condition (c)
 273       (assert (and (typep c 'sb-int:simple-control-error)
 274                    (search "exited block" (simple-condition-format-control c)))))
 275     (:no-error (&rest whatever) (error "Expected an error"))))
 276
 277 (test-util:with-test (:name :exited-tagbody)
 278   (handler-case (funcall
 279                  (block zot
 280                    (tagbody
 281                     (return-from zot (let ((x 1)) (lambda () (go foo))))
 282                     foo)))
 283      (condition (c)
 284        (assert (and (typep c 'sb-int:simple-control-error)
 285                     (search "exited tagbody"
 286                             (simple-condition-format-control c)))))
 287      (:no-error (&rest whatever) (error "Expected an error"))))
 288
 289 (test-util:with-test (:name :argless-lambda)
 290   (assert (eq ((lambda () (declare (special *some-var*)) (setq *some-var* t)))
 291               t)))