1 ;;;; miscellaneous side-effectful tests of LOAD
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (defvar *tmp-filename* "load-test.tmp")
16 ;;; Bug reported by Sean Ross: FASL loader set fill pointer to loaded
22 (with-open-file (s *tmp-filename*
25 :if-does-not-exist :create)
26 (print '(setq *array* #3a(((1 2) (2 1)) ((3 4) (4 3)))) s))
30 (setq tmp-fasl (compile-file *tmp-filename*))
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*))))
39 ;;; rudimentary external-format test
40 (dolist (ef '(:default :ascii :latin-1 :utf-8))
41 (with-open-file (s *tmp-filename*
44 :if-does-not-exist :create)
45 (print '(defun foo (x) (1+ x)) s))
50 (setq tmp-fasl (compile-file *tmp-filename* :external-format ef))
52 (assert (= (foo 1) 2)))
53 (when tmp-fasl (delete-file tmp-fasl))
54 (delete-file *tmp-filename*))))
56 ;;; As reported by David Tolpin *LOAD-PATHNAME* was not merged.
58 (defparameter *saved-load-pathname* nil)
59 (with-open-file (s *tmp-filename*
62 :if-does-not-exist :create)
63 (print '(setq *saved-load-pathname* *load-pathname*) s))
67 (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
68 (delete-file *tmp-filename*)))
70 ;;; Test many, many variations on LOAD.
71 (defparameter *counter* 0)
72 (defparameter *loaded-pathname* nil)
73 (defparameter *loaded-truename* nil)
75 (defparameter *test-program-string* (format nil "~
77 (setf *loaded-pathname* *load-pathname*)
78 (setf *loaded-truename* *load-truename*)"))
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*)
87 (equal ,(if pathname `(merge-pathnames ,pathname))
90 (equal ,(if pathname `(merge-pathnames ,truename))
91 *loaded-truename*))))))
93 (defmacro with-test-program (source fasl &body body)
98 (with-open-file (*standard-output* ,src :direction :output
99 :if-exists :supersede)
100 (princ *test-program-string*))
102 (compile-file ,src :output-file ,fsl))
106 (when (probe-file ,src)
108 (when (and ,fsl (probe-file ,fsl))
109 (delete-file ,fsl))))))
111 ;;; Loading from streams.
114 (with-input-from-string (s *test-program-string*)
115 (load-and-assert s nil nil))
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))))
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))))
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)))
134 (defmethod stream-read-char ((stream load-impure-gray-stream))
135 (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
137 (if (>= pointer (length *test-program-string*))
139 (char *test-program-string* pointer))
142 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
143 (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
145 (error "fibber! you never read from this stream ~S" stream)
149 (with-open-stream (stream (make-instance 'load-impure-gray-stream))
150 (load-and-assert stream nil nil))
152 ;;; Loading from things named by pathname designators.
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)))
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)))
165 ;; Test loading a source file whose name lacks a type when supplying a
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)))
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)))
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)))
186 ;; Test loading a fasl whose name lacks a type when supplying a
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)))
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)))
204 ;; Ensure that loading a fasl specified with a type checks for the
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))
212 (handler-case (load fasl)
213 (sb-fasl::fasl-header-missing () :ok))))
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))
228 (handler-case (load fasl-spec)
229 (sb-fasl::fasl-header-missing () :ok))))
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
238 (with-open-file (*standard-output* source :direction :output
240 (write-line ";;comment"))
241 (handler-case (load spec)
242 ;; IWBNI the error signalled here were more specific than
244 (error () :|well, we got an error!|))))
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
252 (with-open-file (*standard-output* source :direction :output
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))))
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
267 (with-open-file (*standard-output* source :direction :output
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))))
276 (with-test (:name :bug-332)
277 (flet ((stimulate-sbcl ()
279 (format nil "~A/~A.lisp"
280 (or (posix-getenv "TEST_DIRECTORY")
281 (posix-getenv "TMPDIR")
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))))))
297 (defun load-empty-file (type)
298 (let ((pathname (make-pathname :name "load-impure-lisp-empty-temp"
302 (with-open-file (f pathname
303 :if-exists :supersede
306 (progn (load pathname) t)
308 (ignore-errors (delete-file pathname)))))
310 (with-test (:name (load :empty.lisp))
311 (assert (load-empty-file "lisp")))
313 (with-test (:name (load :empty.fasl))
314 (assert (not (load-empty-file "fasl"))))
316 (with-test (:name :parallel-fasl-load)
318 (let ((lisp #p"parallel-fasl-load-test.lisp")
323 (multiple-value-bind (compiled warned failed)
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)
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)))
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)))))
360 (ignore-errors (delete-file fasl))))))
364 (with-test (:name :load-simd-pack-int)
365 (with-open-file (s *tmp-filename*
367 :if-exists :supersede
368 :if-does-not-exist :create)
369 (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s))
373 (setq tmp-fasl (compile-file *tmp-filename*))
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*))))
383 (with-test (:name :load-simd-pack-single)
384 (with-open-file (s *tmp-filename*
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))
392 (setq tmp-fasl (compile-file *tmp-filename*))
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*))))
402 (with-test (:name :load-simd-pack-double)
403 (with-open-file (s *tmp-filename*
405 :if-exists :supersede
406 :if-does-not-exist :create)
407 (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s))
411 (setq tmp-fasl (compile-file *tmp-filename*))
414 (assert (typep *pack* '(sb-kernel:simd-pack double-float)))
415 (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*))
417 (when tmp-fasl (delete-file tmp-fasl))
418 (delete-file *tmp-filename*))))