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 (invoke-restart 'run-tests::skip-file)
  15
  16 (setf sb-ext:*evaluator-mode* :interpret)
  17
  18 (in-package sb-interpreter)
  19
  20 (test-util:with-test (:name :write-bogus-function-instance)
  21   (write-to-string
  22    (sb-pcl::class-prototype (find-class 'sb-kernel:interpreted-function))))
  23
  24 (test-util:with-test (:name :type-checker-for-function)
  25   ;; The test for (FUNCTION (HAIR) (MORE-HAIR)) is just FUNCTIONP.
  26   ;; The test for not that is (NOT FUNCTION).
  27   (assert (eq (type-checker (specifier-type '(function (cons) cons)))
  28               #'functionp))
  29   (assert (type-checker (specifier-type
  30                          '(not (function (integer) integer))))))
  31
  32 (defvar *invocation-count* 0)
  33
  34 (defmacro what-cell (x)
  35   (incf *invocation-count*)
  36   `(car ,x))
  37
  38 (defun foo (x &optional (howmuch 1)) (incf (what-cell x) howmuch))
  39
  40 (test-util:with-test (:name :interpreter-macro-cache-flush)
  41   (let ((cell (cons 0 0)))
  42     (foo cell)
  43     (foo cell)
  44     (foo cell)
  45     (assert (= *invocation-count* 1)) ; once only
  46     (assert (= (car cell) 3))
  47     (defmacro what-cell (x)
  48       (incf *invocation-count*)
  49       `(cdr ,x))
  50     ;; Even though INCF's definition is unchanged, the expansion of INCF
  51     ;; is invalidated by the change to the definition of WHAT-CELL.
  52     (foo cell 10)
  53     (foo cell 10)
  54     (foo cell 10)
  55     (assert (= *invocation-count* 2)) ; once more
  56     (assert (= (cdr cell) 30))))
  57
  58 (test-util:with-test (:name :interpreter-eval-if-cond-nil-nil)
  59   (let ((x 0))
  60     (flet ((foo () (setq x 1)))
  61       ;; this was accidentally optimizing out the call to FOO
  62       (if (foo) nil nil)
  63       (assert (= x 1)))))
  64
  65 (defmacro expect-type-error (form)
  66   `(handler-case ,form
  67      (type-error ())
  68      (:no-error () (error "Should have gotten a TYPE-ERROR"))))
  69
  70 (defmacro expect-bad-key-error (form)
  71   `(handler-case ,form
  72     (error (c)
  73       (assert (search "not in the allowed set"
  74                       (write-to-string c :escape nil))))
  75     (:no-error () (error "Expected an error"))))
  76
  77 (defmacro expect-odd-keys-error (form)
  78   `(handler-case ,form
  79      (error (c)
  80        (assert (search "odd number" (simple-condition-format-control c))))
  81      (:no-error () (error "Expected an error"))))
  82
  83 (test-util:with-test (:name :interpreter-keyword-parsing)
  84   ;; Keyword parsing
  85   ;; No error - &allow-other-keys was specified.
  86   (validate-keywords '(:foo 3 :bar 2 :baz 3) 1 #(:foo))
  87
  88   (expect-odd-keys-error (validate-keywords '(:bar) 1 #(:foo)))
  89
  90   ;; :ALLOW-OTHER-KEYS key is always allowed even if its value is nil.
  91   (validate-keywords '(:a 1 :allow-other-keys nil :b 2)
  92                      (ash 3 3) #(:a :b :c))
  93
  94   ;; :X is not allowed
  95   (expect-bad-key-error
  96    (validate-keywords '(:a 1 :x nil :b 2) (ash 3 3) #(:a :b :c)))
  97
  98   ;; As with all keywords, only the first value matters.
  99   (expect-bad-key-error
 100    (validate-keywords '(:a 1 :allow-other-keys nil :allow-other-keys t :x 2)
 101                       (ash 3 3) #(:a :b :c)))
 102
 103   ;; here it's T
 104   (validate-keywords '(:a 1 :allow-other-keys t :allow-other-keys nil :x 2)
 105                      (ash 3 3) #(:a :b :c))
 106   ;; here we short-cicuit after seeing T but still have to check for ODDP
 107   (expect-odd-keys-error
 108    (validate-keywords '(:a 1 :allow-other-keys t :allow-other-keys nil :x)
 109                       (ash 3 3) #(:a :b :c)))
 110
 111   (defun foo (x &optional b c &key akey) (list x b c akey))
 112   ;; The ODDP check occurs only on actual args that remain after
 113   ;; processing optional arguments.
 114   ;; No errors should result from these calls.
 115   (foo 1 2)
 116   (foo 1 2 3)
 117   (foo 1 2 3 :akey 'hi))
 118
 119 (test-util:with-test (:name :interpreter-type-checking)
 120
 121   (expect-type-error (the integer (values 'a 1 2)))
 122
 123   ;; "Just do it"
 124   (locally (declare (optimize (safety 0))) (the integer (values 'a 1 2)))
 125
 126   ;; THE returns multiple values even if not a VALUES type-specifier.
 127   (let ((l (multiple-value-call #'list
 128              (the integer (values 1 'foo 'bar)))))
 129     (assert (= (length l) 3)))
 130
 131   ;; Too many values in a "strict" THE form are not permitted.
 132   (expect-type-error (the (values integer &optional) (values 1 2)))
 133
 134   ;; A trailing type of which NIL is a member (so LIST,SYMBOL,T at least)
 135   ;; causes (THE VALUES ...) to accept absence of a value. By definition the
 136   ;; missing values are NIL. While this seems liberal, so far as VALUES
 137   ;; expressing a shape similar to DESTRUCTURING-BIND, CLHS draws attention
 138   ;; to it specifically:
 139   ;;
 140   ;;  "It is permissible for _form_ to yield a different number of values than
 141   ;;  are specified by value-type, provided that the values for which types are
 142   ;;  declared are indeed of those types. Missing values are treated as nil
 143   ;;  for the purpose of checking their types"
 144   (dolist (trailing-type '(symbol t))
 145     (eval `(the (values integer ,trailing-type) 4))
 146     (eval `(the (values integer ,trailing-type) (values 4 'foo)))
 147     (eval `(the (values integer ,trailing-type) (values 4 'foo 5))))
 148
 149   ;; But a strict THE form does not allow this liberty.
 150   (expect-type-error (the (values integer symbol &optional) 4))
 151
 152   (defun f () 'hi)
 153   (defun g (x) (length (string x)))
 154   (defun h ()
 155     (let* ((x (f))
 156            (x (g x)))
 157       (declare (fixnum x))
 158       x))
 159
 160   ;; The first binding of X in h is to a symbol, which is fine.
 161   ;; The FIXNUM declaration applies to the _second_ binding named X.
 162   (h)
 163
 164   ;; The SETQ is not valid because X is restricted to fixnum.
 165   (expect-type-error
 166    (let* ((x 3)
 167           (y (setq x 'fred)))
 168      (declare (fixnum x))))
 169
 170   (defun foo1 ()
 171     (the (values integer symbol &optional string) (bar)))
 172   (defun foo2 ()
 173     (the (values integer symbol string) (bar)))
 174   (defun foo3 ()
 175     (the (values integer &optional) (bar)))
 176
 177   (defun bar () (values 1 'hi))
 178
 179   (foo1) ; ok
 180   (expect-type-error (foo2)) ; didn't get a string as 3rd value
 181   (expect-type-error (foo3)) ; got too many values
 182
 183   (expect-type-error
 184    (the (values integer symbol string) (bar)))
 185
 186   (defun no-vals () (values))
 187
 188   (handler-case (let ((x (the integer (no-vals)))) x)
 189     (type-error ())
 190     (:no-error () (error "Should have gotten an ERROR")))
 191
 192   (defmacro nice-macro (a b)
 193     (declare (type (member :first :second) a))
 194     (case a
 195       (:first `(car ,b))
 196       (:second `(cadr ,b))))
 197
 198   (assert (equal (macroexpand-1 '(nice-macro :first (x)))
 199                  '(car (x))))
 200   ;; macro should fail.
 201   (expect-type-error (macroexpand '(nice-macro :third (x))))
 202
 203   ;; SETQ of MUMBLE which is a "free" (not bound) typed special variable
 204   (expect-type-error
 205    (let* ((foo 3) (baz foo))
 206       (declare (special foo mumble) (real mumble))
 207       (setq mumble 'a)))
 208
 209   (expect-type-error
 210    (let ((x 3))
 211       (declare (special x) (integer x))
 212       ; (print x)
 213       (let ((x 'a))
 214         (declare (symbol x))
 215         ; (print x)
 216         (locally (declare (special x))
 217           ; (print x)
 218           ;; this references the special X, not the lexical X
 219           (setq x 'foo)))))
 220
 221   ;; This works due to short-circuiting within TYPEP
 222   (let ((x 3)) (declare (type (or integer blurf) x)) x)
 223
 224   ;; This fails under a naive OR type parser, but a different parse might
 225   ;; equate (OR BLURF INTEGER) with (OR INTEGER BLURF), which just worked fine in the
 226   ;; previous test, or could force known types to appear to the left of unknowns
 227   ;; in a union. So even dropping the values-specifier-type cache may not make this fail.
 228   ;; I'm keeping it in case I change my mind again though.
 229   #+nil
 230   (handler-case (let ((x 3)) (declare (type (or blurf integer) x)) x)
 231     (simple-error ()) ; "unknown type"
 232     (:no-error (&rest ignore) (error "Expected an ERROR"))))
 233
 234 (test-util:with-test (:name :tagbody-if-optimizer)
 235   (assert
 236    (string= "ABC"
 237             (with-output-to-string (*standard-output*)
 238              (tagbody
 239               (go :a)
 240               :b
 241               (princ :b)
 242               (if nil (go :b))
 243               (go :c)
 244               :a
 245               (princ :a)
 246               (go :b)
 247               :c
 248               (princ :c))))))
 249
 250 (macrolet ((foo= (x y) `(= (the fixnum ,x) (the fixnum ,y))))
 251   (declare (optimize speed))
 252   (declaim (inline foo-compare))
 253   (defun foo-compare (a b) (foo= a b)))
 254
 255 (test-util:with-test (:name :inline-lexenv-not-too-hairy)
 256   (assert (sb-c::fun-name-inline-expansion 'foo-compare)))
 257
 258 (defmacro use-hairy-env (x &environment e)
 259   (list 'list
 260         (eql (sb-interpreter::env-from-lexenv e) :compile)
 261         (sb-int:eval-in-lexenv x e)))
 262
 263 ;;; Assert that USE-HAIRY-ENV can be invoked such that when it calls
 264 ;;; EVAL-IN-LEXENV on an environment object that is too complex,
 265 ;;; it works anyway. Of course don't actually do this :-)
 266 ;;; Arguably the interpreter could be modified such that it only chokes
 267 ;;; if you _actually_ try to reference parts of the complex lexenv
 268 ;;; that you're not allowed to, but that's a whole other ball of wax.
 269 (test-util:with-test (:name :eval-in-complex-lexenv)
 270   (let ((answer
 271          (funcall (compile nil '(lambda (a) (cons a (use-hairy-env (+ 1 2)))))
 272                   45)))
 273     (assert (eql (first answer) 45))
 274     ;; ensure that the lambda environment could not be handled by the interpreter
 275     (assert (eql (second answer) t))
 276     (assert (eql (third answer) 3))))
 277
 278 (test-util:with-test (:name :exited-block)
 279   (handler-case (funcall (let ((x 1)) (block b (lambda () (return-from b)))))
 280     (condition (c)
 281       (assert (and (typep c 'sb-int:simple-control-error)
 282                    (search "exited block" (simple-condition-format-control c)))))
 283     (:no-error (&rest whatever) (error "Expected an error"))))
 284
 285 (test-util:with-test (:name :exited-tagbody)
 286   (handler-case (funcall
 287                  (block zot
 288                    (tagbody
 289                     (return-from zot (let ((x 1)) (lambda () (go foo))))
 290                     foo)))
 291      (condition (c)
 292        (assert (and (typep c 'sb-int:simple-control-error)
 293                     (search "exited tagbody"
 294                             (simple-condition-format-control c)))))
 295      (:no-error (&rest whatever) (error "Expected an error"))))
 296
 297 (test-util:with-test (:name :argless-lambda)
 298   (assert (eq ((lambda () (declare (special *some-var*)) (setq *some-var* t)))
 299               t)))
 300
 301 (test-util:with-test (:name :typecheck-symbol-not-null)
 302   (funcall (lambda (x) (the (and symbol (not null)) x))
 303            'foo))
 304
 305 (defstruct testme x)
 306 (test-util:with-test (:name :compiled-equalp-method)
 307   (assert (compiled-function-p
 308            (sb-kernel:layout-equalp-impl
 309             (sb-kernel:find-layout 'testme)))))
 310 (let ((f #'testme-x))
 311   (let ((source-loc (sb-interpreter:fun-source-location f)))
 312     (setf (slot-value source-loc 'sb-c::namestring) "myfile.lisp")))
 313 (defun foo (s) (testme-x s))
 314 (test-util:with-test (:name :source-namestring)
 315   (assert (string= (sb-kernel::function-file-namestring #'testme-x)
 316                    "myfile.lisp"))
 317   (foo (make-testme))
 318   ;; check that implicit compilation happened
 319   (assert (= (sb-kernel:widetag-of #'testme-x) sb-vm:simple-fun-widetag))
 320   ;; check that source location namestring was preserved
 321   (assert (string= (sb-kernel::function-file-namestring #'testme-x)
 322                    "myfile.lisp")))
 323
 324 (macrolet ((some-things () ''(bit-vector string)))
 325   (deftype thingz (&optional d)
 326     `(or ,@(mapcar (lambda (x) `(,x ,d)) (some-things)))))
 327 ;;; FUNCTION-LAMBDA-EXPRESSION could incorrectly return NIL for the second value
 328 (test-util:with-test (:name :fun-lambda-expr-closure)
 329   (assert (nth-value 1 (function-lambda-expression (sb-int:info :type :expander 'thingz))))
 330   ;; and make sure the expander actually works
 331   (assert (typep "hey" '(thingz 3))))
 332
 333 (defpackage fancypkg (:use "CL" "SB-EXT") (:export make-mystruct mystruct-x))
 334 (in-package fancypkg)
 335 (defstruct mystruct (x 3) y)
 336 (in-package "CL-USER")
 337 (lock-package "FANCYPKG")
 338
 339 (defun f ()
 340   (fancypkg:mystruct-x (fancypkg:make-mystruct)))
 341 (test-util:with-test (:name :jit-compiled-struct-accessor-locked-pkg)
 342   (assert (eql (f) 3))
 343   (assert (not (compiled-function-p #'f)))
 344   (assert (compiled-function-p #'fancypkg:mystruct-x)))