teach NODE-CONSERVATIVE-TYPE about union types

[sbcl.git] / tests / load.impure.lisp

diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp
index 461c238..bdc4116 100644 (file)
--- a/tests/load.impure.lisp
+++ b/tests/load.impure.lisp
@@ -84,8 +84,10 @@
            *loaded-pathname* *loaded-truename*)
        (load ,load-argument :print t :verbose t)
        (assert (and (= (1+ ,before) *counter*)
+                    #-win32 ;kludge
                     (equal ,(if pathname `(merge-pathnames ,pathname))
                            *loaded-pathname*)
+                    #-win32 ;kludge
                     (equal ,(if pathname `(merge-pathnames ,truename))
                            *loaded-truename*))))))
 
@@ -271,3 +273,83 @@
                                    (when (find-restart 'sb-fasl::object)
                                      (invoke-restart 'sb-fasl::object)))))
       (load-and-assert spec fasl fasl))))
+
+(with-test (:name :bug-332 :fails-on :win32)
+  (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))))))