X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fload.impure.lisp;h=ee43f50411f11b4a9da3804107ec3f84a2f7d383;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=7466edb54f715e83987626ad9cafaa646d823854;hpb=53f576d7d796e37a9c51c3c3296341458f046c44;p=sbcl.git diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index 7466edb..ee43f50 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -55,18 +55,17 @@ ;;; As reported by David Tolpin *LOAD-PATHNAME* was not merged. (progn - (defvar *saved-load-pathname*) + (defparameter *saved-load-pathname* nil) (with-open-file (s *tmp-filename* :direction :output :if-exists :supersede :if-does-not-exist :create) (print '(setq *saved-load-pathname* *load-pathname*) s)) - (let (tmp-fasl) - (unwind-protect - (progn - (load *tmp-filename*) - (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*))) - (delete-file *tmp-filename*)))) + (unwind-protect + (progn + (load *tmp-filename*) + (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*))) + (delete-file *tmp-filename*))) ;;; Test many, many variations on LOAD. (defparameter *counter* 0) @@ -84,8 +83,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*)))))) @@ -252,9 +253,9 @@ :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))))) + (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. @@ -267,14 +268,20 @@ :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))))) + (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)))) + (let ((filename + (format nil "~A/~A.lisp" + (or (posix-getenv "TEST_DIRECTORY") + (posix-getenv "TMPDIR") + "/tmp") + (gensym)))) + (ensure-directories-exist filename) ;; create a file which redefines a structure incompatibly (with-open-file (f filename :direction :output :if-exists :supersede) (print '(defstruct bug-332 foo) f) @@ -287,4 +294,125 @@ (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)))))) + +(defvar *pack*) +#+sb-simd-pack +(with-test (:name :load-simd-pack-int) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack integer))) + (assert (= 2 (sb-kernel:%simd-pack-low *pack*))) + (assert (= 4 (sb-kernel:%simd-pack-high *pack*))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) + +#+sb-simd-pack +(with-test (:name :load-simd-pack-single) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack single-float))) + (assert (equal (multiple-value-list (sb-kernel:%simd-pack-singles *pack*)) + '(1f0 2f0 3f0 4f0))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*)))) +#+sb-simd-pack +(with-test (:name :load-simd-pack-double) + (with-open-file (s *tmp-filename* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s)) + (let (tmp-fasl) + (unwind-protect + (progn + (setq tmp-fasl (compile-file *tmp-filename*)) + (let ((*pack* nil)) + (load tmp-fasl) + (assert (typep *pack* '(sb-kernel:simd-pack double-float))) + (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*)) + '(1d0 2d0))))) + (when tmp-fasl (delete-file tmp-fasl)) + (delete-file *tmp-filename*))))