tests/error-source-path.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 \f
  13 ;;; Utilities
  14
  15 (defmacro assert-condition-source-paths (form &rest source-paths)
  16   `(assert (equal (checked-compile-condition-source-paths
  17                    '(lambda () ,form))
  18                   (mapcar (lambda (path)
  19                             (append path '(2 0)))
  20                           '(,@source-paths)))))
  21
  22 (defmacro warning-signalling-macro (&body body)
  23   (warn "warning from macro")
  24   `(progn ,@body))
  25
  26 (defmacro error-signalling-macro (&body body)
  27   (declare (ignore body))
  28   (error "error from macro"))
  29
  30 \f
  31 ;;; Tests
  32
  33 (with-test (:name (:source-path multiple-value-bind))
  34   (assert-condition-source-paths
  35    (multiple-value-bind (1 2) (list 1 2))
  36    (1)))
  37
  38 (with-test (:name (:source-path multiple-value-setq))
  39   (assert-condition-source-paths
  40    (multiple-value-setq (1 2) (list 1 2))
  41    (1)))
  42
  43 (with-test (:name (:source-path cond))
  44   (assert-condition-source-paths (cond 1) (1))
  45   (assert-condition-source-paths (cond #()) (1))
  46   (assert-condition-source-paths (cond "foo") (1))
  47   (assert-condition-source-paths (cond (t t) 1) (2)))
  48
  49 (with-test (:name (:source-path do))
  50   (assert-condition-source-paths (do () 1) ())
  51   (assert-condition-source-paths (do 1 (t)) ()) ; should be improved
  52   (assert-condition-source-paths (do (1) (t)) (1))
  53   (assert-condition-source-paths (do (x (1)) (t)) (1 1)))
  54
  55 (with-test (:name (:source-path do*))
  56   (assert-condition-source-paths (do* () 1) ())
  57   (assert-condition-source-paths (do* 1 (t)) ()) ; should be improved
  58   (assert-condition-source-paths (do* (1) (t)) (1))
  59   (assert-condition-source-paths (do* (x (1)) (t)) (1 1)))
  60
  61 (with-test (:name (:source-path dolist))
  62   (assert-condition-source-paths (dolist (x (1 . 2))) (1 1)))
  63
  64 (with-test (:name (:source-path restart-bind))
  65   (assert-condition-source-paths (restart-bind ((continue (lambda ()) 1))) (0 1))
  66   (assert-condition-source-paths (restart-bind ((nil (lambda ()) 1))) (0 1)))
  67
  68 (with-test (:name (:source-path restart-case))
  69   (assert-condition-source-paths (restart-case 1 (1)) (2))
  70   (assert-condition-source-paths (restart-case 1 (continue 1)) (2)))
  71
  72 (with-test (:name (:source-path handler-bind))
  73   (assert-condition-source-paths (handler-bind (1)) (1))
  74   (assert-condition-source-paths
  75    (handler-bind ((error (lambda (c) (declare (ignore c))) 1)))
  76    (0 1))
  77
  78   ;; Not sure what's going on with this one.
  79   #+nil (assert-condition-source-paths
  80    (handler-bind ((no-such-type #'continue)))
  81    (0 1)))
  82
  83 (with-test (:name (:source-path handler-case))
  84   (assert-condition-source-paths (handler-case 1 (error)) (2)))
  85
  86 (with-test (:name (:source-path case))
  87   (assert-condition-source-paths (case 1 1) (2))
  88   (assert-condition-source-paths (case 1 (a :a) 1) (3))
  89   (assert-condition-source-paths (case 1 (a :a) (a :b)) (3))
  90   (assert-condition-source-paths (case 1 (t :a) (b :b)) (2)))
  91
  92 (with-test (:name (:source-path declare))
  93   (assert-condition-source-paths (declare (1)) (1))
  94   (assert-condition-source-paths (declare (type integer) (1)) (2)))
  95
  96 (with-test (:name (:source-path defgeneric :lambda-list))
  97   (assert-condition-source-paths
  98    (defgeneric foo (x x))
  99    (2)))
 100
 101 (with-test (:name (:source-path defmethod :lambda-list))
 102   (assert-condition-source-paths
 103    (defmethod foo (x x))
 104    (2)))
 105
 106 (defclass deprecated-class () ())
 107 (declaim (deprecated :early "1.0" (type deprecated-class)))
 108 (defgeneric using-deprecated (thing))
 109 (with-test (:name (:source-path defmethod deprecated :specializer))
 110   (assert-condition-source-paths
 111    (defmethod using-deprecated ((thing deprecated-class)))
 112    (0 2)))
 113
 114 (with-test (:name (:source-path defmethod :walk-body))
 115   (assert-condition-source-paths
 116    (defmethod using-deprecated ((thing t))
 117      (progn (warning-signalling-macro)))
 118    (1 3) (1 3)) ; FIXME duplication is an artifact of DEFMETHOD's implementation
 119   (assert-condition-source-paths
 120    (defmethod using-deprecated ((thing t))
 121      (progn (error-signalling-macro)))
 122    (1 3)))