1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / fopcompiler.impure-cload.lisp
1 ;;;; tests of the fop compiler
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 (in-package "CL-USER")
15
16 ;; Can't use normal ASSERT, since it is not fopcompilable...
17 (defun assert* (value)
18   (unless value
19     (error "assert failed")))
20
21 ;;; Test that the forms that are supposed to be fopcompilable are, and
22 ;;; the ones that aren't aren't. The body might contain further tests to
23 ;;; ensure that the fopcompiled code works as intended.
24 (defmacro fopcompile-test (fopcompilable-p &body body)
25   (assert (eql (sb-c::fopcompilable-p `(progn ,@body))
26                fopcompilable-p))
27   `(progn ,@body))
28
29 (fopcompile-test t
30  (let ((a 1))
31    (assert* (eql a 1))))
32
33 (fopcompile-test t
34  (let ((a 3))
35    (let ((a 4))
36      (assert* (eql a 4)))))
37
38 (fopcompile-test t
39  (let* ((a 5))
40    (let* ((a 6))
41      (assert* (eql a 6)))))
42
43 (fopcompile-test nil
44  (let ((a 7))
45    (assert* (eql (funcall (lambda () a)) 7))))
46
47 (fopcompile-test nil
48   (let* ((a 8))
49     (assert* (eql (funcall (lambda () a)) 8))))
50
51 (fopcompile-test t
52   (let ((a 8)
53         (b (lambda () 1)))
54     nil))
55
56 (fopcompile-test t
57   (let* ((a (lambda () 1)))
58     nil))
59
60 (fopcompile-test nil
61   (let* ((a 8)
62          (b (lambda () 1)))
63     nil))
64
65 (fopcompile-test nil
66   (let* ((a 9)
67          (b (funcall (lambda () a))))
68     (assert* (eql b 9))))
69
70 (fopcompile-test t
71   (let ((a 10))
72     (let ((a 11)
73           (b a))
74       (assert* (eql b 10)))))
75
76 (fopcompile-test t
77   (let ((a 12))
78     (let* ((a 13)
79            (b a))
80       (assert* (eql b 13)))))
81
82 (setf (symbol-value 'fopcompile-test-foo) 1)
83 (assert* (eql fopcompile-test-foo 1))
84
85 ;;; Ensure that we're passing sensible environments to macros during
86 ;;; fopcompilation. Reported by Samium Gromoff.
87
88 (defmacro bar (vars &environment env)
89   (assert (equal vars
90                  (mapcar #'car (sb-c::lexenv-vars env)))))
91
92 (symbol-macrolet ((foo 1))
93   (let* ((x (bar (foo)))
94          (y (bar (x foo))))
95     (bar (y x foo))))
96