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* (scratch-file-name "tmp"))
  15
  16 ;;; These tests are essentially the same as in compiler.pure.lisp
  17 ;;; They have to be run before we mess up *DEFAULT-PATHNAME-DEFAULTS*
  18 (with-test (:name :load-as-source-error-position-reporting)
  19   ;; These test errors that occur during READ
  20   (dolist (input '("data/wonky1.lisp" "data/wonky2.lisp" "data/wonky3.lisp"))
  21     (let ((expect (with-open-file (f input) (read f))))
  22       (assert (stringp expect))
  23       (let ((err-string
  24              (block foo
  25                ;; you can't query the stream position with HANDLER-CASE
  26                ;; because it closes before the condition is formatted.
  27                (handler-bind ((error (lambda (c)
  28                                        (return-from foo
  29                                          (write-to-string c :escape nil)))))
  30                  (load input)))))
  31         (assert (search expect err-string)))))
  32
  33   ;; This tests an error that occur during EVAL
  34   (let ((s (with-output-to-string (*error-output*)
  35              (handler-bind ((error #'abort)) (load "data/wonky4.lisp")))))
  36     (assert (search "While evaluating the form starting at line 16, column 1"
  37                     s))))
  38
  39 ;;; Save this because we're going to mess up the path in the following SETQ.
  40 (defvar *parallel-load-source-file* (truename "parallel-fasl-load-test.lisp"))
  41
  42 ;;; Tests in this file make assertions about behavior of LOAD or OPEN when given
  43 ;;; partial pathnames. As such, fully qualifying the pathname arguments with the
  44 ;;; temp dir would totally defeat the point of the tests. While we can't assume
  45 ;;; that the current directory is writable, we can change the defaults to the temp
  46 ;;; dir which doesn't affect the meaning of the tests, since they don't care where
  47 ;;; their files are, with the one exception being "parallel-load".
  48 ;;; I'm not doing this for win32 since I don't know what works there.
  49 #-win32 (setq *default-pathname-defaults*
  50               (truename (make-pathname :directory
  51                                        (pathname-directory (scratch-file-name)))))
  52
  53 ;;; Loading from Lisp should set the TOPLEVEL-FORM-NUMBER slot
  54 (with-test (:name :load-lisp-assigns-tlf-num)
  55   (with-open-file (f *tmp-filename* :direction :output
  56                      :if-exists :supersede :if-does-not-exist :create)
  57     (write '(defvar *var0* 'this-is-form-0) :stream f)
  58     (write '(defvar *var1* 'this-is-form-1) :stream f))
  59   (load *tmp-filename*)
  60   (assert (eql 0 (sb-c:definition-source-location-toplevel-form-number
  61                      (sb-int:info :source-location :variable '*var0*))))
  62   (assert (eql 1 (sb-c:definition-source-location-toplevel-form-number
  63                      (sb-int:info :source-location :variable '*var1*))))
  64   (delete-file *tmp-filename*))
  65
  66 ;;; Bug reported by Sean Ross: FASL loader set fill pointer to loaded
  67 ;;; simple arrays.
  68
  69 (defvar *array*)
  70
  71 (progn
  72   (with-open-file (s *tmp-filename*
  73                      :direction :output
  74                      :if-exists :supersede
  75                      :if-does-not-exist :create)
  76     (print '(setq *array* #3a(((1 2) (2 1)) ((3 4) (4 3)))) s))
  77   (let (tmp-fasl)
  78     (unwind-protect
  79          (progn
  80            (setq tmp-fasl (compile-file *tmp-filename*))
  81            (let ((*array* nil))
  82              (load tmp-fasl)
  83              (assert (arrayp *array*))
  84              (assert (= (array-rank *array*) 3))
  85              (assert (not (array-has-fill-pointer-p *array*)))))
  86       (when tmp-fasl (delete-file tmp-fasl))
  87       (delete-file *tmp-filename*))))
  88
  89 ;;; rudimentary external-format test
  90 (dolist (ef '(:default :ascii :latin-1 :utf-8))
  91   (with-open-file (s *tmp-filename*
  92                      :direction :output
  93                      :if-exists :supersede
  94                      :if-does-not-exist :create)
  95     (print '(defun foo (x) (1+ x)) s))
  96   (fmakunbound 'foo)
  97   (let (tmp-fasl)
  98     (unwind-protect
  99          (progn
 100            (setq tmp-fasl (compile-file *tmp-filename* :external-format ef))
 101            (load tmp-fasl)
 102            (assert (= (foo 1) 2)))
 103       (when tmp-fasl (delete-file tmp-fasl))
 104       (delete-file *tmp-filename*))))
 105
 106 ;;; As reported by David Tolpin *LOAD-PATHNAME* was not merged.
 107 (progn
 108   (defparameter *saved-load-pathname* nil)
 109   (with-open-file (s *tmp-filename*
 110                      :direction :output
 111                      :if-exists :supersede
 112                      :if-does-not-exist :create)
 113     (print '(setq *saved-load-pathname* *load-pathname*) s))
 114   (unwind-protect
 115        (progn
 116          (load *tmp-filename*)
 117          (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
 118     (delete-file *tmp-filename*)))
 119 \f
 120 ;;; Test many, many variations on LOAD.
 121 (defparameter *counter* 0)
 122 (defparameter *loaded-pathname* nil)
 123 (defparameter *loaded-truename* nil)
 124
 125 (defparameter *test-program-string* (format nil "~
 126  (incf *counter*)
 127  (setf *loaded-pathname* *load-pathname*)
 128  (setf *loaded-truename* *load-truename*)"))
 129
 130 (defmacro load-and-assert (load-argument pathname truename)
 131   (let ((before (gensym)))
 132     `(let ((,before *counter*)
 133            *loaded-pathname* *loaded-truename*)
 134        (load ,load-argument :print 'yes :verbose t)
 135        (assert (and (= (1+ ,before) *counter*)
 136                     #-win32 ;kludge
 137                     (equal ,(if pathname `(merge-pathnames ,pathname))
 138                            *loaded-pathname*)
 139                     #-win32 ;kludge
 140                     (equal ,(if pathname `(merge-pathnames ,truename))
 141                            *loaded-truename*))))))
 142
 143 (defmacro with-test-program (source fasl &body body)
 144   (let ((src (gensym))
 145         (fsl (gensym)))
 146     `(let ((,src ,source)
 147            (,fsl ,fasl))
 148        (with-open-file (*standard-output* ,src :direction :output
 149                                           :if-exists :supersede)
 150          (princ *test-program-string*))
 151        (when ,fsl
 152          (compile-file ,src :output-file ,fsl))
 153        (unwind-protect
 154             (progn
 155               ,@body)
 156          (when (probe-file ,src)
 157            (delete-file ,src))
 158          (when (and ,fsl (probe-file ,fsl))
 159            (delete-file ,fsl))))))
 160
 161 ;;; Loading from streams.
 162
 163 ;; string-stream
 164 (with-test (:name :load-string-stream)
 165   (with-input-from-string (s *test-program-string*)
 166     (load-and-assert s nil nil)))
 167
 168 ;; file-stream associated with a source file
 169 (with-test (:name :load-lisp-file-stream)
 170   (let ((source (scratch-file-name "lisp")))
 171     (with-test-program source nil
 172       (with-open-file (stream source)
 173         (load-and-assert stream source source)))))
 174
 175 ;; file-stream associated with a fasl file
 176 (with-test (:name :load-fasl-file-stream)
 177   (let* ((source (scratch-file-name "lisp"))
 178          (fasl (compile-file-pathname source)))
 179     (with-test-program source fasl
 180       (with-open-file (stream fasl :element-type 'unsigned-byte)
 181         (load-and-assert fasl fasl fasl)))))
 182
 183 ;; Develop a simple Gray stream to test loading from.
 184 (defclass load-impure-gray-stream (fundamental-character-input-stream)
 185   ((pointer :initform 0 :accessor load-impure-gray-stream-pointer)))
 186
 187 (defmethod stream-read-char ((stream load-impure-gray-stream))
 188   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 189     (prog1
 190         (if (>= pointer (length *test-program-string*))
 191             :eof
 192             (char *test-program-string* pointer))
 193       (incf pointer))))
 194
 195 (defmethod stream-unread-char ((stream load-impure-gray-stream) char)
 196   (with-accessors ((pointer load-impure-gray-stream-pointer)) stream
 197     (if (<= pointer 0)
 198         (error "fibber!  you never read from this stream ~S" stream)
 199         (decf pointer)))
 200   nil)
 201
 202 (with-test (:name :load-gray-stream)
 203   (with-open-stream (stream (make-instance 'load-impure-gray-stream))
 204     (load-and-assert stream nil nil)))
 205
 206 ;;; Loading from things named by pathname designators.
 207
 208 (defvar *tmp-lisp-filename* (scratch-file-name "lisp"))
 209
 210 ;; Test loading a source file by supplying a complete pathname.
 211 (with-test (:name :load-source-file-full-pathname)
 212   (let ((source *tmp-lisp-filename*))
 213     (with-test-program source nil
 214       (load-and-assert source source source))))
 215
 216 ;; Test loading a source file when supplying a partial pathname.
 217 (with-test (:name :load-source-file-partial-pathname)
 218   (let ((source *tmp-lisp-filename*)
 219         (partial (make-pathname :defaults *tmp-lisp-filename*
 220                                  :type nil)))
 221     (with-test-program source nil
 222       (load-and-assert partial source source))))
 223
 224 (when (find-symbol "%LOAD-TRUENAME" "SB-FASL") (push :no-test-load-truename *features*))
 225
 226 ;; Test loading a source file whose name lacks a type when supplying a
 227 ;; partial pathname.
 228 (with-test (:name :load-source-file-default-type :skipped-on :no-test-load-truename)
 229   (let ((source (make-pathname :type :unspecific
 230                                :defaults *tmp-lisp-filename*))
 231         (partial (make-pathname :defaults *tmp-lisp-filename*
 232                                 :type nil)))
 233     (with-test-program source nil
 234       (load-and-assert partial partial partial))))
 235
 236 ;; Test loading a fasl
 237 (with-test (:name :load-fasl-file)
 238   (let* ((source *tmp-lisp-filename*)
 239          (fasl (compile-file-pathname source)))
 240     (with-test-program source fasl
 241       (load-and-assert fasl fasl fasl))))
 242
 243 ;; Test loading a fasl when supplying a partial pathname.
 244 (with-test (:name :load-fasl-file-partial-pathname)
 245   (let* ((source *tmp-lisp-filename*)
 246          (fasl (compile-file-pathname source))
 247          (partial (make-pathname :defaults *tmp-lisp-filename*
 248                                  :type nil)))
 249     (with-test-program source fasl
 250       (load-and-assert partial fasl fasl))))
 251
 252 ;; Test loading a fasl whose name lacks a type when supplying a
 253 ;; partial pathname.
 254 (with-test (:name :load-fasl-file-default-type :skipped-on :no-test-load-truename)
 255   (let* ((source  *tmp-lisp-filename*)
 256          (fasl (make-pathname :type :unspecific
 257                               :defaults (compile-file-pathname source)))
 258          (partial (make-pathname :defaults *tmp-lisp-filename*
 259                                  :type nil)))
 260     (with-test-program source fasl
 261       (load-and-assert partial partial partial))))
 262
 263 ;; Test loading a fasl with a strange type
 264 (with-test (:name :load-fasl-file-strange-type :skipped-on :no-test-load-truename)
 265   (let* ((source *tmp-lisp-filename*)
 266          (fasl (make-pathname :defaults (compile-file-pathname source)
 267                               :type "compiled-lisp")))
 268     (with-test-program source fasl
 269       (load-and-assert fasl fasl fasl))))
 270
 271 ;;; Errors
 272
 273 ;; Ensure that loading a fasl specified with a type checks for the
 274 ;; header.
 275 (with-test (:name :load-fasl-header-missing-1
 276             ;; somehow the header needs to get tested without a pre-test of the file length
 277             :skipped-on :no-test-load-truename)
 278   (let* ((source *tmp-lisp-filename*)
 279          (fasl (compile-file-pathname source)))
 280     (with-test-program source fasl
 281       (with-open-file (f fasl :direction :io :if-exists :overwrite
 282                          :element-type '(unsigned-byte 8))
 283         (write-byte 0 f))
 284       (handler-case (load fasl)
 285         (sb-fasl::fasl-header-missing () :ok)))))
 286
 287 ;; Ensure that loading a fasl specified without a type checks for the
 288 ;; header.  Note: this wasn't the behavior in
 289 ;; src/code/target-load.lisp v1.40 and earlier (SBCL version 1.0.12.35
 290 ;; or so).  If target-load.lisp is reverted to that state eventually,
 291 ;; this test should be removed (or that definition of LOAD altered).
 292 (with-test (:name :load-fasl-header-missing-2
 293             ;; this test is probably bad for for the same reason the STRANGE-TYPE test is
 294             :skipped-on :no-test-load-truename)
 295   (let* ((source *tmp-lisp-filename*)
 296          (fasl (compile-file-pathname source))
 297          (fasl-spec (make-pathname :type nil
 298                                    :defaults (compile-file-pathname source))))
 299     (with-test-program source fasl
 300       (with-open-file (f fasl :direction :io :if-exists :overwrite
 301                          :element-type '(unsigned-byte 8))
 302         (write-byte 0 f))
 303       (handler-case (load fasl-spec)
 304         (sb-fasl::fasl-header-missing () :ok)))))
 305
 306 ;; Ensure that we get an error when the source file is newer than the
 307 ;; fasl and the supplied argument is an incomplete pathname.
 308 (with-test (:name :load-default-obsolete-fasl)
 309   (let* ((source *tmp-lisp-filename*)
 310          (fasl (compile-file-pathname source))
 311          (spec (make-pathname :type nil :defaults source)))
 312     (with-test-program source fasl
 313       (sleep 1)
 314       (with-open-file (*standard-output* source :direction :output
 315                                          :if-exists :append)
 316         (write-line ";;comment"))
 317       (handler-case (load spec)
 318         ;; IWBNI the error signalled here were more specific than
 319         ;; SIMPLE-ERROR.
 320         (error () :|well, we got an error!|)))))
 321
 322 ;; Ensure that we can invoke the restart SOURCE in the above case.
 323 (with-test (:name :load-default-obsolete-fasl-restart-source)
 324   (let* ((source *tmp-lisp-filename*)
 325          (fasl (compile-file-pathname source))
 326          (spec (make-pathname :type nil :defaults source)))
 327     (with-test-program source fasl
 328       (sleep 1)
 329       (with-open-file (*standard-output* source :direction :output
 330                                          :if-exists :append)
 331         (write-line ";;comment"))
 332       (handler-bind ((error (lambda (error)
 333                               (declare (ignore error))
 334                               (when (find-restart 'sb-fasl::source)
 335                                 (invoke-restart 'sb-fasl::source)))))
 336         (load-and-assert spec source source)))))
 337
 338 ;; Ensure that we can invoke the restart OBJECT in the above case.
 339 (with-test (:name :load-defaulted-obsolete-fasl-restart-object)
 340   (let* ((source *tmp-lisp-filename*)
 341          (fasl (compile-file-pathname source))
 342          (spec (make-pathname :type nil :defaults source)))
 343     (with-test-program source fasl
 344       (sleep 1)
 345       (with-open-file (*standard-output* source :direction :output
 346                                          :if-exists :append)
 347         (write-line ";;comment"))
 348       (handler-bind ((error (lambda (error)
 349                               (declare (ignore error))
 350                               (when (find-restart 'sb-fasl::object)
 351                                 (invoke-restart 'sb-fasl::object)))))
 352         (load-and-assert spec fasl fasl)))))
 353
 354 (with-test (:name :bug-332)
 355   (flet ((stimulate-sbcl ()
 356            ;; compile and load the file, then invoke the continue restart on
 357            ;; the structure redefinition error
 358            (handler-bind ((error (lambda (c) (continue c))))
 359              (let ((fasl (compile-file "bug-332.lisp")))
 360                (load fasl)
 361                (ignore-errors (delete-file fasl))))))
 362     (stimulate-sbcl)
 363     (stimulate-sbcl)
 364     (stimulate-sbcl)))
 365
 366 (defun load-empty-file (type)
 367   (let ((pathname (scratch-file-name type)))
 368       (unwind-protect
 369            (progn
 370              (with-open-file (f pathname
 371                                 :if-exists :supersede
 372                                 :direction :output))
 373              (handler-case
 374                  (progn (load pathname) t)
 375                (error () nil)))
 376         (ignore-errors (delete-file pathname)))))
 377
 378 (with-test (:name (load :empty.lisp))
 379   (assert (load-empty-file "lisp")))
 380
 381 (with-test (:name (load :empty.fasl))
 382   (assert (not (load-empty-file "fasl"))))
 383
 384 ;; There is a concurrency bug in ALLOCATE-CODE-OBJECT leading to deadlock.
 385 ;; Some changes to the compiler caused it to more often compile a TLF into
 386 ;; a callable lamda - as contrasted with a sequence of operations performed
 387 ;; entirely by the fasl interpreter - which exacerbated the problem.
 388 ;; A meager attempt at a fix of mutex-guarding ALLOCATE-CODE-OBJECT did not
 389 ;; resolve the deadlock, and was not ideal anyway.
 390 (with-test (:name :parallel-fasl-load
 391             :skipped-on :sb-safepoint)
 392   #+sb-thread
 393   (with-scratch-file (fasl "fasl")
 394     (let ((ready nil))
 395       (multiple-value-bind (compiled warned failed)
 396           (compile-file *parallel-load-source-file* :output-file fasl)
 397         (assert (not warned))
 398         (assert (not failed)))
 399       (labels ((load-loop ()
 400                  (let* ((*standard-output* (make-broadcast-stream))
 401                         (*error-output* *standard-output*))
 402                    (sb-ext:wait-for ready)
 403                    (handler-case (dotimes (i 1000 t)
 404                                    (load fasl)
 405                                    (test-it))
 406                      (error (e) e))))
 407                (test-it ()
 408                  (assert (= 1 (one-fun)))
 409                  (assert (= 2 (two-fun)))
 410                  (assert (= 42 (symbol-value '*var*)))
 411                  (assert (= 13 (symbol-value '*quux*)))))
 412         (let ((t1 (sb-thread:make-thread #'load-loop))
 413               (t2 (sb-thread:make-thread #'load-loop))
 414               (t3 (sb-thread:make-thread #'load-loop)))
 415           (setf ready t)
 416           (let ((r1 (sb-thread:join-thread t1))
 417                 (r2 (sb-thread:join-thread t2))
 418                 (r3 (sb-thread:join-thread t3)))
 419             (unless (and (eq t r1) (eq t r2) (eq t r3))
 420               (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
 421             ;; These ones cannot be tested while redefinitions are running:
 422             ;; adding a method implies REMOVE-METHOD, so a call would be racy.
 423             (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
 424             (assert (eq 'cons (gen-fun '(foo))))
 425             (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
 426           (test-it))))))
 427
 428 ;; Check that ':load print' on a fasl has some non-null effect
 429 (with-test (:name :fasloader-print)
 430   (with-open-file (stream *tmp-filename*
 431                           :direction :output :if-exists :supersede)
 432     (dolist (form '((defmacro some-fancy-macro (x) `(car ,x))
 433                     (defvar *some-var* () nil)
 434                     (deftype my-favorite-type () '(integer -1 8))
 435                     (defun fred (x) (- x))
 436                     (push (some-fancy-macro '(a . b)) *some-var*)))
 437       (write form :stream stream)))
 438   (let* ((s (make-string-output-stream))
 439          (output (compile-file *tmp-filename*)))
 440     (let ((*standard-output* s))
 441       (load output :print 0))
 442     (delete-file output)
 443     (assert (not (string= (get-output-stream-string s) "")))
 444     (delete-file *tmp-filename*)))
 445
 446 (with-test (:name :load-reader-error)
 447   (unwind-protect
 448        (block result
 449          (with-open-file (f *tmp-filename* :direction :output
 450                             :if-does-not-exist :create :if-exists :supersede)
 451            (write-string "(defun fool () (nosuchpackage: " f))
 452          (handler-bind
 453              ((condition
 454                (lambda (e)
 455                  (if (eql (search "READ error during LOAD:"
 456                                   (write-to-string e :escape nil))
 457                           0)
 458                      (return-from result t)
 459                      (error "Unexpectedly erred: ~S" e)))))
 460            (load *tmp-filename* :verbose nil)))
 461     (delete-file *tmp-filename*))
 462   ;; Not really a test of the bugfix, but a reminder that asdf-dependency-grovel
 463   ;; uses this internal macro and that we should endeavor not to break the syntax.
 464   (macroexpand '(sb-c:do-forms-from-info
 465                  ((myform myindex) my-source-info) (something))))