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:quit :unix-status 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)))))