Megatest

Check-in [16fd8f0a83]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:cleanup show-uncalled-procedures.scm
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64
Files: files | file ages | folders
SHA1: 16fd8f0a8394bde80157a2a1f3c5f7c2a00cf3da
User & Date: bb on 2017-08-16 00:00:20
Other Links: branch diff | manifest | tags
Context
2017-08-16
01:24
add util to trackback procedure calls check-in: fc5bec0c9f user: bb tags: v1.64
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
Changes
Hide Diffs Unified Diffs Show Whitespace Changes Patch

Modified show-uncalled-procedures.scm from [4b6bc7988a] to [0604c01fa9]. 










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










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

>
>
>
>
>
>
>
>
>
|
>









>
>




<
<
|
>
>
|
>
>

>

<



|
|
|
|
|
|
|


|
<


>
>







>

>
>








|
>

>







>
>



>






<
<











|
|
|








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
115

;; 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 (<procname> ... ) <body>)
;;           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 (<procname> <args>) <body> )
(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 <args>) <body>)
                     (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
︙︙
103
104
105
106
107
108
109
110






111

112
113
114

                                  (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))








|
>
>
>
>
>
>
|
>
|

|

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

                                  (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 (main)
  (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.
    ))
  
(main)

This page was generated in about 0.116s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00