Megatest

Artifact [a8d79f928b]
Login

Artifact a8d79f928bde0f009e9c875dbbcc065535766a6e:


#!/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)
;;