Really restore clisp cross-compilation.
[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   (defparameter *saved-load-pathname* nil)
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   (unwind-protect
65        (progn
66          (load *tmp-filename*)
67          (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
68     (delete-file *tmp-filename*)))
69 \f
70 ;;; Test many, many variations on LOAD.
71 (defparameter *counter* 0)
72 (defparameter *loaded-pathname* nil)
73 (defparameter *loaded-truename* nil)
74
75 (defparameter *test-program-string* (format nil "~
76  (incf *counter*)
77  (setf *loaded-pathname* *load-pathname*)
78  (setf *loaded-truename* *load-truename*)"))
79
80 (defmacro load-and-assert (load-argument pathname truename)
81   (let ((before (gensym)))
82     `(let ((,before *counter*)
83            *loaded-pathname* *loaded-truename*)
84        (load ,load-argument :print t :verbose t)
85        (assert (and (= (1+ ,before) *counter*)
86                     #-win32 ;kludge
87                     (equal ,(if pathname `(merge-pathnames ,pathname))
88                            *loaded-pathname*)
89                     #-win32 ;kludge
90                     (equal ,(if pathname `(merge-pathnames ,truename))
91                            *loaded-truename*))))))
92
93 (defmacro with-test-program (source fasl &body body)
94   (let ((src (gensym))
95         (fsl (gensym)))
96     `(let ((,src ,source)
97            (,fsl ,fasl))
98        (with-open-file (*standard-output* ,src :direction :output
99                                           :if-exists :supersede)
100          (princ *test-program-string*))
101        (when ,fsl
102          (compile-file ,src :output-file ,fsl))
103        (unwind-protect
104             (progn
105               ,@body)
106          (when (probe-file ,src)
107            (delete-file ,src))
108          (when (and ,fsl (probe-file ,fsl))
109            (delete-file ,fsl))))))
110
111 ;;; Loading from streams.
112
113 ;; string-stream
114 (with-input-from-string (s *test-program-string*)
115   (load-and-assert s nil nil))
116
117 ;; file-stream associated with a source file
118 (let ((source (pathname "load-impure-test.lisp")))
119   (with-test-program source nil
120     (with-open-file (stream source)
121       (load-and-assert stream source source))))
122
123 ;; file-stream associated with a fasl file
124 (let* ((source (pathname "load-impure-test.lisp"))
125        (fasl (compile-file-pathname source)))
126   (with-test-program source fasl
127     (with-open-file (stream fasl :element-type 'unsigned-byte)
128       (load-and-assert fasl fasl fasl))))
129
130 ;; Develop a simple Gray stream to test loading from.
131 (defclass load-impure-gray-stream (fundamental-character-input-stream)
132   ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
133
134 (defmethod stream-read-char ((stream load-impure-gray-stream))
135   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
136     (prog1
137         (if (>= pointer (length *test-program-string*))
138             :eof
139             (char *test-program-string* pointer))
140       (incf pointer))))
141
142 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
143   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
144     (if (<= pointer 0)
145         (error "fibber!  you never read from this stream ~S" stream)
146         (decf pointer)))
147   nil)
148
149 (with-open-stream (stream (make-instance 'load-impure-gray-stream))
150   (load-and-assert stream nil nil))
151
152 ;;; Loading from things named by pathname designators.
153
154 ;; Test loading a source file by supplying a complete pathname.
155 (let ((source (pathname "load-impure-test.lisp")))
156   (with-test-program source nil
157     (load-and-assert source source source)))
158
159 ;; Test loading a source file when supplying a partial pathname.
160 (let ((source (pathname "load-impure-test.lisp"))
161       (partial (pathname "load-impure-test")))
162   (with-test-program source nil
163     (load-and-assert partial source source)))
164
165 ;; Test loading a source file whose name lacks a type when supplying a
166 ;; partial pathname.
167 (let ((source (make-pathname :type :unspecific
168                              :defaults (pathname "load-impure-test")))
169       (partial (pathname "load-impure-test")))
170   (with-test-program source nil
171     (load-and-assert partial partial partial)))
172
173 ;; Test loading a fasl
174 (let* ((source (pathname "load-impure-test.lisp"))
175        (fasl (compile-file-pathname source)))
176   (with-test-program source fasl
177     (load-and-assert fasl fasl fasl)))
178
179 ;; Test loading a fasl when supplying a partial pathname.
180 (let* ((source  (pathname "load-impure-test.lisp"))
181        (fasl (compile-file-pathname source))
182        (partial (pathname "load-impure-test")))
183   (with-test-program source fasl
184     (load-and-assert partial fasl fasl)))
185
186 ;; Test loading a fasl whose name lacks a type when supplying a
187 ;; partial pathname.
188 (let* ((source  (pathname "load-impure-test.lisp"))
189        (fasl (make-pathname :type :unspecific
190                             :defaults (compile-file-pathname source)))
191        (partial (pathname "load-impure-test")))
192   (with-test-program source fasl
193     (load-and-assert partial partial partial)))
194
195 ;; Test loading a fasl with a strange type
196 (let* ((source (pathname "load-impure-test.lisp"))
197        (fasl (make-pathname :defaults (compile-file-pathname source)
198                             :type "compiled-lisp")))
199   (with-test-program source fasl
200     (load-and-assert fasl fasl fasl)))
201
202 ;;; Errors
203
204 ;; Ensure that loading a fasl specified with a type checks for the
205 ;; header.
206 (let* ((source (pathname "load-impure-test.lisp"))
207        (fasl (compile-file-pathname source)))
208   (with-test-program source fasl
209     (with-open-file (f fasl :direction :io :if-exists :overwrite
210                        :element-type '(unsigned-byte 8))
211       (write-byte 0 f))
212     (handler-case (load fasl)
213       (sb-fasl::fasl-header-missing () :ok))))
214
215 ;; Ensure that loading a fasl specified without a type checks for the
216 ;; header.  Note: this wasn't the behavior in
217 ;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
218 ;; or so).  If target-load.lisp is reverted to that state eventually,
219 ;; this test should be removed (or that definition of LOAD altered).
220 (let* ((source (pathname "load-impure-test.lisp"))
221        (fasl (compile-file-pathname source))
222        (fasl-spec (make-pathname :type nil
223                                  :defaults (compile-file-pathname source))))
224   (with-test-program source fasl
225     (with-open-file (f fasl :direction :io :if-exists :overwrite
226                        :element-type '(unsigned-byte 8))
227       (write-byte 0 f))
228     (handler-case (load fasl-spec)
229       (sb-fasl::fasl-header-missing () :ok))))
230
231 ;; Ensure that we get an error when the source file is newer than the
232 ;; fasl and the supplied argument is an incomplete pathname.
233 (let* ((source (pathname "load-impure-test.lisp"))
234        (fasl (compile-file-pathname source))
235        (spec (make-pathname :type nil :defaults source)))
236   (with-test-program source fasl
237     (sleep 1)
238     (with-open-file (*standard-output* source :direction :output
239                                        :if-exists :append)
240       (write-line ";;comment"))
241     (handler-case (load spec)
242       ;; IWBNI the error signalled here were more specific than
243       ;; SIMPLE-ERROR.
244       (error () :|well, we got an error!|))))
245
246 ;; Ensure that we can invoke the restart SOURCE in the above case.
247 (let* ((source (pathname "load-impure-test.lisp"))
248        (fasl (compile-file-pathname source))
249        (spec (make-pathname :type nil :defaults source)))
250   (with-test-program source fasl
251     (sleep 1)
252     (with-open-file (*standard-output* source :direction :output
253                                        :if-exists :append)
254       (write-line ";;comment"))
255     (handler-bind ((error (lambda (error)
256                             (declare (ignore error))
257                             (when (find-restart 'sb-fasl::source)
258                               (invoke-restart 'sb-fasl::source)))))
259       (load-and-assert spec source source))))
260
261 ;; Ensure that we can invoke the restart OBJECT in the above case.
262 (let* ((source (pathname "load-impure-test.lisp"))
263        (fasl (compile-file-pathname source))
264        (spec (make-pathname :type nil :defaults source)))
265   (with-test-program source fasl
266     (sleep 1)
267     (with-open-file (*standard-output* source :direction :output
268                                        :if-exists :append)
269       (write-line ";;comment"))
270     (handler-bind ((error (lambda (error)
271                             (declare (ignore error))
272                             (when (find-restart 'sb-fasl::object)
273                               (invoke-restart 'sb-fasl::object)))))
274       (load-and-assert spec fasl fasl))))
275
276 (with-test (:name :bug-332)
277   (flet ((stimulate-sbcl ()
278            (let ((filename
279                   (format nil "~A/~A.lisp"
280                           (or (posix-getenv "TEST_DIRECTORY")
281                               (posix-getenv "TMPDIR")
282                               "/tmp")
283                           (gensym))))
284              (ensure-directories-exist filename)
285              ;; create a file which redefines a structure incompatibly
286              (with-open-file (f filename :direction :output :if-exists :supersede)
287                (print '(defstruct bug-332 foo) f)
288                (print '(defstruct bug-332 foo bar) f))
289              ;; compile and load the file, then invoke the continue restart on
290              ;; the structure redefinition error
291              (handler-bind ((error (lambda (c) (continue c))))
292                (load (compile-file filename))))))
293     (stimulate-sbcl)
294     (stimulate-sbcl)
295     (stimulate-sbcl)))
296
297 (defun load-empty-file (type)
298   (let ((pathname (make-pathname :name "load-impure-lisp-empty-temp"
299                                  :type type)))
300       (unwind-protect
301            (progn
302              (with-open-file (f pathname
303                                 :if-exists :supersede
304                                 :direction :output))
305              (handler-case
306                  (progn (load pathname) t)
307                (error () nil)))
308         (ignore-errors (delete-file pathname)))))
309
310 (with-test (:name (load :empty.lisp))
311   (assert (load-empty-file "lisp")))
312
313 (with-test (:name (load :empty.fasl))
314   (assert (not (load-empty-file "fasl"))))
315
316 (with-test (:name :parallel-fasl-load)
317   #+sb-thread
318   (let ((lisp #p"parallel-fasl-load-test.lisp")
319         (fasl nil)
320         (ready nil))
321     (unwind-protect
322          (progn
323            (multiple-value-bind (compiled warned failed)
324                (compile-file lisp)
325              (setf fasl compiled)
326              (assert (not warned))
327              (assert (not failed))
328              (labels ((load-loop ()
329                         (let* ((*standard-output* (make-broadcast-stream))
330                                (*error-output* *standard-output*))
331                           (sb-ext:wait-for ready)
332                           (handler-case
333                               (progn
334                                 (loop repeat 1000
335                                       do (load fasl)
336                                          (test-it))
337                                 t)
338                             (error (e) e))))
339                       (test-it ()
340                         (assert (= 1 (one-fun)))
341                         (assert (= 2 (two-fun)))
342                         (assert (= 42 (symbol-value '*var*)))
343                         (assert (= 13 (symbol-value '*quux*)))))
344                (let ((t1 (sb-thread:make-thread #'load-loop))
345                      (t2 (sb-thread:make-thread #'load-loop))
346                      (t3 (sb-thread:make-thread #'load-loop)))
347                  (setf ready t)
348                  (let ((r1 (sb-thread:join-thread t1))
349                        (r2 (sb-thread:join-thread t2))
350                        (r3 (sb-thread:join-thread t3)))
351                    (unless (and (eq t r1) (eq t r2) (eq t r3))
352                      (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
353                    ;; These ones cannot be tested while redefinitions are running:
354                    ;; adding a method implies REMOVE-METHOD, so a call would be racy.
355                    (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
356                    (assert (eq 'cons (gen-fun '(foo))))
357                    (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
358                  (test-it)))))
359       (when fasl
360         (ignore-errors (delete-file fasl))))))
361
362 (defvar *pack*)
363 #+sb-simd-pack
364 (with-test (:name :load-simd-pack-int)
365   (with-open-file (s *tmp-filename*
366                      :direction :output
367                      :if-exists :supersede
368                      :if-does-not-exist :create)
369     (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s))
370   (let (tmp-fasl)
371     (unwind-protect
372          (progn
373            (setq tmp-fasl (compile-file *tmp-filename*))
374            (let ((*pack* nil))
375              (load tmp-fasl)
376              (assert (typep *pack* '(sb-kernel:simd-pack integer)))
377              (assert (= 2 (sb-kernel:%simd-pack-low *pack*)))
378              (assert (= 4 (sb-kernel:%simd-pack-high *pack*)))))
379       (when tmp-fasl (delete-file tmp-fasl))
380       (delete-file *tmp-filename*))))
381
382 #+sb-simd-pack
383 (with-test (:name :load-simd-pack-single)
384   (with-open-file (s *tmp-filename*
385                      :direction :output
386                      :if-exists :supersede
387                      :if-does-not-exist :create)
388     (print '(setq *pack* (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)) s))
389   (let (tmp-fasl)
390     (unwind-protect
391          (progn
392            (setq tmp-fasl (compile-file *tmp-filename*))
393            (let ((*pack* nil))
394              (load tmp-fasl)
395              (assert (typep *pack* '(sb-kernel:simd-pack single-float)))
396              (assert (equal (multiple-value-list (sb-kernel:%simd-pack-singles *pack*))
397                             '(1f0 2f0 3f0 4f0)))))
398       (when tmp-fasl (delete-file tmp-fasl))
399       (delete-file *tmp-filename*))))
400
401 #+sb-simd-pack
402 (with-test (:name :load-simd-pack-double)
403   (with-open-file (s *tmp-filename*
404                      :direction :output
405                      :if-exists :supersede
406                      :if-does-not-exist :create)
407     (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s))
408   (let (tmp-fasl)
409     (unwind-protect
410          (progn
411            (setq tmp-fasl (compile-file *tmp-filename*))
412            (let ((*pack* nil))
413              (load tmp-fasl)
414              (assert (typep *pack* '(sb-kernel:simd-pack double-float)))
415              (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*))
416                             '(1d0 2d0)))))
417       (when tmp-fasl (delete-file tmp-fasl))
418       (delete-file *tmp-filename*))))