;; Copyright 2006-2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
(include "codescanlib.scm")
;; show call paths for named procedure
(define (traceback-proc in-procname)
(letrec* ((all-scm-files (glob "*.scm"))
(xref (get-xref all-scm-files))
(have (alist-ref (string->symbol in-procname) xref eq? #f))
(lookup (lambda (path procname depth)
(let* ((upcone-temp (filter (lambda (x)
(eq? procname (car x)))
xref))
(upcone-temp2 (cond
((null? upcone-temp) '())
(else (cdar upcone-temp))))
(upcone (filter
(lambda (x) (not (eq? x procname)))
upcone-temp2))
(uppath (cons procname path))
(updepth (add1 depth)))
(if (null? upcone)
(print uppath)
(for-each (lambda (x)
(if (not (member procname path))
(lookup uppath x updepth) ))
upcone))))))
(if have
(lookup '() (string->symbol in-procname) 0)
(print "no such func - "in-procname))))
(if (eq? 1 (length (command-line-arguments)))
(traceback-proc (car (command-line-arguments)))
(print "Usage: trackback <procedure name>"))
(exit 0)