tests/with-compilation-unit.impure.lisp

   1 ;;;; This file is for testing WITH-COMPILATION-UNIT (particularily the
   2 ;;;; suppression of undefined-foo warnings for forward-references).
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 (defvar *file-a* #p"with-compilation-unit-temp-a.lisp")
  16 (defvar *file-b* #p"with-compilation-unit-temp-b.lisp")
  17
  18 (defun test-files (reset &optional want-suppress-p)
  19   (funcall reset)
  20   (assert (eql (raises-error?
  21                 (handler-bind ((warning (lambda (c)
  22                                           (error "got a warning: ~a" c))))
  23                   (with-compilation-unit ()
  24                     (compile-file *file-a*)
  25                     (compile-file *file-b*))))
  26                want-suppress-p))
  27
  28   (funcall reset)
  29   (assert
  30    (raises-error?
  31     (handler-bind ((warning (lambda (c)
  32                               (error "got a warning: ~a" c))))
  33       (compile-file *file-a*)
  34       (compile-file *file-b*))))
  35
  36   (funcall reset)
  37   (assert (eql (raises-error?
  38                 (handler-bind ((warning (lambda (c)
  39                                           (error "got a warning: ~a" c))))
  40                   (with-compilation-unit ()
  41                     (compile-file *file-a*)
  42                     (load (compile-file-pathname *file-b*)))))
  43                want-suppress-p))
  44
  45   (funcall reset)
  46   (assert
  47    (raises-error?
  48     (handler-bind ((warning (lambda (c)
  49                               (error "got a warning: ~a" c))))
  50       (compile-file *file-a*)
  51       (load (compile-file-pathname *file-b*))))))
  52
  53 (with-test (:name (:with-compilation-unit :function))
  54   (with-open-file (stream *file-b* :direction :output
  55 :if-exists :supersede)
  56     (write '(defun foo () 1) :stream stream))
  57   (with-open-file (stream *file-a* :direction :output
  58 :if-exists :supersede)
  59     (write '(defun bar () (foo)) :stream stream))
  60
  61   (test-files (lambda ()
  62                 (fmakunbound 'foo)
  63                 (fmakunbound 'bar))))
  64
  65 (with-test (:name (:with-compilation-unit :generic-function))
  66   (with-open-file (stream *file-b* :direction :output
  67                           :if-exists :supersede)
  68     (write '(defgeneric foo ()) :stream stream)
  69     (write '(defmethod foo () 1) :stream stream))
  70   (with-open-file (stream *file-a* :direction :output
  71                           :if-exists :supersede)
  72     (write '(defmethod bar () (foo)) :stream stream))
  73
  74   (test-files (lambda ()
  75                 (fmakunbound 'foo)
  76                 (fmakunbound 'bar))))
  77
  78 (with-test (:name (:with-compilation-unit :variable))
  79   (with-open-file (stream *file-b* :direction :output
  80                           :if-exists :supersede)
  81     (write `(defvar ,(intern "*A*") nil) :stream stream))
  82   (with-open-file (stream *file-a* :direction :output
  83                           :if-exists :supersede)
  84     (write `(defun bar () ,(intern "*A*")) :stream stream))
  85
  86   (test-files (lambda ()
  87                 (unintern (find-symbol "*A*"))
  88                 (fmakunbound 'bar))
  89               ;; Check that undefined variables are warned for, even
  90               ;; if the variable is defined later in the compilation
  91               ;; unit.
  92               t))
  93
  94 (with-test (:name (:with-compilation-unit :type))
  95   (with-open-file (stream *file-b* :direction :output
  96                           :if-exists :supersede)
  97     (write `(deftype ,(intern "A-TYPE") () 'fixnum) :stream stream))
  98   (with-open-file (stream *file-a* :direction :output
  99                           :if-exists :supersede)
 100     (write `(defun bar () (typep 1 ',(intern "A-TYPE"))) :stream stream))
 101
 102   (test-files (lambda ()
 103                 (unintern 'a-type)
 104                 (fmakunbound 'bar))))
 105
 106 (delete-file *file-a*)
 107 (delete-file *file-b*)
 108