#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq
;; 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/>.
;;
;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot
;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot
;; dot -Tpdf plot.dot > plot.pdf
;; first param is comma separated list of files to include in the map, use - to do all
;; second param is list of regexs for functions to include in the map
;; third param is list of files to scan
(module plot-uses
*
(import scheme chicken)
(use regex srfi-69 srfi-13)
(use matchable data-structures ports extras)
(define unituses-rx (regexp "^\\(declare \\((unit|uses) ([^\\(\\)]+)\\).*"))
(define (print-err . data)
(with-output-to-port (current-error-port)
(lambda ()
(apply print data))))
(define (process-file ignores fname)
(with-input-from-file fname
(lambda ()
(let loop ((modname "DUMMYMOD"))
(let* ((inl (read-line)))
(if (eof-object? inl)
#t
(match (string-search unituses-rx inl)
((_ dtype unitname)
(if (equal? dtype "unit")
(loop unitname)
(begin
(if (equal? dtype "uses")
(if (not (or (member modname '("DUMMYMOD"))
(member modname ignores)
(member unitname ignores)))
(print " \""unitname"\" -> \""modname"\";"))
(print-err "ERROR: bad declare line \""inl"\""))
(loop modname))))
(else
(loop modname)))))))))
(define (main)
(match (command-line-arguments)
(("todot" ignoreunits . files)
(let* ((ignores (string-split ignoreunits ",")))
(print-err "Making graph for files: " (string-intersperse files ", "))
(print "digraph uses_unit {")
(for-each
(lambda (fname)
(print "// Filename: "fname)
(process-file ignores fname))
files)
(print "}")))
(else
(print-err "Usage: plot-uses u1,u2... file1.scm ...")
(print-err " where u1,u2... are units to ignore and file1.scm... are the files to process."))))
(main)
)
;;
;; ;; Gather the usages
;; (print "digraph G {")
;; (define curr-cluster-num 0)
;; (define function-calls '())
;;
;; (for-each
;; (lambda (fname)
;; (let ((last-func #f))
;; (print-err "Processing file " fname)
;; (print "subgraph cluster_" curr-cluster-num " {")
;; (set! curr-cluster-num (+ curr-cluster-num 1))
;; (with-input-from-file fname
;; (lambda ()
;; (with-output-to-port (current-error-port)
;; (lambda ()
;; (print "Analyzing file " fname)))
;; (print "label=\"" fname "\";")
;; (let loop ((inl (read-line))
;; (fnname "toplevel")
;; (allcalls '()))
;; (if (eof-object? inl)
;; (begin
;; (set! function-calls (cons (list fnname allcalls) function-calls))
;; (for-each
;; (lambda (call-name)
;; (hash-table-set! breadcrumbs call-name #t))
;; allcalls)
;; (print-err "function: " fnname " allcalls: " allcalls))
;; (let ((match (string-match defn-rx inl)))
;; (if match
;; (let ((func-name (cadr match)))
;; (if last-func
;; (print "\"" func-name "\" -> \"" last-func "\";")
;; (print "\"" func-name "\";"))
;; (set! last-func func-name)
;; (hash-table-set! breadcrumbs func-name #t)
;; (loop (read-line)
;; func-name
;; allcalls))
;; (let ((calls (look-for-all-calls inl fnname)))
;; (loop (read-line) fnname (append allcalls calls)))))))))
;; (print "}")))
;; targs)
;;
;; (print-err "breadcrumbs: " (hash-table-keys breadcrumbs))
;; (print-err "function-calls: " function-calls)
;;
;; (for-each
;; (lambda (function-call)
;; (print-err "function-call: " function-call)
;; (let ((fnname (car function-call))
;; (calls (cadr function-call)))
;; (for-each
;; (lambda (callname)
;; (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ")
;; "\"" fnname "\" -> \"" callname "\";"))
;; calls)))
;; function-calls)
;;
;; (print "}")
;;
;; (exit)
;;