DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;; 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 .
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
-(define (load-scm-file scm-file)
- ;;(print "load "scm-file)
- (handle-exceptions
- exn
- '()
- (with-input-from-string
- (conc "("
- (with-input-from-file scm-file read-all)
- ")" )
- read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;; -- be advised:
-;; * this may be fooled by macros, since this code does not take them into account.
-;; * this code does only checks for form (define ( ... ) )
-;; so it excludes from reckoning
-;; - generated functions, as in things like foo-set! from defstructs,
-;; - define-inline, (
-;; - define procname (lambda ..
-;; - etc...
-(define (get-toplevel-procs+file+args+body filename)
- (let* ((scm-tree (load-scm-file filename))
- (procs
- (filter identity
- (map
- (match-lambda
- [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
- [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
- [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
- [('define (defname args ...) body ...) ;; match (define (procname ) )
- (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
- (list defname filename args body)
- #f)]
- [else #f] ) scm-tree))))
- procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
- (cond
- ((null? body) '())
- ((atom? body) (list body))
- (else
- (apply append (map get-atoms-in-body body)))))
-
-;; given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
- (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
- (res
- (map
- (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (args (caddr item))
- (body (cadddr item))
- (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
- (list proc file atoms)))
- toplevel-proc-items)))
- res))
-
-;; uniquify a list of atoms
-(define (unique-atoms lst)
- (let loop ((lst (flatten lst)) (res '()))
- (if (null? lst)
- (reverse res)
- (let ((c (car lst)))
- (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
- (let* ((all-procs (map car all-procs+file+calls))
- (caller-ht (make-hash-table)))
- ;; let's cross reference with a hash table
- (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
- (for-each (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (calls (caddr item)))
- (for-each (lambda (callee)
- (hash-table-set! caller-ht callee
- (cons proc
- (hash-table-ref caller-ht callee))))
- calls)))
- all-procs+file+calls)
- (map (lambda (x)
- (let ((k (car x))
- (r (unique-atoms (cdr x))))
- (cons k r)))
- (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
- (let* ((all-procs+file+atoms
- (apply append (map get-procs+file+atoms all-scm-files)))
- (all-procs (map car all-procs+file+atoms))
- (all-procs+file+calls ; proc calls things in calls list
- (map (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (atoms (caddr item))
- (calls
- (filter identity
- (map
- (lambda (x)
- (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
- (member x all-procs))
- x
- #f))
- atoms))))
- (list proc file calls)))
- all-procs+file+atoms))
- (callers (get-callers-alist all-procs+file+calls)))
- callers))
DELETED trackback.scm
Index: trackback.scm
==================================================================
--- trackback.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;; 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 .
-
-(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 "))
-
-(exit 0)
-
ADDED utils/codescanlib.scm
Index: utils/codescanlib.scm
==================================================================
--- /dev/null
+++ utils/codescanlib.scm
@@ -0,0 +1,144 @@
+;; 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 .
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define ( ... ) )
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname ) )
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
ADDED utils/gendeps.scm
Index: utils/gendeps.scm
==================================================================
--- /dev/null
+++ utils/gendeps.scm
@@ -0,0 +1,89 @@
+;; (require-library iup canvas-draw)
+
+;; It'd be better to use codescan....
+
+(module gendeps
+ *
+
+(import
+ scheme
+ chicken.base
+ chicken.string
+ chicken.process-context
+ chicken.file
+ chicken.io
+ chicken.port
+ scheme
+ ;;extras
+ regex
+ regex-case
+ matchable
+ srfi-69
+ )
+
+(define (portprint p . args)
+ (with-output-to-port p
+ (lambda ()
+ (apply print args))))
+
+(define (compunit targfname files)
+ (let* ((unitdata (make-hash-table))
+ (moduledata (make-hash-table))
+ (filesdata (make-hash-table))
+ (unitdec (regexp "^\\(declare\\s+\\(unit\\s+([^\\s]+)\\)\\)"))
+ (unituse (regexp "^\\(declare\\s+\\(uses\\s+([^\\s]+)\\)\\)"))
+ (moduledec (regexp "^\\(module\\s+([\\s]+)"))
+ (importuse (regexp "^\\(import\\s+(.*)\\)")) ;; captures string of imports (one line)
+ (dotport (open-output-file (conc targfname ".dot")))
+ (incport (open-output-file (conc targfname ".inc")))
+ )
+ (portprint dotport "digraph usedeps {")
+ (for-each
+ (lambda (fname)
+ (let* ((sname (string-substitute "\\.scm$" "" fname)))
+ (print "Processing "fname" with core name of "sname)
+ (hash-table-set! filesdata sname fname) ;; record the existance of the src file
+ (with-input-from-file fname
+ (lambda ()
+ (let loop ((inl (read-line)))
+ (if (not (eof-object? inl))
+ (begin
+ (regex-case
+ inl
+ (unitdec (_ unitname)
+ (if (equal? sname unitname) ;; good if same
+ (if (not (hash-table-exists? unitdata unitname))
+ (hash-table-set! unitdata unitname (make-hash-table)))))
+ (unituse (_ usingname)
+ (portprint dotport "\""sname"\" -> \""usingname"\"")
+ (portprint incport sname".scm : "usingname".scm"))
+ ;; (moduledec (_ modname) (print "Module: " modname))
+ ;; (importuse (_ importname) (print "Imports: " importname))
+ (else #f))
+ (loop (read-line)))))))))
+ files)
+ (portprint dotport "}")
+ (close-output-port dotport)
+ (close-output-port incport)))
+
+;; seen is hash of seen functions
+
+(define usage "Usage: gendeps targfile files...
+")
+
+(define (main)
+ (match
+ (command-line-arguments)
+ (("help")(print usage))
+ ((targfile . files)
+ (compunit targfile files))
+ (else
+ (print "ERROR: Arguments not recognised.")
+ (print usage))))
+)
+
+(import
+ ;; (only iup show main-loop)
+ gendeps)
+
+(main)
ADDED utils/trackback.scm
Index: utils/trackback.scm
==================================================================
--- /dev/null
+++ utils/trackback.scm
@@ -0,0 +1,53 @@
+;; 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 .
+
+(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 "))
+
+(exit 0)
+