Really restore clisp cross-compilation.
[sbcl.git] / tests / with-compilation-unit.impure.lisp
1 ;;;; This file is for testing WITH-COMPILATION-UNIT (particularily the
2 ;;;; suppression of undefined-foo warnings for forward-references).
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
9 ;;;; from CMU CL.
10 ;;;;
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
14
15 (defvar *file-a* #p"with-compilation-unit-temp-a.lisp")
16 (defvar *file-b* #p"with-compilation-unit-temp-b.lisp")
17
18 (defun test-files (reset &optional want-suppress-p)
19   (funcall reset)
20   (assert (eql (raises-error?
21                 (handler-bind ((warning (lambda (c)
22                                           (error "got a warning: ~a" c))))
23                   (with-compilation-unit ()
24                     (compile-file *file-a*)
25                     (compile-file *file-b*))))
26                want-suppress-p))
27
28   (funcall reset)
29   (assert
30    (raises-error?
31     (handler-bind ((warning (lambda (c)
32                               (error "got a warning: ~a" c))))
33       (compile-file *file-a*)
34       (compile-file *file-b*))))
35
36   (funcall reset)
37   (assert (eql (raises-error?
38                 (handler-bind ((warning (lambda (c)
39                                           (error "got a warning: ~a" c))))
40                   (with-compilation-unit ()
41                     (compile-file *file-a*)
42                     (load (compile-file-pathname *file-b*)))))
43                want-suppress-p))
44
45   (funcall reset)
46   (assert
47    (raises-error?
48     (handler-bind ((warning (lambda (c)
49                               (error "got a warning: ~a" c))))
50       (compile-file *file-a*)
51       (load (compile-file-pathname *file-b*))))))
52
53 (with-test (:name (:with-compilation-unit :function))
54   (with-open-file (stream *file-b* :direction :output
55 :if-exists :supersede)
56     (write '(defun foo () 1) :stream stream))
57   (with-open-file (stream *file-a* :direction :output
58 :if-exists :supersede)
59     (write '(defun bar () (foo)) :stream stream))
60
61   (test-files (lambda ()
62                 (fmakunbound 'foo)
63                 (fmakunbound 'bar))))
64
65 (with-test (:name (:with-compilation-unit :generic-function))
66   (with-open-file (stream *file-b* :direction :output
67                           :if-exists :supersede)
68     (write '(defgeneric foo ()) :stream stream)
69     (write '(defmethod foo () 1) :stream stream))
70   (with-open-file (stream *file-a* :direction :output
71                           :if-exists :supersede)
72     (write '(defmethod bar () (foo)) :stream stream))
73
74   (test-files (lambda ()
75                 (fmakunbound 'foo)
76                 (fmakunbound 'bar))))
77
78 (with-test (:name (:with-compilation-unit :variable))
79   (with-open-file (stream *file-b* :direction :output
80                           :if-exists :supersede)
81     (write `(defvar ,(intern "*A*") nil) :stream stream))
82   (with-open-file (stream *file-a* :direction :output
83                           :if-exists :supersede)
84     (write `(defun bar () ,(intern "*A*")) :stream stream))
85
86   (test-files (lambda ()
87                 (unintern (find-symbol "*A*"))
88                 (fmakunbound 'bar))
89               ;; Check that undefined variables are warned for, even
90               ;; if the variable is defined later in the compilation
91               ;; unit.
92               t))
93
94 (with-test (:name (:with-compilation-unit :type))
95   (with-open-file (stream *file-b* :direction :output
96                           :if-exists :supersede)
97     (write `(deftype ,(intern "A-TYPE") () 'fixnum) :stream stream))
98   (with-open-file (stream *file-a* :direction :output
99                           :if-exists :supersede)
100     (write `(defun bar () (typep 1 ',(intern "A-TYPE"))) :stream stream))
101
102   (test-files (lambda ()
103                 (unintern (find-symbol "A-TYPE"))
104                 (fmakunbound 'bar))))
105
106 (delete-file *file-a*)
107 (delete-file *file-b*)
108