Overview
| Comment: | code to show dangling procedures not called by anything |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.64 |
| Files: | files | file ages | folders |
| SHA1: |
ebe475c9e4b7bce473922230854814a7 |
| User & Date: | bjbarcla on 2017-08-15 18:48:45 |
| Other Links: | branch diff | manifest | tags |
Context
|
2017-08-16
| ||
| 00:00 | cleanup show-uncalled-procedures.scm check-in: 16fd8f0a83 user: bb tags: v1.64 | |
|
2017-08-15
| ||
| 18:48 | code to show dangling procedures not called by anything check-in: ebe475c9e4 user: bjbarcla tags: v1.64 | |
| 16:33 | added get-config-settings.sh to query what tweakable global config settings exist check-in: f77b04e570 user: bjbarcla tags: v1.64 | |
Changes
Added show-uncalled-procedures.scm version [4b6bc7988a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
#!/p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csi -s
(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)
(define (load-scm-file scm-file)
;;(print "load "scm-file)
(handle-exceptions
exn
(begin
;;(print " - problem with "scm-file"; skip it.")
'())
(with-input-from-string (conc "(" (with-input-from-file scm-file read-all) ")" ) read)))
(define (get-toplevel-procs+file+args+body filename)
(let* ((scm-tree (load-scm-file filename))
(procs
(filter identity
(map (lambda (x)
(match x
[(define ('uses args ...) body ...) #f]
[(define ('unit args ...) body ...) #f]
[(define ('prefix args ...) body ...) #f]
[(define (defname args ...) body ...)
(if (atom? defname)
(list defname filename args body)
#f)]
[else #f] )) scm-tree)))
)
procs))
(define (get-atoms-in-body body)
(cond
((null? body) '())
((atom? body) (list body))
(else
(apply append (map get-atoms-in-body body)))))
(define (get-procs+file+atoms file)
(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)))
(get-toplevel-procs+file+args+body file)))
(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)))))))
(define (get-callers-alist all-procs+file+calls)
(let* ((all-procs (map car all-procs+file+calls))
(caller-ht (make-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)
;(print "callee: "callee)
;(exit 1)
(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))))
(let* ((all-scm-files (glob "*.scm"))
(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))
(singletons (filter (lambda (x) (equal? 1 (length x))) callers))
)
(pp singletons))
|