ADDED codescanlib.scm Index: codescanlib.scm ================================================================== --- /dev/null +++ codescanlib.scm @@ -0,0 +1,127 @@ + +;; 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 lost 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)) Index: show-uncalled-procedures.scm ================================================================== --- show-uncalled-procedures.scm +++ show-uncalled-procedures.scm @@ -1,157 +1,13 @@ -;; this code will read scm files from $PWD and return a list of defined procedures that are not called by any other procedures -;; -- 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... - -;; 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 -(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 lost 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)))) - -;; read all scm files in cwd, pretty print a list of procs that are not called -(define (get-xref all-scm-files) - (let* ((all-procs+file+atoms - (apply append (map get-procs+file+atoms all-scm-files))) - ;(foo (begin - ; (pp all-procs+file+atoms) - ; (exit 1))) - (all-procs (map car all-procs+file+atoms)) - ;(bar (begin (pp all-procs) (exit 1))) - (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))) ;; this is a handy cross-reference of callees to callers. could be used elsewhere - callers)) +(include "codescanlib.scm") (define (show-danglers) (let* ((all-scm-files (glob "*.scm")) (xref (get-xref all-scm-files)) (dangling-procs (map car (filter (lambda (x) (equal? 1 (length x))) xref)))) (for-each print dangling-procs) ;; our product. )) -(define (traceback-proc procname) - (let* ((all-scm-files (glob "*.scm")) - (xref (get-xref all-scm-files)) - (lookup (lambda (path procname depth) - (let* ((upcone (alist-ref procname xref equal? '())) - (uppath (conc procname "/" path)) - (updepth (add1 depth))) - (if (null? upcode) (print uppath)) - (for-each (lambda (x) - (lookup uppath x updepth) ) - upcone))))) - (lookup "." procname 0))) - (show-danglers) Index: trackback.scm ================================================================== --- trackback.scm +++ trackback.scm @@ -1,146 +1,8 @@ -;; this code will, given a procname, show code paths to call this procname -;; -- 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... - -;; 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 -(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 lost 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)))) - -;; read all scm files in cwd, pretty print a list of procs that are not called -(define (get-xref all-scm-files) - (let* ((all-procs+file+atoms - (apply append (map get-procs+file+atoms all-scm-files))) - ;(foo (begin - ; (pp all-procs+file+atoms) - ; (exit 1))) - (all-procs (map car all-procs+file+atoms)) - ;(bar (begin (pp all-procs) (exit 1))) - (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))) ;; this is a handy cross-reference of callees to callers. could be used elsewhere - callers)) - -(define (show-danglers) - (let* ((all-scm-files (glob "*.scm")) - (xref (get-xref all-scm-files)) - (dangling-procs - (map car (filter (lambda (x) (equal? 1 (length x))) xref)))) - (for-each print dangling-procs) ;; our product. - )) - +(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)