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                     #-win32 ;kludge
  88                     (equal ,(if pathname `(merge-pathnames ,pathname))
  89                            *loaded-pathname*)
  90                     #-win32 ;kludge
  91                     (equal ,(if pathname `(merge-pathnames ,truename))
  92                            *loaded-truename*))))))
  93
  94 (defmacro with-test-program (source fasl &body body)
  95   (let ((src (gensym))
  96         (fsl (gensym)))
  97     `(let ((,src ,source)
  98            (,fsl ,fasl))
  99        (with-open-file (*standard-output* ,src :direction :output
 100                                           :if-exists :supersede)
 101          (princ *test-program-string*))
 102        (when ,fsl
 103          (compile-file ,src :output-file ,fsl))
 104        (unwind-protect
 105             (progn
 106               ,@body)
 107          (when (probe-file ,src)
 108            (delete-file ,src))
 109          (when (and ,fsl (probe-file ,fsl))
 110            (delete-file ,fsl))))))
 111
 112 ;;; Loading from streams.
 113
 114 ;; string-stream
 115 (with-input-from-string (s *test-program-string*)
 116   (load-and-assert s nil nil))
 117
 118 ;; file-stream associated with a source file
 119 (let ((source (pathname "load-impure-test.lisp")))
 120   (with-test-program source nil
 121     (with-open-file (stream source)
 122       (load-and-assert stream source source))))
 123
 124 ;; file-stream associated with a fasl file
 125 (let* ((source (pathname "load-impure-test.lisp"))
 126        (fasl (compile-file-pathname source)))
 127   (with-test-program source fasl
 128     (with-open-file (stream fasl :element-type 'unsigned-byte)
 129       (load-and-assert fasl fasl fasl))))
 130
 131 ;; Develop a simple Gray stream to test loading from.
 132 (defclass load-impure-gray-stream (fundamental-character-input-stream)
 133   ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
 134
 135 (defmethod stream-read-char ((stream load-impure-gray-stream))
 136   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 137     (prog1
 138         (if (>= pointer (length *test-program-string*))
 139             :eof
 140             (char *test-program-string* pointer))
 141       (incf pointer))))
 142
 143 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
 144   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 145     (if (<= pointer 0)
 146         (error "fibber!  you never read from this stream ~S" stream)
 147         (decf pointer)))
 148   nil)
 149
 150 (with-open-stream (stream (make-instance 'load-impure-gray-stream))
 151   (load-and-assert stream nil nil))
 152
 153 ;;; Loading from things named by pathname designators.
 154
 155 ;; Test loading a source file by supplying a complete pathname.
 156 (let ((source (pathname "load-impure-test.lisp")))
 157   (with-test-program source nil
 158     (load-and-assert source source source)))
 159
 160 ;; Test loading a source file when supplying a partial pathname.
 161 (let ((source (pathname "load-impure-test.lisp"))
 162       (partial (pathname "load-impure-test")))
 163   (with-test-program source nil
 164     (load-and-assert partial source source)))
 165
 166 ;; Test loading a source file whose name lacks a type when supplying a
 167 ;; partial pathname.
 168 (let ((source (make-pathname :type :unspecific
 169                              :defaults (pathname "load-impure-test")))
 170       (partial (pathname "load-impure-test")))
 171   (with-test-program source nil
 172     (load-and-assert partial partial partial)))
 173
 174 ;; Test loading a fasl
 175 (let* ((source (pathname "load-impure-test.lisp"))
 176        (fasl (compile-file-pathname source)))
 177   (with-test-program source fasl
 178     (load-and-assert fasl fasl fasl)))
 179
 180 ;; Test loading a fasl when supplying a partial pathname.
 181 (let* ((source  (pathname "load-impure-test.lisp"))
 182        (fasl (compile-file-pathname source))
 183        (partial (pathname "load-impure-test")))
 184   (with-test-program source fasl
 185     (load-and-assert partial fasl fasl)))
 186
 187 ;; Test loading a fasl whose name lacks a type when supplying a
 188 ;; partial pathname.
 189 (let* ((source  (pathname "load-impure-test.lisp"))
 190        (fasl (make-pathname :type :unspecific
 191                             :defaults (compile-file-pathname source)))
 192        (partial (pathname "load-impure-test")))
 193   (with-test-program source fasl
 194     (load-and-assert partial partial partial)))
 195
 196 ;; Test loading a fasl with a strange type
 197 (let* ((source (pathname "load-impure-test.lisp"))
 198        (fasl (make-pathname :defaults (compile-file-pathname source)
 199                             :type "compiled-lisp")))
 200   (with-test-program source fasl
 201     (load-and-assert fasl fasl fasl)))
 202
 203 ;;; Errors
 204
 205 ;; Ensure that loading a fasl specified with a type checks for the
 206 ;; header.
 207 (let* ((source (pathname "load-impure-test.lisp"))
 208        (fasl (compile-file-pathname source)))
 209   (with-test-program source fasl
 210     (with-open-file (f fasl :direction :io :if-exists :overwrite
 211                        :element-type '(unsigned-byte 8))
 212       (write-byte 0 f))
 213     (handler-case (load fasl)
 214       (sb-fasl::fasl-header-missing () :ok))))
 215
 216 ;; Ensure that loading a fasl specified without a type checks for the
 217 ;; header.  Note: this wasn't the behavior in
 218 ;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
 219 ;; or so).  If target-load.lisp is reverted to that state eventually,
 220 ;; this test should be removed (or that definition of LOAD altered).
 221 (let* ((source (pathname "load-impure-test.lisp"))
 222        (fasl (compile-file-pathname source))
 223        (fasl-spec (make-pathname :type nil
 224                                  :defaults (compile-file-pathname source))))
 225   (with-test-program source fasl
 226     (with-open-file (f fasl :direction :io :if-exists :overwrite
 227                        :element-type '(unsigned-byte 8))
 228       (write-byte 0 f))
 229     (handler-case (load fasl-spec)
 230       (sb-fasl::fasl-header-missing () :ok))))
 231
 232 ;; Ensure that we get an error when the source file is newer than the
 233 ;; fasl and the supplied argument is an incomplete pathname.
 234 (let* ((source (pathname "load-impure-test.lisp"))
 235        (fasl (compile-file-pathname source))
 236        (spec (make-pathname :type nil :defaults source)))
 237   (with-test-program source fasl
 238     (sleep 1)
 239     (with-open-file (*standard-output* source :direction :output
 240                                        :if-exists :append)
 241       (write-line ";;comment"))
 242     (handler-case (load spec)
 243       ;; IWBNI the error signalled here were more specific than
 244       ;; SIMPLE-ERROR.
 245       (error () :|well, we got an error!|))))
 246
 247 ;; Ensure that we can invoke the restart SOURCE in the above case.
 248 (let* ((source (pathname "load-impure-test.lisp"))
 249        (fasl (compile-file-pathname source))
 250        (spec (make-pathname :type nil :defaults source)))
 251   (with-test-program source fasl
 252     (sleep 1)
 253     (with-open-file (*standard-output* source :direction :output
 254                                        :if-exists :append)
 255       (write-line ";;comment"))
 256     (handler-bind ((error (lambda (error)
 257                                    (declare (ignore error))
 258                                    (when (find-restart 'sb-fasl::source)
 259                                      (invoke-restart 'sb-fasl::source)))))
 260       (load-and-assert spec source source))))
 261
 262 ;; Ensure that we can invoke the restart OBJECT in the above case.
 263 (let* ((source (pathname "load-impure-test.lisp"))
 264        (fasl (compile-file-pathname source))
 265        (spec (make-pathname :type nil :defaults source)))
 266   (with-test-program source fasl
 267     (sleep 1)
 268     (with-open-file (*standard-output* source :direction :output
 269                                        :if-exists :append)
 270       (write-line ";;comment"))
 271     (handler-bind ((error (lambda (error)
 272                                    (declare (ignore error))
 273                                    (when (find-restart 'sb-fasl::object)
 274                                      (invoke-restart 'sb-fasl::object)))))
 275       (load-and-assert spec fasl fasl))))
 276
 277 (with-test (:name :bug-332 :fails-on :win32)
 278   (flet ((stimulate-sbcl ()
 279            (let ((filename (format nil "/tmp/~A.lisp" (gensym))))
 280              ;; create a file which redefines a structure incompatibly
 281              (with-open-file (f filename :direction :output :if-exists :supersede)
 282                (print '(defstruct bug-332 foo) f)
 283                (print '(defstruct bug-332 foo bar) f))
 284              ;; compile and load the file, then invoke the continue restart on
 285              ;; the structure redefinition error
 286              (handler-bind ((error (lambda (c) (continue c))))
 287                (load (compile-file filename))))))
 288     (stimulate-sbcl)
 289     (stimulate-sbcl)
 290     (stimulate-sbcl)))
 291
 292 (defun load-empty-file (type)
 293   (let ((pathname (make-pathname :name "load-impure-lisp-empty-temp"
 294                                  :type type)))
 295       (unwind-protect
 296            (progn
 297              (with-open-file (f pathname
 298                                 :if-exists :supersede
 299                                 :direction :output))
 300              (handler-case
 301                  (progn (load pathname) t)
 302                (error () nil)))
 303         (ignore-errors (delete-file pathname)))))
 304
 305 (with-test (:name (load "empty.lisp"))
 306   (assert (load-empty-file "lisp")))
 307
 308 (with-test (:name (load "empty.fasl"))
 309   (assert (not (load-empty-file "fasl"))))
 310
 311 (with-test (:name :parallel-fasl-load)
 312   #+sb-thread
 313   (let ((lisp #p"parallel-fasl-load-test.lisp")
 314         (fasl nil)
 315         (ready nil))
 316     (unwind-protect
 317          (progn
 318            (multiple-value-bind (compiled warned failed)
 319                (compile-file lisp)
 320              (setf fasl compiled)
 321              (assert (not warned))
 322              (assert (not failed))
 323              (labels ((load-loop ()
 324                         (let* ((*standard-output* (make-broadcast-stream))
 325                                (*error-output* *standard-output*))
 326                           (sb-ext:wait-for ready)
 327                           (handler-case
 328                               (progn
 329                                 (loop repeat 1000
 330                                       do (load fasl)
 331                                          (test-it))
 332                                 t)
 333                             (error (e) e))))
 334                       (test-it ()
 335                         (assert (= 1 (one-fun)))
 336                         (assert (= 2 (two-fun)))
 337                         (assert (= 42 (symbol-value '*var*)))
 338                         (assert (= 13 (symbol-value '*quux*)))))
 339                (let ((t1 (sb-thread:make-thread #'load-loop))
 340                      (t2 (sb-thread:make-thread #'load-loop))
 341                      (t3 (sb-thread:make-thread #'load-loop)))
 342                  (setf ready t)
 343                  (let ((r1 (sb-thread:join-thread t1))
 344                        (r2 (sb-thread:join-thread t2))
 345                        (r3 (sb-thread:join-thread t3)))
 346                    (unless (and (eq t r1) (eq t r2) (eq t r3))
 347                      (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
 348                    ;; These ones cannot be tested while redefinitions are running:
 349                    ;; adding a method implies REMOVE-METHOD, so a call would be racy.
 350                    (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
 351                    (assert (eq 'cons (gen-fun '(foo))))
 352                    (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
 353                  (test-it)))))
 354       (when fasl
 355         (ignore-errors (delete-file fasl))))))