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 defclass :slot :type :initform))
  97   (assert-condition-source-paths
  98    (defclass foo () ((x :type string :initform 1)))
  99    (0 3))
 100   (assert-condition-source-paths
 101    (defclass foo () ((x :type string :initform (+ 1 5))))
 102    (4 0 3)))
 103
 104 (with-test (:name (:source-path defclass :slot :type :malformed))
 105   (assert-condition-source-paths
 106    (defclass foo () ((x :type 1)))
 107    (0 3))
 108   (assert-condition-source-paths
 109    (defclass foo () ((x :type (null cons))))
 110    (2 0 3))
 111   (assert-condition-source-paths
 112    (define-condition foo () ((x :type 1)))
 113    (0 3))
 114   (assert-condition-source-paths
 115    (define-condition foo () ((x :type (null cons))))
 116    (2 0 3)))
 117
 118 (with-test (:name (:source-path :&key :initform))
 119   (assert-condition-source-paths
 120    (defun foo (&key (x 15))
 121      (declare (float x))
 122      x)
 123    (1 2))
 124   (assert-condition-source-paths
 125    (defun foo (&key (x /))
 126      (declare (float x))
 127      x)
 128    (1 2))
 129   (assert-condition-source-paths
 130    (defun foo (&key (x (print 16)))
 131      (declare (float x))
 132      x)
 133    (1 1 2)))
 134
 135 (with-test (:name (:source-path :defstruct :initform))
 136   (assert-condition-source-paths
 137    (locally (declare (optimize (safety 0)))
 138     (defstruct f
 139       (x (print t) :type fixnum)))
 140    (1 2 2))
 141   (assert-condition-source-paths
 142    (locally (declare (optimize (safety 0)))
 143      (defstruct f
 144        (x 33 :type cons)))
 145    (2 2))
 146   (assert-condition-source-paths
 147    (locally (declare (optimize (safety 0)))
 148      (defstruct f
 149        (x mm)))
 150    (2 2)))
 151
 152 (with-test (:name (:source-path defgeneric :lambda-list))
 153   (assert-condition-source-paths
 154    (defgeneric foo (x x))
 155    (2)))
 156
 157 (with-test (:name (:source-path defmethod :lambda-list))
 158   (assert-condition-source-paths
 159    (defmethod foo (x x))
 160    (2)))
 161
 162 (defclass deprecated-class () ())
 163 (declaim (deprecated :early "1.0" (type deprecated-class)))
 164 (defgeneric using-deprecated (thing))
 165 (with-test (:name (:source-path defmethod deprecated :specializer))
 166   (assert-condition-source-paths
 167    (defmethod using-deprecated ((thing deprecated-class)))
 168    (0 2)))
 169
 170 (with-test (:name (:source-path defclass deprecated :slot :type))
 171   (assert-condition-source-paths
 172    (defclass foo ()
 173      ((bar :type deprecated-class)))
 174    (0 3))
 175   (assert-condition-source-paths
 176    (define-condition foo ()
 177      ((bar :type deprecated-class)))
 178    (0 3)))
 179
 180 (with-test (:name (:source-path defmethod :walk-body))
 181   (assert-condition-source-paths
 182    (defmethod using-deprecated ((thing t))
 183      (progn (warning-signalling-macro)))
 184    (1 3) (1 3)) ; FIXME duplication is an artifact of DEFMETHOD's implementation
 185   (assert-condition-source-paths
 186    (defmethod using-deprecated ((thing t))
 187      (progn (error-signalling-macro)))
 188    (1 3)))
 189
 190 ;;; In the following two tests, using 1 as the instance avoids
 191 ;;; "undefined variable" noise. The strange "slot names" EVEN and ODD
 192 ;;; stem from that (and would work with WITH-ACCESSORS).
 193
 194 (with-test (:name (:source-path with-slots))
 195   ;; instance sub-form
 196   (assert-condition-source-paths
 197    (with-slots (even) (the integer 1 2))
 198    (2))
 199   ;; slot-entry sub-forms
 200   (assert-condition-source-paths
 201    (with-slots (1) 1)
 202    (1))
 203   (assert-condition-source-paths
 204    (with-slots (()) 1)
 205    (1))
 206   (assert-condition-source-paths
 207    (with-slots ((even)) 1)
 208    (0 1))
 209   (assert-condition-source-paths
 210    (with-slots ((even 1)) 1)
 211    (0 1))
 212   (assert-condition-source-paths
 213    (with-slots ((even even) (odd odd 1)) 1)
 214    (1 1)))
 215
 216 (with-test (:name (:source-path with-accessors))
 217   ;; instance sub-form
 218   (assert-condition-source-paths
 219    (with-accessors ((even evenp)) (the integer 1 2))
 220    (2))
 221   ;; slot-entry sub-forms
 222   (assert-condition-source-paths
 223    (with-accessors (1) 1)
 224    (1))
 225   (assert-condition-source-paths
 226    (with-accessors (()) 1)
 227    (1))
 228   (assert-condition-source-paths
 229    (with-accessors ((even)) 1)
 230    (0 1))
 231   (assert-condition-source-paths
 232    (with-accessors ((even evenp) (odd oddp 1)) 1)
 233    (1 1)))
 234
 235 (with-test (:name (:source-path flet :unused))
 236   (assert-condition-source-paths
 237    (flet ((f ())))
 238    (0 1)))
 239
 240 (with-test (:name (:source-path flet :malformed))
 241   (assert-condition-source-paths
 242    (flet ((f)))
 243    (0 1))
 244   (assert-condition-source-paths
 245    (flet #())
 246    ()))
 247
 248 (with-test (:name (:source-path labels :unused))
 249   (assert-condition-source-paths
 250    (labels ((f ())))
 251    (0 1)))
 252
 253 (with-test (:name (:source-path labels :malformed))
 254   (assert-condition-source-paths
 255    (labels ((f)))
 256    (0 1))
 257   (assert-condition-source-paths
 258    (labels #())
 259    ()))
 260
 261 (with-test (:name (:source-path let :malformed))
 262   (assert-condition-source-paths
 263    (let ((x 1 2)))
 264    (0 1))
 265   (assert-condition-source-paths
 266    (let #())
 267    ()))
 268
 269 (with-test (:name (:source-path let* :malformed))
 270   (assert-condition-source-paths
 271    (let* ((x 1 2)))
 272    (0 1))
 273   (assert-condition-source-paths
 274    (let* #())
 275    ()))
 276
 277 (with-test (:name (:source-path typep :unknown-type-specifier))
 278   (assert-condition-source-paths
 279    (typep 1 'undefined-type)
 280    (2)))
 281
 282 (with-test (:name :dead-code-note-after-transforms)
 283   (assert
 284    (typep (nth-value 4
 285                      (checked-compile
 286                       `(lambda (x)
 287                          (when nil
 288                            (funcall x)))))
 289           '(cons sb-ext:code-deletion-note null))))
 290
 291 (with-test (:name :dead-code-note-after-transforms.2)
 292   (assert
 293    (typep (nth-value 4
 294                      (checked-compile
 295                       `(lambda (a v)
 296                          (declare (vector v))
 297                          (block nil
 298                            (when (integerp a)
 299                              (if (integerp a)
 300                                  (return))
 301                              (length v))))))
 302           '(cons sb-ext:code-deletion-note null))))
 303
 304 (with-test (:name :ignore-deleted-subforms)
 305   (assert-condition-source-paths
 306    (lambda (x m)
 307      (when nil
 308        (funcall x
 309                 (if m
 310                     (print 20)
 311                     (print x)))))
 312    (2 2)))
 313
 314 (with-test (:name :ignore-deleted-subforms.2)
 315   (assert-condition-source-paths
 316    (lambda ()
 317      (when nil
 318        (let ((z (print 10)))
 319          z)))
 320    (2 2)))
 321
 322 (with-test (:name :ignore-deleted-subforms.3)
 323   (assert-condition-source-paths
 324    (lambda (x)
 325      (when x
 326        (unless x
 327          (let ((z (print 10)))
 328            (if z
 329                10
 330                (funcall x))))))
 331    (2 2 2)))
 332
 333 (with-test (:name :ignore-deleted-subforms.4)
 334   (assert-condition-source-paths
 335    (lambda (x)
 336      (when nil
 337        (if (print 10)
 338            10
 339            x)))
 340    (2 2)))
 341
 342 (with-test (:name :dotted-comma-source-paths)
 343   (assert-condition-source-paths
 344    (lambda ()
 345      `(progn
 346         . ,(progn
 347              (progn (setq x 1)))))
 348    (1 1 1 1 2)))