source: trunk/tests/ansi-tests/compile-file.lsp

Last change on this file was 14368, checked in by gz, 9 years ago

Don't muffle warnings when running test, as that affects the return values from compile-file. Tweak tests to not cause warnings

File size: 6.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr  9 08:25:25 2005
4;;;; Contains: Tests of COMPILE-FILE
5
6(in-package :cl-test)
7
8(defun compile-file-test (file funname &rest args &key
9                               expect-warnings
10                               expect-style-warnings output-file
11                               (print nil print-p)
12                               (verbose nil verbose-p)
13                               (*compile-print* nil)
14                               (*compile-verbose* nil)
15                               external-format)
16  (declare (ignorable external-format))
17  (let* ((target-pathname (or output-file
18                              (compile-file-pathname file)))
19         (actual-warnings-p nil)
20         (actual-style-warnings-p nil))
21    (when (probe-file target-pathname)
22      (delete-file target-pathname))
23    (fmakunbound funname)
24    (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0))
25           (vals (multiple-value-list
26                  (handler-bind
27                   ((style-warning #'(lambda (c)
28                                       (declare (ignore c))
29                                       (setf actual-style-warnings-p t)
30                                       nil))
31                    ((or error warning)
32                     #'(lambda (c)
33                         (unless (typep c 'style-warning)
34                           (setf actual-warnings-p t))
35                         (when (and (typep c 'warning) (not *test-verbose*))
36                           (muffle-warning c))
37                         nil)))
38                   (with-output-to-string
39                     (*standard-output* str)
40                     (let ((*error-output* *standard-output*))
41                       (apply #'compile-file file :allow-other-keys t args)))))))
42      (assert (= (length vals) 3))
43      (destructuring-bind
44          (output-truename warnings-p failure-p)
45          vals
46        (when *test-verbose*
47          (print (namestring (truename target-pathname)))
48          (print (namestring output-truename)))
49        (values
50         (let ((v1 (or print verbose
51                       (and (not print-p) *compile-print*)
52                       (and (not verbose-p) *compile-verbose*)
53                       (string= str "")))
54               (v2 (or (and verbose-p (not verbose))
55                       (and (not verbose-p) (not *compile-verbose*))
56                       (position #\; str)))
57               (v3 (if actual-warnings-p failure-p t))
58               (v4 (if expect-warnings failure-p t))
59               (v5 (if expect-style-warnings warnings-p t))
60               (v6 (or (null output-truename) (pathnamep output-truename)))
61               (v7 (equalpt-or-report (namestring (truename target-pathname))
62                                      (namestring output-truename)))
63               (v8 (not (fboundp funname))))
64           (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t
65             (list v1 v2 v3 v4 v5 v6 v7 v8)))
66         (progn
67           (load output-truename)
68           (funcall funname)))))))
69
70(deftest compile-file.1
71  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1)
72  t nil)
73
74(deftest compile-file.2
75  (compile-file-test "compile-file-test-file-2.lsp" 'compile-file-test-fun.2
76                     :expect-style-warnings t)
77  t nil)
78
79(deftest compile-file.2a
80  (compile-file-test "compile-file-test-file-2a.lsp" 'compile-file-test-fun.2a
81                     :expect-warnings t)
82  t nil)
83
84(deftest compile-file.3
85  (let ((*package* (find-package "CL-TEST")))
86    (compile-file-test "compile-file-test-file-3.lsp" 'compile-file-test-fun.3))
87  t nil)
88
89(deftest compile-file.4
90  (let ((*package* (find-package "CL-USER")))
91    (compile-file-test "compile-file-test-file-3.lsp" 'cl-user::compile-file-test-fun.3))
92  t nil)
93
94(deftest compile-file.5
95  (compile-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1)
96  t nil)
97
98(deftest compile-file.6
99  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
100                     :output-file "foo.fasl")
101  t nil)
102
103(deftest compile-file.6a
104  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
105                     :output-file "foo.ufsl")
106  t nil)
107
108(deftest compile-file.7
109  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
110                     :external-format :default)
111  t nil)
112
113(deftest compile-file.8
114  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
115                     :output-file #p"foo.fasl")
116  t nil)
117
118(deftest compile-file.9
119  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
120                     :print t)
121  t nil)
122
123(deftest compile-file.10
124  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
125                     :verbose t)
126  t nil)
127
128(deftest compile-file.11
129  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
130                     :print nil)
131  t nil)
132
133(deftest compile-file.12
134  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
135                     :verbose nil)
136  t nil)
137
138;;; A file stream is a pathname designator
139(deftest compile-file.13
140  (with-open-file (s "compile-file-test-file.lsp" :direction :input)
141                  (compile-file-test s 'compile-file-test-fun.1))
142  t nil)
143
144(deftest compile-file.14
145  (let ((s (open "foo.fasl" :direction :output :if-exists :supersede
146                 :if-does-not-exist :create)))
147    (close s)
148    (compile-file-test "compile-file-test-file.lsp"
149                       'compile-file-test-fun.1
150                       :output-file s))
151  t nil)
152
153(deftest compile-file.15
154  (let ((*readtable* (copy-readtable nil)))
155    (set-macro-character #\! (get-macro-character #\'))
156    (compile-file-test "compile-file-test-file-4.lsp" 'compile-file-test-fun.4))
157  t foo)
158
159;;; Tests for *compile-file-truename*, *compile-file-pathname*
160
161(deftest compile-file.16
162  (let* ((file #p"compile-file-test-file-5.lsp")
163         (target-pathname (compile-file-pathname file))
164         (*compile-print* nil)
165         (*compile-verbose* nil))
166    (when (probe-file target-pathname)
167      (delete-file target-pathname))
168    (compile-file file)
169    (load target-pathname)
170    (values
171     (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5))
172     (equalpt-or-report (pathname (merge-pathnames file))
173                        (funcall 'compile-file-test-fun.5a))))
174  t t)
175
176;;; Add tests of logical pathnames
177
178(deftest compile-file.17
179  (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.LSP")))
180    (with-open-file
181     (s file :direction :output :if-exists :supersede :if-does-not-exist :create)
182     (format s "(in-package :cl-test)~%(defun compile-file-test-lp.fun () nil)~%"))
183    (compile-file-test file 'compile-file-test-lp.fun))
184  t nil)
185
186(deftest compile-file.18
187  (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.OUT")))
188    (with-open-file
189     (s file :direction :output :if-exists :supersede :if-does-not-exist :create))
190    (compile-file-test "compile-file-test-file.lsp"
191                       'compile-file-test-fun.1
192                       :output-file file))
193  t nil)
194
195(deftest compile-file.19
196  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
197                     :*compile-verbose* t)
198  t nil)
199
200(deftest compile-file.20
201  (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1
202                     :*compile-print* t)
203  t nil) 
204
205(deftest compile-file-pathname.1
206  *compile-file-pathname*
207  nil)
208
209(deftest compile-file-truename.1
210  *compile-file-truename*
211  nil)
212
213;;; Error cases
214
215(deftest compile-file.error.1
216  (signals-error (compile-file "nonexistent-file-to-compile.lsp") file-error)
217  t)
218
219(deftest compile-file.error.2
220  (signals-error (compile-file) program-error)
221  t)
222
223
224
225
Note: See TracBrowser for help on using the repository browser.