tests/full-eval.impure.lisp

   1 ;;;; various tests of the 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 #-(or sb-eval sb-fasteval) (invoke-restart 'run-tests::skip-file)
  15
  16 (setf sb-ext:*evaluator-mode* :interpret)
  17
  18 (assert (not (typep (lambda ()) 'compiled-function)))
  19
  20 (assert (not (compiled-function-p (lambda ()))))
  21
  22 (let ((seen-forms (make-hash-table :test 'equal)))
  23   (let ((*macroexpand-hook* (compile nil
  24                                      `(lambda (fun form env)
  25                                         (setf (gethash form ,seen-forms) t)
  26                                         (funcall fun form env)))))
  27     (let ((fun (lambda ()
  28                  (when t nil))))
  29       (assert (not (gethash '(when t nil) seen-forms)))
  30       (funcall fun)
  31       (assert (gethash '(when t nil) seen-forms)))))
  32
  33 ;;; defstruct constructor
  34 (let ((sb-ext:*evaluator-mode* :interpret))
  35   (eval '(progn
  36           (defstruct evaluated-struct
  37             (pointer nil)
  38             (word 0 :type sb-ext:word)
  39             (single 0.0 :type single-float)
  40             (double 0.0d0 :type double-float)
  41             (csingle (complex 0.0 0.0) :type (complex single-float))
  42             (cdouble (complex 0.0d0 0.0d0) :type (complex double-float)))
  43           (defvar *evaluated-struct* (make-evaluated-struct
  44                                       :pointer :foo
  45                                       :word 42
  46                                       :single 1.23
  47                                       :double 2.34d0
  48                                       :csingle (complex 1.0 2.0)
  49                                       :cdouble (complex 2.0d0 3.0d0)))
  50           (assert (eq :foo (evaluated-struct-pointer *evaluated-struct*)))
  51           (assert (eql 42 (evaluated-struct-word *evaluated-struct*)))
  52           (assert (eql 1.23 (evaluated-struct-single *evaluated-struct*)))
  53           (assert (eql 2.34d0 (evaluated-struct-double *evaluated-struct*)))
  54           (assert (eql #c(1.0 2.0) (evaluated-struct-csingle *evaluated-struct*)))
  55           (assert (eql #c(2.0d0 3.0d0) (evaluated-struct-cdouble *evaluated-struct*))))))
  56
  57 ;;; Prior to 1.0.25, the interpreter checked for package lock
  58 ;;; violation for a local function in the fbinding form's body's
  59 ;;; lexical environment.
  60 (let ((sb-ext:*evaluator-mode* :interpret))
  61   (assert
  62    (ignore-errors
  63      (eval
  64       '(eql
  65         (locally (declare (disable-package-locks
  66                            ;; rather than create a whole new package
  67                            ;; just to test this corner case, we'll
  68                            ;; lexically shadow something innocuous in
  69                            ;; the CL package.
  70                            cl:ed))
  71           (flet ((cl:ed ()
  72                    42))
  73             (declare (enable-package-locks cl:ed))
  74             (cl:ed)))
  75         42)))))
  76
  77 (defvar *file* (scratch-file-name "lisp"))
  78 (with-test (:name (:full-eval :redefinition-warnings))
  79   (with-open-file (stream *file* :direction :output :if-exists :supersede)
  80     (write '(defun function-for-redefinition () nil) :stream stream))
  81   (handler-bind ((warning #'error))
  82     (let ((sb-ext:*evaluator-mode* :interpret))
  83       (load *file*)
  84       (load *file*))
  85     (let ((sb-ext:*evaluator-mode* :compile))
  86       (load *file*))))
  87 (delete-file *file*)
  88
  89 (defvar *stash*)
  90 (defun save-it (f) (setq *stash* f) 'whatever)
  91 (with-test (:name (let* :nested-environments))
  92   (let ((z 'zee) (y 'y) (x 92))
  93     (let* ((baz (save-it (lambda (what) (assert (equal (list what x y z)
  94                                                        (list what 92 'y 'zee))))))
  95            (mum (funcall *stash* :after-binding-baz))
  96            (y 'new-y)
  97            (z (progn (funcall *stash* :after-binding-y) 'new-z))
  98            (x (progn (funcall *stash* :after-binding-z) 'new-x)))
  99       (funcall *stash* :in-body)
 100       (values))))
 101
 102 (with-test (:name (let* :nested-environment-again))
 103   (let* ((foo 3)
 104          (foo (lambda () (typep foo 'integer))))
 105     (assert (funcall foo))))
 106
 107 (declaim (inline some-inline-fun))
 108 (locally
 109  (declare (muffle-conditions compiler-note))
 110  (defun some-inline-fun (x) (- x)))
 111 (with-test (:name :inline-fun-captures-decl :fails-on (not :sb-fasteval))
 112   (assert (equal (sb-int:fun-name-inline-expansion 'some-inline-fun)
 113                  '(sb-c:lambda-with-lexenv
 114                    ((declare (muffle-conditions compiler-note))) (x)
 115                    (block some-inline-fun (- x))))))
 116
 117 (defun typecase-test (node)
 118   (typecase node
 119    (sb-c::bind 'a)
 120    (sb-c::cast 'b)
 121    (sb-c::cif 'c)
 122    (sb-c::cset 'd)
 123    (sb-c::ref 'e)
 124    (sb-kernel:layout 'winner)))
 125
 126 (with-test (:name :interpreted-type-constraint)
 127   (assert (eq (typecase-test (sb-kernel:find-layout 'cons)) 'winner)))
 128
 129 (defclass a-class ()
 130   ((x :initform 123)))
 131
 132 (defun a-class-x-0 (a)
 133   (slot-value a 'x))
 134
 135 (defmethod a-class-x-1 ((a a-class))
 136   (slot-value a 'x))
 137
 138 (defmethod a-class-x-2 ((a a-class))
 139   (let ((%a a))
 140     (slot-value %a 'x)))
 141
 142 (defmethod a-class-x-3 ((a t))
 143   (slot-value a 'x))
 144
 145 (with-test (:name (slot-value defun))
 146   (assert (= (a-class-x-0 (make-instance 'a-class)) 123)))
 147
 148 (with-test (:name (slot-value defmethod))
 149   (assert (= (a-class-x-1 (make-instance 'a-class)) 123)))
 150
 151 (with-test (:name (slot-value defmethod let))
 152   (assert (= (a-class-x-2 (make-instance 'a-class)) 123)))
 153
 154 (with-test (:name (slot-value defmethod t))
 155   (assert (= (a-class-x-3 (make-instance 'a-class)) 123)))