tests/fopcompiler.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 ;;; These tests don't need to be processed by the compiler before
  13 ;;; being executed, in fact mustn't go in "fopcompiler.impure-cload.lisp"
  14 ;;; because the call to COMPILE-FILE needs to be wrapped in HANDLER-BIND.
  15
  16 (defvar *tmp-filename* "fopcompile-test.tmp")
  17
  18 ;; Assert that FORM is handled by the fopcompiler, then compile it.
  19 (defun assert-fopcompilable-and-compile-it (form)
  20   ;; Since FOPCOMPILABLE-P now expands compiler-macros, and the macro for
  21   ;; SOURCE-LOCATION expands to a literal structure, we end up calling
  22   ;; CONSTANT-FOPCOMPILABLE-P which needs *COMPILE-OBJECT* to be bound.
  23   (let ((sb-c::*compile-object*
  24          (sb-fasl::make-fasl-output :stream (make-broadcast-stream)))
  25         (sb-c::*lexenv* (sb-kernel:make-null-lexenv)))
  26     (assert (sb-c::fopcompilable-p form))
  27     (with-open-file (stream *tmp-filename*
  28                             :direction :output :if-exists :supersede)
  29       (prin1 form stream))
  30     (let (warning)
  31       (handler-bind ((warning
  32                       (lambda (c)
  33                         (when (null warning)
  34                           (setq warning c)
  35                           (muffle-warning)))))
  36         (multiple-value-bind (output warningp errorp)
  37             (compile-file *tmp-filename*)
  38           (when output
  39             (delete-file output))
  40           (if (and (not warningp) (not errorp))
  41               ;; return muffled warning, which didn't count as a warning
  42               warning))))))
  43
  44 ;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE.
  45 (with-test (:name :fopcompiler-undefined-warning)
  46   ;; Make sure some wiseacre didn't defconstant *FOO*
  47   (assert (eq (sb-int:info :variable :kind '*foo*) :unknown))
  48   ;; ... or define the I-DO-NOT-EXIST function.
  49   (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed))
  50   (let ((w (assert-fopcompilable-and-compile-it
  51             '(defvar *foo* (i-do-not-exist)))))
  52     (assert (and (typep w 'sb-int:simple-style-warning)
  53                  (eql (search "undefined"
  54                               (simple-condition-format-control w)) 0)))))
  55
  56 ;; Ensure that FOPCOMPILE warns about deprecated variables.
  57 (with-test (:name :fopcompiler-deprecated-var-warning)
  58   (assert (typep (assert-fopcompilable-and-compile-it
  59                   '(defvar *frob* (if *SHOW-ENTRY-POINT-DETAILS* 'yes 'no)))
  60                  'sb-ext:deprecation-condition)))
  61
  62 (ignore-errors (delete-file *tmp-filename*))