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