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)))
 123
 124 ;;; In the following two tests, using 1 as the instance avoids
 125 ;;; "undefined variable" noise. The strange "slot names" EVEN and ODD
 126 ;;; stem from that (and would work with WITH-ACCESSORS).
 127
 128 (with-test (:name (:source-path with-slots))
 129   ;; instance sub-form
 130   (assert-condition-source-paths
 131    (with-slots (even) (the integer 1 2))
 132    (2))
 133   ;; slot-entry sub-forms
 134   (assert-condition-source-paths
 135    (with-slots (1) 1)
 136    (1))
 137   (assert-condition-source-paths
 138    (with-slots (()) 1)
 139    (1))
 140   (assert-condition-source-paths
 141    (with-slots ((even)) 1)
 142    (0 1))
 143   (assert-condition-source-paths
 144    (with-slots ((even 1)) 1)
 145    (0 1))
 146   (assert-condition-source-paths
 147    (with-slots ((even even) (odd odd 1)) 1)
 148    (1 1)))
 149
 150 (with-test (:name (:source-path with-accessors))
 151   ;; instance sub-form
 152   (assert-condition-source-paths
 153    (with-accessors ((even evenp)) (the integer 1 2))
 154    (2))
 155   ;; slot-entry sub-forms
 156   (assert-condition-source-paths
 157    (with-accessors (1) 1)
 158    (1))
 159   (assert-condition-source-paths
 160    (with-accessors (()) 1)
 161    (1))
 162   (assert-condition-source-paths
 163    (with-accessors ((even)) 1)
 164    (0 1))
 165   (assert-condition-source-paths
 166    (with-accessors ((even evenp) (odd oddp 1)) 1)
 167    (1 1)))
 168
 169 (with-test (:name (:source-path flet :unused))
 170   (assert-condition-source-paths
 171    (flet ((f ())))
 172    (0 1)))
 173
 174 (with-test (:name (:source-path flet :malformed))
 175   (assert-condition-source-paths
 176    (flet ((f)))
 177    (0 1))
 178   (assert-condition-source-paths
 179    (flet #())
 180    ()))
 181
 182 (with-test (:name (:source-path labels :unused))
 183   (assert-condition-source-paths
 184    (labels ((f ())))
 185    (0 1)))
 186
 187 (with-test (:name (:source-path labels :malformed))
 188   (assert-condition-source-paths
 189    (labels ((f)))
 190    (0 1))
 191   (assert-condition-source-paths
 192    (labels #())
 193    ()))
 194
 195 (with-test (:name (:source-path let :malformed))
 196   (assert-condition-source-paths
 197    (let ((x 1 2)))
 198    (0 1))
 199   (assert-condition-source-paths
 200    (let #())
 201    ()))
 202
 203 (with-test (:name (:source-path let* :malformed))
 204   (assert-condition-source-paths
 205    (let* ((x 1 2)))
 206    (0 1))
 207   (assert-condition-source-paths
 208    (let* #())
 209    ()))