Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / 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))))