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