Clean up listify-rest-args VOP on x86-64.
[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)))))