;;; -------------------------------------------
;;; Coverage testing

(defun clear-jyacc-coverage ()
  "Clear the coverage test record."
  (maphash #'(lambda (key val)
               (setf (gethash key *jyacc-coverage-ht*) nil))
           *jyacc-coverage-ht*))

(defun report-jyacc-coverage ()
  "Report untested productions."
  (format t "The following productions were not tested:~%")
  (maphash #'(lambda (key val)
               (if (not val)
                   (format t "  ~A~%" key)))
           *jyacc-coverage-ht*))

(defun filter-jyacc-coverage (prod)
  "Rewrite a production seen by Johnson's YACC so that it will mark
   a table when executed."
  (let* ((rprod (reverse prod))
         (aug   (car rprod))
         (prod2 (reverse (cdr rprod))))
    (setf (gethash prod2 *jyacc-coverage-ht*) nil)
    (setf aug
          `(#'(lambda (&rest r)
                (setf (gethash ',prod2 *jyacc-coverage-ht*) t)
                (apply ,aug r))))
    `(,@prod2 ,@aug)))

(defmacro def-jyacc-test (name &rest grammar)
  "Write a coverage tester based on a jyacc grammar (possibly augmented)."
  (setf *jyacc-coverage-ht* (make-hash-table :test #'equal))
  `(let ((parse-fun
          (make-parser
           ',(map 'list #'filter-jyacc-coverage
              (map 'list #'filter-jyacc-production grammar))
           '(,@(jyacc-find-terminals grammar) nil)
           '*eof*)))
    (setf (second parse-fun) ',name)
    (eval parse-fun)
    (compile ',name)))