+;; Test loading a fasl
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source)))
+ (with-test-program source fasl
+ (load-and-assert fasl fasl fasl)))
+
+;; Test loading a fasl when supplying a partial pathname.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source))
+ (partial (pathname "load-impure-test")))
+ (with-test-program source fasl
+ (load-and-assert partial fasl fasl)))
+
+;; Test loading a fasl whose name lacks a type when supplying a
+;; partial pathname.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (make-pathname :type :unspecific
+ :defaults (compile-file-pathname source)))
+ (partial (pathname "load-impure-test")))
+ (with-test-program source fasl
+ (load-and-assert partial partial partial)))
+
+;; Test loading a fasl with a strange type
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (make-pathname :defaults (compile-file-pathname source)
+ :type "compiled-lisp")))
+ (with-test-program source fasl
+ (load-and-assert fasl fasl fasl)))
+
+;;; Errors
+
+;; Ensure that loading a fasl specified with a type checks for the
+;; header.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source)))
+ (with-test-program source fasl
+ (with-open-file (f fasl :direction :io :if-exists :overwrite
+ :element-type '(unsigned-byte 8))
+ (write-byte 0 f))
+ (handler-case (load fasl)
+ (sb-fasl::fasl-header-missing () :ok))))
+
+;; Ensure that loading a fasl specified without a type checks for the
+;; header. Note: this wasn't the behavior in
+;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
+;; or so). If target-load.lisp is reverted to that state eventually,
+;; this test should be removed (or that definition of LOAD altered).
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source))
+ (fasl-spec (make-pathname :type nil
+ :defaults (compile-file-pathname source))))
+ (with-test-program source fasl
+ (with-open-file (f fasl :direction :io :if-exists :overwrite
+ :element-type '(unsigned-byte 8))
+ (write-byte 0 f))
+ (handler-case (load fasl-spec)
+ (sb-fasl::fasl-header-missing () :ok))))
+
+;; Ensure that we get an error when the source file is newer than the
+;; fasl and the supplied argument is an incomplete pathname.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source))
+ (spec (make-pathname :type nil :defaults source)))
+ (with-test-program source fasl
+ (sleep 1)
+ (with-open-file (*standard-output* source :direction :output
+ :if-exists :append)
+ (write-line ";;comment"))
+ (handler-case (load spec)
+ ;; IWBNI the error signalled here were more specific than
+ ;; SIMPLE-ERROR.
+ (error () :|well, we got an error!|))))
+
+;; Ensure that we can invoke the restart SOURCE in the above case.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source))
+ (spec (make-pathname :type nil :defaults source)))
+ (with-test-program source fasl
+ (sleep 1)
+ (with-open-file (*standard-output* source :direction :output
+ :if-exists :append)
+ (write-line ";;comment"))
+ (handler-bind ((error (lambda (error)
+ (declare (ignore error))
+ (when (find-restart 'sb-fasl::source)
+ (invoke-restart 'sb-fasl::source)))))
+ (load-and-assert spec source source))))
+
+;; Ensure that we can invoke the restart OBJECT in the above case.
+(let* ((source (pathname "load-impure-test.lisp"))
+ (fasl (compile-file-pathname source))
+ (spec (make-pathname :type nil :defaults source)))
+ (with-test-program source fasl
+ (sleep 1)
+ (with-open-file (*standard-output* source :direction :output
+ :if-exists :append)
+ (write-line ";;comment"))
+ (handler-bind ((error (lambda (error)
+ (declare (ignore error))
+ (when (find-restart 'sb-fasl::object)
+ (invoke-restart 'sb-fasl::object)))))
+ (load-and-assert spec fasl fasl))))
+
+(with-test (:name :bug-332)
+ (flet ((stimulate-sbcl ()
+ (let ((filename (format nil "/tmp/~A.lisp" (gensym))))
+ ;; create a file which redefines a structure incompatibly
+ (with-open-file (f filename :direction :output :if-exists :supersede)
+ (print '(defstruct bug-332 foo) f)
+ (print '(defstruct bug-332 foo bar) f))
+ ;; compile and load the file, then invoke the continue restart on
+ ;; the structure redefinition error
+ (handler-bind ((error (lambda (c) (continue c))))
+ (load (compile-file filename))))))
+ (stimulate-sbcl)
+ (stimulate-sbcl)
+ (stimulate-sbcl)))
+
+(defun load-empty-file (type)
+ (let ((pathname (make-pathname :name "load-impure-lisp-empty-temp"
+ :type type)))
+ (unwind-protect
+ (progn
+ (with-open-file (f pathname
+ :if-exists :supersede
+ :direction :output))
+ (handler-case
+ (progn (load pathname) t)
+ (error () nil)))
+ (ignore-errors (delete-file pathname)))))
+
+(with-test (:name (load "empty.lisp"))
+ (assert (load-empty-file "lisp")))
+
+(with-test (:name (load "empty.fasl"))
+ (assert (not (load-empty-file "fasl"))))
+
+(with-test (:name :parallel-fasl-load)
+ #+sb-thread
+ (let ((lisp #p"parallel-fasl-load-test.lisp")
+ (fasl nil)
+ (ready nil))
+ (unwind-protect
+ (progn
+ (multiple-value-bind (compiled warned failed)
+ (compile-file lisp)
+ (setf fasl compiled)
+ (assert (not warned))
+ (assert (not failed))
+ (labels ((load-loop ()
+ (let* ((*standard-output* (make-broadcast-stream))
+ (*error-output* *standard-output*))
+ (sb-ext:wait-for ready)
+ (handler-case
+ (progn
+ (loop repeat 1000
+ do (load fasl)
+ (test-it))
+ t)
+ (error (e) e))))
+ (test-it ()
+ (assert (= 1 (one-fun)))
+ (assert (= 2 (two-fun)))
+ (assert (= 42 (symbol-value '*var*)))
+ (assert (= 13 (symbol-value '*quux*)))))
+ (let ((t1 (sb-thread:make-thread #'load-loop))
+ (t2 (sb-thread:make-thread #'load-loop))
+ (t3 (sb-thread:make-thread #'load-loop)))
+ (setf ready t)
+ (let ((r1 (sb-thread:join-thread t1))
+ (r2 (sb-thread:join-thread t2))
+ (r3 (sb-thread:join-thread t3)))
+ (unless (and (eq t r1) (eq t r2) (eq t r3))
+ (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
+ ;; These ones cannot be tested while redefinitions are running:
+ ;; adding a method implies REMOVE-METHOD, so a call would be racy.
+ (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
+ (assert (eq 'cons (gen-fun '(foo))))
+ (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
+ (test-it)))))
+ (when fasl
+ (ignore-errors (delete-file fasl))))))