1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / load.impure.lisp
1 ;;;; miscellaneous side-effectful tests of LOAD
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 (defvar *tmp-filename* "load-test.tmp")
15
16 ;;; Bug reported by Sean Ross: FASL loader set fill pointer to loaded
17 ;;; simple arrays.
18
19 (defvar *array*)
20
21 (progn
22   (with-open-file (s *tmp-filename*
23                      :direction :output
24                      :if-exists :supersede
25                      :if-does-not-exist :create)
26     (print '(setq *array* #3a(((1 2) (2 1)) ((3 4) (4 3)))) s))
27   (let (tmp-fasl)
28     (unwind-protect
29          (progn
30            (setq tmp-fasl (compile-file *tmp-filename*))
31            (let ((*array* nil))
32              (load tmp-fasl)
33              (assert (arrayp *array*))
34              (assert (= (array-rank *array*) 3))
35              (assert (not (array-has-fill-pointer-p *array*)))))
36       (when tmp-fasl (delete-file tmp-fasl))
37       (delete-file *tmp-filename*))))
38
39 ;;; rudimentary external-format test
40 (dolist (ef '(:default :ascii :latin-1 :utf-8))
41   (with-open-file (s *tmp-filename*
42                      :direction :output
43                      :if-exists :supersede
44                      :if-does-not-exist :create)
45     (print '(defun foo (x) (1+ x)) s))
46   (fmakunbound 'foo)
47   (let (tmp-fasl)
48     (unwind-protect
49          (progn
50            (setq tmp-fasl (compile-file *tmp-filename* :external-format ef))
51            (load tmp-fasl)
52            (assert (= (foo 1) 2)))
53       (when tmp-fasl (delete-file tmp-fasl))
54       (delete-file *tmp-filename*))))
55
56 ;;; As reported by David Tolpin *LOAD-PATHNAME* was not merged.
57 (progn
58   (defvar *saved-load-pathname*)
59   (with-open-file (s *tmp-filename*
60                      :direction :output
61                      :if-exists :supersede
62                      :if-does-not-exist :create)
63     (print '(setq *saved-load-pathname* *load-pathname*) s))
64   (let (tmp-fasl)
65     (unwind-protect
66          (progn
67            (load *tmp-filename*)
68            (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
69       (delete-file *tmp-filename*))))
70 \f
71 ;;; Test many, many variations on LOAD.
72 (defparameter *counter* 0)
73 (defparameter *loaded-pathname* nil)
74 (defparameter *loaded-truename* nil)
75
76 (defparameter *test-program-string* (format nil "~
77  (incf *counter*)
78  (setf *loaded-pathname* *load-pathname*)
79  (setf *loaded-truename* *load-truename*)"))
80
81 (defmacro load-and-assert (load-argument pathname truename)
82   (let ((before (gensym)))
83     `(let ((,before *counter*)
84            *loaded-pathname* *loaded-truename*)
85        (load ,load-argument :print t :verbose t)
86        (assert (and (= (1+ ,before) *counter*)
87                     (equal ,(if pathname `(merge-pathnames ,pathname))
88                            *loaded-pathname*)
89                     (equal ,(if pathname `(merge-pathnames ,truename))
90                            *loaded-truename*))))))
91
92 (defmacro with-test-program (source fasl &body body)
93   (let ((src (gensym))
94         (fsl (gensym)))
95     `(let ((,src ,source)
96            (,fsl ,fasl))
97        (with-open-file (*standard-output* ,src :direction :output
98                                           :if-exists :supersede)
99          (princ *test-program-string*))
100        (when ,fsl
101          (compile-file ,src :output-file ,fsl))
102        (unwind-protect
103             (progn
104               ,@body)
105          (when (probe-file ,src)
106            (delete-file ,src))
107          (when (and ,fsl (probe-file ,fsl))
108            (delete-file ,fsl))))))
109
110 ;;; Loading from streams.
111
112 ;; string-stream
113 (with-input-from-string (s *test-program-string*)
114   (load-and-assert s nil nil))
115
116 ;; file-stream associated with a source file
117 (let ((source (pathname "load-impure-test.lisp")))
118   (with-test-program source nil
119     (with-open-file (stream source)
120       (load-and-assert stream source source))))
121
122 ;; file-stream associated with a fasl file
123 (let* ((source (pathname "load-impure-test.lisp"))
124        (fasl (compile-file-pathname source)))
125   (with-test-program source fasl
126     (with-open-file (stream fasl :element-type 'unsigned-byte)
127       (load-and-assert fasl fasl fasl))))
128
129 ;; Develop a simple Gray stream to test loading from.
130 (defclass load-impure-gray-stream (fundamental-character-input-stream)
131   ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
132
133 (defmethod stream-read-char ((stream load-impure-gray-stream))
134   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
135     (prog1
136         (if (>= pointer (length *test-program-string*))
137             :eof
138             (char *test-program-string* pointer))
139       (incf pointer))))
140
141 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
142   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
143     (if (<= pointer 0)
144         (error "fibber!  you never read from this stream ~S" stream)
145         (decf pointer)))
146   nil)
147
148 (with-open-stream (stream (make-instance 'load-impure-gray-stream))
149   (load-and-assert stream nil nil))
150
151 ;;; Loading from things named by pathname designators.
152
153 ;; Test loading a source file by supplying a complete pathname.
154 (let ((source (pathname "load-impure-test.lisp")))
155   (with-test-program source nil
156     (load-and-assert source source source)))
157
158 ;; Test loading a source file when supplying a partial pathname.
159 (let ((source (pathname "load-impure-test.lisp"))
160       (partial (pathname "load-impure-test")))
161   (with-test-program source nil
162     (load-and-assert partial source source)))
163
164 ;; Test loading a source file whose name lacks a type when supplying a
165 ;; partial pathname.
166 (let ((source (make-pathname :type :unspecific
167                              :defaults (pathname "load-impure-test")))
168       (partial (pathname "load-impure-test")))
169   (with-test-program source nil
170     (load-and-assert partial partial partial)))
171
172 ;; Test loading a fasl
173 (let* ((source (pathname "load-impure-test.lisp"))
174        (fasl (compile-file-pathname source)))
175   (with-test-program source fasl
176     (load-and-assert fasl fasl fasl)))
177
178 ;; Test loading a fasl when supplying a partial pathname.
179 (let* ((source  (pathname "load-impure-test.lisp"))
180        (fasl (compile-file-pathname source))
181        (partial (pathname "load-impure-test")))
182   (with-test-program source fasl
183     (load-and-assert partial fasl fasl)))
184
185 ;; Test loading a fasl whose name lacks a type when supplying a
186 ;; partial pathname.
187 (let* ((source  (pathname "load-impure-test.lisp"))
188        (fasl (make-pathname :type :unspecific
189                             :defaults (compile-file-pathname source)))
190        (partial (pathname "load-impure-test")))
191   (with-test-program source fasl
192     (load-and-assert partial partial partial)))
193
194 ;; Test loading a fasl with a strange type
195 (let* ((source (pathname "load-impure-test.lisp"))
196        (fasl (make-pathname :defaults (compile-file-pathname source)
197                             :type "compiled-lisp")))
198   (with-test-program source fasl
199     (load-and-assert fasl fasl fasl)))
200
201 ;;; Errors
202
203 ;; Ensure that loading a fasl specified with a type checks for the
204 ;; header.
205 (let* ((source (pathname "load-impure-test.lisp"))
206        (fasl (compile-file-pathname source)))
207   (with-test-program source fasl
208     (with-open-file (f fasl :direction :io :if-exists :overwrite
209                        :element-type '(unsigned-byte 8))
210       (write-byte 0 f))
211     (handler-case (load fasl)
212       (sb-fasl::fasl-header-missing () :ok))))
213
214 ;; Ensure that loading a fasl specified without a type checks for the
215 ;; header.  Note: this wasn't the behavior in
216 ;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
217 ;; or so).  If target-load.lisp is reverted to that state eventually,
218 ;; this test should be removed (or that definition of LOAD altered).
219 (let* ((source (pathname "load-impure-test.lisp"))
220        (fasl (compile-file-pathname source))
221        (fasl-spec (make-pathname :type nil
222                                  :defaults (compile-file-pathname source))))
223   (with-test-program source fasl
224     (with-open-file (f fasl :direction :io :if-exists :overwrite
225                        :element-type '(unsigned-byte 8))
226       (write-byte 0 f))
227     (handler-case (load fasl-spec)
228       (sb-fasl::fasl-header-missing () :ok))))
229
230 ;; Ensure that we get an error when the source file is newer than the
231 ;; fasl and the supplied argument is an incomplete pathname.
232 (let* ((source (pathname "load-impure-test.lisp"))
233        (fasl (compile-file-pathname source))
234        (spec (make-pathname :type nil :defaults source)))
235   (with-test-program source fasl
236     (sleep 1)
237     (with-open-file (*standard-output* source :direction :output
238                                        :if-exists :append)
239       (write-line ";;comment"))
240     (handler-case (load spec)
241       ;; IWBNI the error signalled here were more specific than
242       ;; SIMPLE-ERROR.
243       (error () :|well, we got an error!|))))
244
245 ;; Ensure that we can invoke the restart SOURCE in the above case.
246 (let* ((source (pathname "load-impure-test.lisp"))
247        (fasl (compile-file-pathname source))
248        (spec (make-pathname :type nil :defaults source)))
249   (with-test-program source fasl
250     (sleep 1)
251     (with-open-file (*standard-output* source :direction :output
252                                        :if-exists :append)
253       (write-line ";;comment"))
254     (handler-bind ((error (lambda (error)
255                                    (declare (ignore error))
256                                    (when (find-restart 'sb-fasl::source)
257                                      (invoke-restart 'sb-fasl::source)))))
258       (load-and-assert spec source source))))
259
260 ;; Ensure that we can invoke the restart OBJECT in the above case.
261 (let* ((source (pathname "load-impure-test.lisp"))
262        (fasl (compile-file-pathname source))
263        (spec (make-pathname :type nil :defaults source)))
264   (with-test-program source fasl
265     (sleep 1)
266     (with-open-file (*standard-output* source :direction :output
267                                        :if-exists :append)
268       (write-line ";;comment"))
269     (handler-bind ((error (lambda (error)
270                                    (declare (ignore error))
271                                    (when (find-restart 'sb-fasl::object)
272                                      (invoke-restart 'sb-fasl::object)))))
273       (load-and-assert spec fasl fasl))))