X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fload.impure.lisp;h=7466edb54f715e83987626ad9cafaa646d823854;hb=ae09f8fd7765f6cab6ad317a13e27ff22ab0c11e;hp=fb107f406660f5faff8d00d060af1478ad21a6bf;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp
index fb107f4..7466edb 100644
--- a/tests/load.impure.lisp
+++ b/tests/load.impure.lisp
@@ -67,5 +67,224 @@
            (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)
+(defparameter *loaded-pathname* nil)
+(defparameter *loaded-truename* nil)
+
+(defparameter *test-program-string* (format nil "~
+ (incf *counter*)
+ (setf *loaded-pathname* *load-pathname*)
+ (setf *loaded-truename* *load-truename*)"))
+
+(defmacro load-and-assert (load-argument pathname truename)
+  (let ((before (gensym)))
+    `(let ((,before *counter*)
+           *loaded-pathname* *loaded-truename*)
+       (load ,load-argument :print t :verbose t)
+       (assert (and (= (1+ ,before) *counter*)
+                    (equal ,(if pathname `(merge-pathnames ,pathname))
+                           *loaded-pathname*)
+                    (equal ,(if pathname `(merge-pathnames ,truename))
+                           *loaded-truename*))))))
+
+(defmacro with-test-program (source fasl &body body)
+  (let ((src (gensym))
+        (fsl (gensym)))
+    `(let ((,src ,source)
+           (,fsl ,fasl))
+       (with-open-file (*standard-output* ,src :direction :output
+                                          :if-exists :supersede)
+         (princ *test-program-string*))
+       (when ,fsl
+         (compile-file ,src :output-file ,fsl))
+       (unwind-protect
+            (progn
+              ,@body)
+         (when (probe-file ,src)
+           (delete-file ,src))
+         (when (and ,fsl (probe-file ,fsl))
+           (delete-file ,fsl))))))
+
+;;; Loading from streams.
+
+;; string-stream
+(with-input-from-string (s *test-program-string*)
+  (load-and-assert s nil nil))
+
+;; file-stream associated with a source file
+(let ((source (pathname "load-impure-test.lisp")))
+  (with-test-program source nil
+    (with-open-file (stream source)
+      (load-and-assert stream source source))))
+
+;; file-stream associated with a fasl file
+(let* ((source (pathname "load-impure-test.lisp"))
+       (fasl (compile-file-pathname source)))
+  (with-test-program source fasl
+    (with-open-file (stream fasl :element-type 'unsigned-byte)
+      (load-and-assert fasl fasl fasl))))
+
+;; Develop a simple Gray stream to test loading from.
+(defclass load-impure-gray-stream (fundamental-character-input-stream)
+  ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
+
+(defmethod stream-read-char ((stream load-impure-gray-stream))
+  (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
+    (prog1
+        (if (>= pointer (length *test-program-string*))
+            :eof
+            (char *test-program-string* pointer))
+      (incf pointer))))
+
+(defmethod stream-unread-char ((stream load-impure-gray-stream) char)
+  (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
+    (if (<= pointer 0)
+        (error "fibber!  you never read from this stream ~S" stream)
+        (decf pointer)))
+  nil)
+
+(with-open-stream (stream (make-instance 'load-impure-gray-stream))
+  (load-and-assert stream nil nil))
+
+;;; Loading from things named by pathname designators.
+
+;; Test loading a source file by supplying a complete pathname.
+(let ((source (pathname "load-impure-test.lisp")))
+  (with-test-program source nil
+    (load-and-assert source source source)))
+
+;; Test loading a source file when supplying a partial pathname.
+(let ((source (pathname "load-impure-test.lisp"))
+      (partial (pathname "load-impure-test")))
+  (with-test-program source nil
+    (load-and-assert partial source source)))
+
+;; Test loading a source file whose name lacks a type when supplying a
+;; partial pathname.
+(let ((source (make-pathname :type :unspecific
+                             :defaults (pathname "load-impure-test")))
+      (partial (pathname "load-impure-test")))
+  (with-test-program source nil
+    (load-and-assert partial partial partial)))
+
+;; 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)))
+
 
-(quit :unix-status 104)