tests/load.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of LOAD
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  14 (defvar *tmp-filename* "load-test.tmp")
  15
  16 ;;; Bug reported by Sean Ross: FASL loader set fill pointer to loaded
  17 ;;; simple arrays.
  18
  19 (defvar *array*)
  20
  21 (progn
  22   (with-open-file (s *tmp-filename*
  23                      :direction :output
  24                      :if-exists :supersede
  25                      :if-does-not-exist :create)
  26     (print '(setq *array* #3a(((1 2) (2 1)) ((3 4) (4 3)))) s))
  27   (let (tmp-fasl)
  28     (unwind-protect
  29          (progn
  30            (setq tmp-fasl (compile-file *tmp-filename*))
  31            (let ((*array* nil))
  32              (load tmp-fasl)
  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*))))
  38
  39 ;;; rudimentary external-format test
  40 (dolist (ef '(:default :ascii :latin-1 :utf-8))
  41   (with-open-file (s *tmp-filename*
  42                      :direction :output
  43                      :if-exists :supersede
  44                      :if-does-not-exist :create)
  45     (print '(defun foo (x) (1+ x)) s))
  46   (fmakunbound 'foo)
  47   (let (tmp-fasl)
  48     (unwind-protect
  49          (progn
  50            (setq tmp-fasl (compile-file *tmp-filename* :external-format ef))
  51            (load tmp-fasl)
  52            (assert (= (foo 1) 2)))
  53       (when tmp-fasl (delete-file tmp-fasl))
  54       (delete-file *tmp-filename*))))
  55
  56 ;;; As reported by David Tolpin *LOAD-PATHNAME* was not merged.
  57 (progn
  58   (defvar *saved-load-pathname*)
  59   (with-open-file (s *tmp-filename*
  60                      :direction :output
  61                      :if-exists :supersede
  62                      :if-does-not-exist :create)
  63     (print '(setq *saved-load-pathname* *load-pathname*) s))
  64   (let (tmp-fasl)
  65     (unwind-protect
  66          (progn
  67            (load *tmp-filename*)
  68            (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
  69       (delete-file *tmp-filename*))))
  70 \f
  71 ;;; Test many, many variations on LOAD.
  72 (defparameter *counter* 0)
  73 (defparameter *loaded-pathname* nil)
  74 (defparameter *loaded-truename* nil)
  75
  76 (defparameter *test-program-string* (format nil "~
  77  (incf *counter*)
  78  (setf *loaded-pathname* *load-pathname*)
  79  (setf *loaded-truename* *load-truename*)"))
  80
  81 (defmacro load-and-assert (load-argument pathname truename)
  82   (let ((before (gensym)))
  83     `(let ((,before *counter*)
  84            *loaded-pathname* *loaded-truename*)
  85        (load ,load-argument :print t :verbose t)
  86        (assert (and (= (1+ ,before) *counter*)
  87                     (equal ,(if pathname `(merge-pathnames ,pathname))
  88                            *loaded-pathname*)
  89                     (equal ,(if pathname `(merge-pathnames ,truename))
  90                            *loaded-truename*))))))
  91
  92 (defmacro with-test-program (source fasl &body body)
  93   (let ((src (gensym))
  94         (fsl (gensym)))
  95     `(let ((,src ,source)
  96            (,fsl ,fasl))
  97        (with-open-file (*standard-output* ,src :direction :output
  98                                           :if-exists :supersede)
  99          (princ *test-program-string*))
 100        (when ,fsl
 101          (compile-file ,src :output-file ,fsl))
 102        (unwind-protect
 103             (progn
 104               ,@body)
 105          (when (probe-file ,src)
 106            (delete-file ,src))
 107          (when (and ,fsl (probe-file ,fsl))
 108            (delete-file ,fsl))))))
 109
 110 ;;; Loading from streams.
 111
 112 ;; string-stream
 113 (with-input-from-string (s *test-program-string*)
 114   (load-and-assert s nil nil))
 115
 116 ;; file-stream associated with a source file
 117 (let ((source (pathname "load-impure-test.lisp")))
 118   (with-test-program source nil
 119     (with-open-file (stream source)
 120       (load-and-assert stream source source))))
 121
 122 ;; file-stream associated with a fasl file
 123 (let* ((source (pathname "load-impure-test.lisp"))
 124        (fasl (compile-file-pathname source)))
 125   (with-test-program source fasl
 126     (with-open-file (stream fasl :element-type 'unsigned-byte)
 127       (load-and-assert fasl fasl fasl))))
 128
 129 ;; Develop a simple Gray stream to test loading from.
 130 (defclass load-impure-gray-stream (fundamental-character-input-stream)
 131   ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
 132
 133 (defmethod stream-read-char ((stream load-impure-gray-stream))
 134   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 135     (prog1
 136         (if (>= pointer (length *test-program-string*))
 137             :eof
 138             (char *test-program-string* pointer))
 139       (incf pointer))))
 140
 141 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
 142   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 143     (if (<= pointer 0)
 144         (error "fibber!  you never read from this stream ~S" stream)
 145         (decf pointer)))
 146   nil)
 147
 148 (with-open-stream (stream (make-instance 'load-impure-gray-stream))
 149   (load-and-assert stream nil nil))
 150
 151 ;;; Loading from things named by pathname designators.
 152
 153 ;; Test loading a source file by supplying a complete pathname.
 154 (let ((source (pathname "load-impure-test.lisp")))
 155   (with-test-program source nil
 156     (load-and-assert source source source)))
 157
 158 ;; Test loading a source file when supplying a partial pathname.
 159 (let ((source (pathname "load-impure-test.lisp"))
 160       (partial (pathname "load-impure-test")))
 161   (with-test-program source nil
 162     (load-and-assert partial source source)))
 163
 164 ;; Test loading a source file whose name lacks a type when supplying a
 165 ;; partial pathname.
 166 (let ((source (make-pathname :type :unspecific
 167                              :defaults (pathname "load-impure-test")))
 168       (partial (pathname "load-impure-test")))
 169   (with-test-program source nil
 170     (load-and-assert partial partial partial)))
 171
 172 ;; Test loading a fasl
 173 (let* ((source (pathname "load-impure-test.lisp"))
 174        (fasl (compile-file-pathname source)))
 175   (with-test-program source fasl
 176     (load-and-assert fasl fasl fasl)))
 177
 178 ;; Test loading a fasl when supplying a partial pathname.
 179 (let* ((source  (pathname "load-impure-test.lisp"))
 180        (fasl (compile-file-pathname source))
 181        (partial (pathname "load-impure-test")))
 182   (with-test-program source fasl
 183     (load-and-assert partial fasl fasl)))
 184
 185 ;; Test loading a fasl whose name lacks a type when supplying a
 186 ;; partial pathname.
 187 (let* ((source  (pathname "load-impure-test.lisp"))
 188        (fasl (make-pathname :type :unspecific
 189                             :defaults (compile-file-pathname source)))
 190        (partial (pathname "load-impure-test")))
 191   (with-test-program source fasl
 192     (load-and-assert partial partial partial)))
 193
 194 ;; Test loading a fasl with a strange type
 195 (let* ((source (pathname "load-impure-test.lisp"))
 196        (fasl (make-pathname :defaults (compile-file-pathname source)
 197                             :type "compiled-lisp")))
 198   (with-test-program source fasl
 199     (load-and-assert fasl fasl fasl)))
 200
 201 ;;; Errors
 202
 203 ;; Ensure that loading a fasl specified with a type checks for the
 204 ;; header.
 205 (let* ((source (pathname "load-impure-test.lisp"))
 206        (fasl (compile-file-pathname source)))
 207   (with-test-program source fasl
 208     (with-open-file (f fasl :direction :io :if-exists :overwrite
 209                        :element-type '(unsigned-byte 8))
 210       (write-byte 0 f))
 211     (handler-case (load fasl)
 212       (sb-fasl::fasl-header-missing () :ok))))
 213
 214 ;; Ensure that loading a fasl specified without a type checks for the
 215 ;; header.  Note: this wasn't the behavior in
 216 ;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
 217 ;; or so).  If target-load.lisp is reverted to that state eventually,
 218 ;; this test should be removed (or that definition of LOAD altered).
 219 (let* ((source (pathname "load-impure-test.lisp"))
 220        (fasl (compile-file-pathname source))
 221        (fasl-spec (make-pathname :type nil
 222                                  :defaults (compile-file-pathname source))))
 223   (with-test-program source fasl
 224     (with-open-file (f fasl :direction :io :if-exists :overwrite
 225                        :element-type '(unsigned-byte 8))
 226       (write-byte 0 f))
 227     (handler-case (load fasl-spec)
 228       (sb-fasl::fasl-header-missing () :ok))))
 229
 230 ;; Ensure that we get an error when the source file is newer than the
 231 ;; fasl and the supplied argument is an incomplete pathname.
 232 (let* ((source (pathname "load-impure-test.lisp"))
 233        (fasl (compile-file-pathname source))
 234        (spec (make-pathname :type nil :defaults source)))
 235   (with-test-program source fasl
 236     (sleep 1)
 237     (with-open-file (*standard-output* source :direction :output
 238                                        :if-exists :append)
 239       (write-line ";;comment"))
 240     (handler-case (load spec)
 241       ;; IWBNI the error signalled here were more specific than
 242       ;; SIMPLE-ERROR.
 243       (error () :|well, we got an error!|))))
 244
 245 ;; Ensure that we can invoke the restart SOURCE in the above case.
 246 (let* ((source (pathname "load-impure-test.lisp"))
 247        (fasl (compile-file-pathname source))
 248        (spec (make-pathname :type nil :defaults source)))
 249   (with-test-program source fasl
 250     (sleep 1)
 251     (with-open-file (*standard-output* source :direction :output
 252                                        :if-exists :append)
 253       (write-line ";;comment"))
 254     (handler-bind ((error (lambda (error)
 255                                    (declare (ignore error))
 256                                    (when (find-restart 'sb-fasl::source)
 257                                      (invoke-restart 'sb-fasl::source)))))
 258       (load-and-assert spec source source))))
 259
 260 ;; Ensure that we can invoke the restart OBJECT in the above case.
 261 (let* ((source (pathname "load-impure-test.lisp"))
 262        (fasl (compile-file-pathname source))
 263        (spec (make-pathname :type nil :defaults source)))
 264   (with-test-program source fasl
 265     (sleep 1)
 266     (with-open-file (*standard-output* source :direction :output
 267                                        :if-exists :append)
 268       (write-line ";;comment"))
 269     (handler-bind ((error (lambda (error)
 270                                    (declare (ignore error))
 271                                    (when (find-restart 'sb-fasl::object)
 272                                      (invoke-restart 'sb-fasl::object)))))
 273       (load-and-assert spec fasl fasl))))
 274
 275 (with-test (:name :bug-332)
 276   (flet ((stimulate-sbcl ()
 277            (let ((filename (format nil "/tmp/~A.lisp" (gensym))))
 278              ;; create a file which redefines a structure incompatibly
 279              (with-open-file (f filename :direction :output :if-exists :supersede)
 280                (print '(defstruct bug-332 foo) f)
 281                (print '(defstruct bug-332 foo bar) f))
 282              ;; compile and load the file, then invoke the continue restart on
 283              ;; the structure redefinition error
 284              (handler-bind ((error (lambda (c) (continue c))))
 285                (load (compile-file filename))))))
 286     (stimulate-sbcl)
 287     (stimulate-sbcl)
 288     (stimulate-sbcl)))
 289
 290