;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.


;;; Utilities

(defmacro assert-condition-source-paths (form &rest source-paths)
  `(assert (equal (checked-compile-condition-source-paths
                   '(lambda () ,form))
                  (mapcar (lambda (path)
                            (append path '(2 0)))
                          '(,@source-paths)))))

(defmacro warning-signalling-macro (&body body)
  (warn "warning from macro")
  `(progn ,@body))

(defmacro error-signalling-macro (&body body)
  (declare (ignore body))
  (error "error from macro"))


;;; Tests

(with-test (:name (:source-path multiple-value-bind))
  (assert-condition-source-paths
   (multiple-value-bind (1 2) (list 1 2))
   (1)))

(with-test (:name (:source-path multiple-value-setq))
  (assert-condition-source-paths
   (multiple-value-setq (1 2) (list 1 2))
   (1)))

(with-test (:name (:source-path cond))
  (assert-condition-source-paths (cond 1) (1))
  (assert-condition-source-paths (cond #()) (1))
  (assert-condition-source-paths (cond "foo") (1))
  (assert-condition-source-paths (cond (t t) 1) (2)))

(with-test (:name (:source-path do))
  (assert-condition-source-paths (do () 1) ())
  (assert-condition-source-paths (do 1 (t)) ()) ; should be improved
  (assert-condition-source-paths (do (1) (t)) (1))
  (assert-condition-source-paths (do (x (1)) (t)) (1 1)))

(with-test (:name (:source-path do*))
  (assert-condition-source-paths (do* () 1) ())
  (assert-condition-source-paths (do* 1 (t)) ()) ; should be improved
  (assert-condition-source-paths (do* (1) (t)) (1))
  (assert-condition-source-paths (do* (x (1)) (t)) (1 1)))

(with-test (:name (:source-path dolist))
  (assert-condition-source-paths (dolist (x (1 . 2))) (1 1)))

(with-test (:name (:source-path restart-bind))
  (assert-condition-source-paths (restart-bind ((continue (lambda ()) 1))) (0 1))
  (assert-condition-source-paths (restart-bind ((nil (lambda ()) 1))) (0 1)))

(with-test (:name (:source-path restart-case))
  (assert-condition-source-paths (restart-case 1 (1)) (2))
  (assert-condition-source-paths (restart-case 1 (continue 1)) (2)))

(with-test (:name (:source-path handler-bind))
  (assert-condition-source-paths (handler-bind (1)) (1))
  (assert-condition-source-paths
   (handler-bind ((error (lambda (c) (declare (ignore c))) 1)))
   (0 1))

  ;; Not sure what's going on with this one.
  #+nil (assert-condition-source-paths
   (handler-bind ((no-such-type #'continue)))
   (0 1)))

(with-test (:name (:source-path handler-case))
  (assert-condition-source-paths (handler-case 1 (error)) (2)))

(with-test (:name (:source-path case))
  (assert-condition-source-paths (case 1 1) (2))
  (assert-condition-source-paths (case 1 (a :a) 1) (3))
  (assert-condition-source-paths (case 1 (a :a) (a :b)) (3))
  (assert-condition-source-paths (case 1 (t :a) (b :b)) (2)))

(with-test (:name (:source-path declare))
  (assert-condition-source-paths (declare (1)) (1))
  (assert-condition-source-paths (declare (type integer) (1)) (2)))

(defclass deprecated-class () ())
(declaim (deprecated :early "1.0" (type deprecated-class)))
(defgeneric using-deprecated (thing))
(with-test (:name (:source-path defmethod deprecated :specializer))
  (assert-condition-source-paths
   (defmethod using-deprecated ((thing deprecated-class)))
   (0 2)))

(with-test (:name (:source-path defmethod :walk-body))
  (assert-condition-source-paths
   (defmethod using-deprecated ((thing t))
     (progn (warning-signalling-macro)))
   (1 3) (1 3)) ; FIXME duplication is an artifact of DEFMETHOD's implementation
  (assert-condition-source-paths
   (defmethod using-deprecated ((thing t))
     (progn (error-signalling-macro)))
   (1 3)))
