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 #-sb-eval
  15 (sb-ext:exit :code 104)
  16
  17 (setf sb-ext:*evaluator-mode* :interpret)
  18
  19 (assert (not (typep (lambda ()) 'compiled-function)))
  20
  21 (assert (not (compiled-function-p (lambda ()))))
  22
  23 (let ((seen-forms (make-hash-table :test 'equal)))
  24   (let ((*macroexpand-hook* (compile nil
  25                                      `(lambda (fun form env)
  26                                         (setf (gethash form ,seen-forms) t)
  27                                         (funcall fun form env)))))
  28     (let ((fun (lambda ()
  29                  (when t nil))))
  30       (assert (not (gethash '(when t nil) seen-forms)))
  31       (funcall fun)
  32       (assert (gethash '(when t nil) seen-forms)))))
  33
  34 ;;; defstruct constructor
  35 (let ((sb-ext:*evaluator-mode* :interpret))
  36   (eval '(progn
  37           (defstruct evaluated-struct
  38             (pointer nil)
  39             (word 0 :type (unsigned-byte #.sb-vm:n-word-bytes))
  40             (single 0.0 :type single-float)
  41             (double 0.0d0 :type double-float)
  42             (csingle (complex 0.0 0.0) :type (complex single-float))
  43             (cdouble (complex 0.0d0 0.0d0) :type (complex double-float)))
  44           (defvar *evaluated-struct* (make-evaluated-struct
  45                                       :pointer :foo
  46                                       :word 42
  47                                       :single 1.23
  48                                       :double 2.34d0
  49                                       :csingle (complex 1.0 2.0)
  50                                       :cdouble (complex 2.0d0 3.0d0)))
  51           (assert (eq :foo (evaluated-struct-pointer *evaluated-struct*)))
  52           (assert (eql 42 (evaluated-struct-word *evaluated-struct*)))
  53           (assert (eql 1.23 (evaluated-struct-single *evaluated-struct*)))
  54           (assert (eql 2.34d0 (evaluated-struct-double *evaluated-struct*)))
  55           (assert (eql #c(1.0 2.0) (evaluated-struct-csingle *evaluated-struct*)))
  56           (assert (eql #c(2.0d0 3.0d0) (evaluated-struct-cdouble *evaluated-struct*))))))
  57
  58 ;;; Prior to 1.0.25, the interpreter checked for package lock
  59 ;;; violation for a local function in the fbinding form's body's
  60 ;;; lexical environment.
  61 (let ((sb-ext:*evaluator-mode* :interpret))
  62   (assert
  63    (ignore-errors
  64      (eval
  65       '(eql
  66         (locally (declare (disable-package-locks
  67                            ;; rather than create a whole new package
  68                            ;; just to test this corner case, we'll
  69                            ;; lexically shadow something innocuous in
  70                            ;; the CL package.
  71                            cl:ed))
  72           (flet ((cl:ed ()
  73                    42))
  74             (declare (enable-package-locks cl:ed))
  75             (cl:ed)))
  76         42)))))
  77
  78 (defvar *file* #p"full-eval-temp.lisp")
  79 (with-test (:name (:full-eval :redefinition-warnings))
  80   (with-open-file (stream *file* :direction :output :if-exists :supersede)
  81     (write '(defun function-for-redefinition () nil) :stream stream))
  82   (handler-bind ((warning #'error))
  83     (let ((sb-ext:*evaluator-mode* :interpret))
  84       (load *file*)
  85       (load *file*))
  86     (let ((sb-ext:*evaluator-mode* :compile))
  87       (load *file*))))
  88 (delete-file *file*)
  89
  90 (defvar *stash*)
  91 (defun save-it (f) (setq *stash* f) 'whatever)
  92 (with-test (:name (let* :nested-environments))
  93   (let ((z 'zee) (y 'y) (x 92))
  94     (let* ((baz (save-it (lambda (what) (assert (equal (list what x y z)
  95                                                        (list what 92 'y 'zee))))))
  96            (mum (funcall *stash* :after-binding-baz))
  97            (y 'new-y)
  98            (z (progn (funcall *stash* :after-binding-y) 'new-z))
  99            (x (progn (funcall *stash* :after-binding-z) 'new-x)))
 100       (funcall *stash* :in-body)
 101       (values))))
 102
 103 (with-test (:name (let* :nested-environment-again))
 104   (let* ((foo 3)
 105          (foo (lambda () (typep foo 'integer))))
 106     (assert (funcall foo))))