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            (let ((filename
 279                   (format nil "~A/~A.lisp"
 280                           (or (posix-getenv "TEST_DIRECTORY")
 281                               (posix-getenv "TMPDIR")
 282                               "/tmp")
 283                           (gensym))))
 284              (ensure-directories-exist filename)
 285              ;; create a file which redefines a structure incompatibly
 286              (with-open-file (f filename :direction :output :if-exists :supersede)
 287                (print '(defstruct bug-332 foo) f)
 288                (print '(defstruct bug-332 foo bar) f))
 289              ;; compile and load the file, then invoke the continue restart on
 290              ;; the structure redefinition error
 291              (handler-bind ((error (lambda (c) (continue c))))
 292                (load (compile-file filename))))))
 293     (stimulate-sbcl)
 294     (stimulate-sbcl)
 295     (stimulate-sbcl)))
 296
 297 (defun load-empty-file (type)
 298   (let ((pathname (make-pathname :name "load-impure-lisp-empty-temp"
 299                                  :type type)))
 300       (unwind-protect
 301            (progn
 302              (with-open-file (f pathname
 303                                 :if-exists :supersede
 304                                 :direction :output))
 305              (handler-case
 306                  (progn (load pathname) t)
 307                (error () nil)))
 308         (ignore-errors (delete-file pathname)))))
 309
 310 (with-test (:name (load :empty.lisp))
 311   (assert (load-empty-file "lisp")))
 312
 313 (with-test (:name (load :empty.fasl))
 314   (assert (not (load-empty-file "fasl"))))
 315
 316 (with-test (:name :parallel-fasl-load)
 317   #+sb-thread
 318   (let ((lisp #p"parallel-fasl-load-test.lisp")
 319         (fasl nil)
 320         (ready nil))
 321     (unwind-protect
 322          (progn
 323            (multiple-value-bind (compiled warned failed)
 324                (compile-file lisp)
 325              (setf fasl compiled)
 326              (assert (not warned))
 327              (assert (not failed))
 328              (labels ((load-loop ()
 329                         (let* ((*standard-output* (make-broadcast-stream))
 330                                (*error-output* *standard-output*))
 331                           (sb-ext:wait-for ready)
 332                           (handler-case
 333                               (progn
 334                                 (loop repeat 1000
 335                                       do (load fasl)
 336                                          (test-it))
 337                                 t)
 338                             (error (e) e))))
 339                       (test-it ()
 340                         (assert (= 1 (one-fun)))
 341                         (assert (= 2 (two-fun)))
 342                         (assert (= 42 (symbol-value '*var*)))
 343                         (assert (= 13 (symbol-value '*quux*)))))
 344                (let ((t1 (sb-thread:make-thread #'load-loop))
 345                      (t2 (sb-thread:make-thread #'load-loop))
 346                      (t3 (sb-thread:make-thread #'load-loop)))
 347                  (setf ready t)
 348                  (let ((r1 (sb-thread:join-thread t1))
 349                        (r2 (sb-thread:join-thread t2))
 350                        (r3 (sb-thread:join-thread t3)))
 351                    (unless (and (eq t r1) (eq t r2) (eq t r3))
 352                      (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
 353                    ;; These ones cannot be tested while redefinitions are running:
 354                    ;; adding a method implies REMOVE-METHOD, so a call would be racy.
 355                    (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
 356                    (assert (eq 'cons (gen-fun '(foo))))
 357                    (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
 358                  (test-it)))))
 359       (when fasl
 360         (ignore-errors (delete-file fasl))))))
 361
 362 (defvar *pack*)
 363 #+sb-simd-pack
 364 (with-test (:name :load-simd-pack-int)
 365   (with-open-file (s *tmp-filename*
 366                      :direction :output
 367                      :if-exists :supersede
 368                      :if-does-not-exist :create)
 369     (print '(setq *pack* (sb-kernel:%make-simd-pack-ub64 2 4)) s))
 370   (let (tmp-fasl)
 371     (unwind-protect
 372          (progn
 373            (setq tmp-fasl (compile-file *tmp-filename*))
 374            (let ((*pack* nil))
 375              (load tmp-fasl)
 376              (assert (typep *pack* '(sb-kernel:simd-pack integer)))
 377              (assert (= 2 (sb-kernel:%simd-pack-low *pack*)))
 378              (assert (= 4 (sb-kernel:%simd-pack-high *pack*)))))
 379       (when tmp-fasl (delete-file tmp-fasl))
 380       (delete-file *tmp-filename*))))
 381
 382 #+sb-simd-pack
 383 (with-test (:name :load-simd-pack-single)
 384   (with-open-file (s *tmp-filename*
 385                      :direction :output
 386                      :if-exists :supersede
 387                      :if-does-not-exist :create)
 388     (print '(setq *pack* (sb-kernel:%make-simd-pack-single 1f0 2f0 3f0 4f0)) s))
 389   (let (tmp-fasl)
 390     (unwind-protect
 391          (progn
 392            (setq tmp-fasl (compile-file *tmp-filename*))
 393            (let ((*pack* nil))
 394              (load tmp-fasl)
 395              (assert (typep *pack* '(sb-kernel:simd-pack single-float)))
 396              (assert (equal (multiple-value-list (sb-kernel:%simd-pack-singles *pack*))
 397                             '(1f0 2f0 3f0 4f0)))))
 398       (when tmp-fasl (delete-file tmp-fasl))
 399       (delete-file *tmp-filename*))))
 400
 401 #+sb-simd-pack
 402 (with-test (:name :load-simd-pack-double)
 403   (with-open-file (s *tmp-filename*
 404                      :direction :output
 405                      :if-exists :supersede
 406                      :if-does-not-exist :create)
 407     (print '(setq *pack* (sb-kernel:%make-simd-pack-double 1d0 2d0)) s))
 408   (let (tmp-fasl)
 409     (unwind-protect
 410          (progn
 411            (setq tmp-fasl (compile-file *tmp-filename*))
 412            (let ((*pack* nil))
 413              (load tmp-fasl)
 414              (assert (typep *pack* '(sb-kernel:simd-pack double-float)))
 415              (assert (equal (multiple-value-list (sb-kernel:%simd-pack-doubles *pack*))
 416                             '(1d0 2d0)))))
 417       (when tmp-fasl (delete-file tmp-fasl))
 418       (delete-file *tmp-filename*))))