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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
;"vet.scm" Check exports, references, and documentation of library modules.
;Copyright (C) 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;@code{(require 'vet)}
;;@ftindex vet
(require 'common-list-functions)
(require 'top-refs)
(require 'manifest)
(define r4rs-symbols
'(* + - -> / < <= = => > >= ... abs acos and angle append apply asin
assoc assq assv atan begin boolean? caaaar caaadr caaar caadar caaddr
caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
call-with-current-continuation call-with-input-file
call-with-output-file car case cdaaar cdaadr cdaar cdadar cdaddr cdadr
cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling
char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=?
char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric?
char-ready? char-upcase char-upper-case? char-whitespace? char<=?
char<? char=? char>=? char>? char? close-input-port
close-output-port complex? cond cons cos current-input-port
current-output-port define denominator display do else eof-object?
eq? equal? eqv? even? exact->inexact exact? exp expt floor
for-each force gcd if imag-part implementation-vicinity in-vicinity
inexact->exact inexact? input-port? integer->char integer? lambda
lcm length let let* letrec library-vicinity list list->string
list->vector list-ref list-tail list? load log magnitude make-polar
make-rectangular make-string make-vector make-vicinity map max member
memq memv min modulo negative? newline not null? number->string
number? numerator odd? open-input-file open-output-file or
output-port? pair? peek-char positive? procedure? quasiquote
quotient rational? rationalize read read-char real-part real?
remainder reverse round set! set-car! set-cdr! sin sqrt string
string->list string->number string->symbol string-append string-ci<=?
string-ci<? string-ci=? string-ci>=? string-ci>? string-copy
string-fill! string-length string-ref string-set! string<=?
string<? string=? string>=? string>? string? sub-vicinity
substring symbol->string symbol? tan transcript-off transcript-on
truncate unquote unquote-splicing user-vicinity vector vector->list
vector-fill! vector-length vector-ref vector-set! vector?
with-input-from-file with-output-to-file write write-char zero? ))
(define (path<-entry entry)
(define (findit path)
(cond ((not (string? path)) #f)
((file-exists? path) path)
((file-exists? (string-append path ".scm"))
(string-append path ".scm"))
(else #f)))
(cond ((string? (cdr entry)) (findit (cdr entry)))
((not (pair? (cdr entry))) #f)
(else (case (cadr entry)
((source defmacro macro syntactic-closures
syntax-case macros-that-work)
(let ((lp (last-pair entry)))
(or (and (string? (car lp)) (findit (car lp)))
(and (string? (cdr lp)) (findit (cdr lp))))))
(else #f)))))
(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*)))
(define (top-refs<-files filenames)
(remove-duplicates (apply append (map top-refs<-file filenames))))
(define (provided+? . features)
(lambda (feature)
(or (memq feature features) (provided? feature))))
(define (requires<-file filename)
(file->requires filename (provided+? 'compiling) slib:catalog))
(define (requires<-files filenames)
(remove-duplicates (apply append (map requires<-file filenames))))
(define (definitions<-files filenames)
(remove-duplicates (apply append (map file->definitions filenames))))
(define (exports<-files filenames)
(remove-duplicates (apply append (map file->exports filenames))))
(define (code-walk-justify lst . margins)
(define left-margin (case (length margins)
((1 2 3) (car margins))
((0) 0)
(else (slib:error 'code-walk-justify 'wna margins))))
(define right-margin (case (length margins)
((2 3) (cadr margins))
(else (output-port-width))))
(define spacer (case (length margins)
((3) (caddr margins))
(else #\ )))
(cond ((>= left-margin right-margin)
(slib:error 'code-walk-justify
" left margin must be smaller than right: "
margins)))
(let ((cur left-margin)
(lms (make-string left-margin #\ )))
(display lms)
(for-each
(lambda (obj)
(if (symbol? obj) (set! obj (symbol->string obj)))
(let ((objl (string-length obj)))
(cond ((= left-margin cur)
(display obj)
(set! cur (+ objl cur)))
((<= right-margin (+ 1 objl cur))
(newline)
(set! cur (+ objl left-margin))
(display lms) (display obj))
(else
(display #\ )
(display obj)
(set! cur (+ 1 objl cur))))))
lst)))
;;@body
;;Using the procedures in the @code{top-refs} and @code{manifest}
;;modules, @0 analyzes each SLIB module, reporting about any
;;procedure or macro defined whether it is:
;;
;;@table @asis
;;
;;@item orphaned
;;defined, not called, not exported;
;;@item missing
;;called, not defined, and not exported by its @code{require}d modules;
;;@item undocumented-export
;;Exported by module, but no index entry in @file{slib.info};
;;
;;@end table
;;
;;And for the library as a whole:
;;
;;@table @asis
;;
;;@item documented-unexport
;;Index entry in @file{slib.info}, but no module exports it.
;;
;;@end table
;;
;;This straightforward analysis caught three full days worth of
;;never-executed branches, transitive require assumptions, spelling
;;errors, undocumented procedures, missing procedures, and cyclic
;;dependencies in SLIB.
(define (vet-slib)
(define infos
(exports<-info-index (in-vicinity (library-vicinity) "slib.info") 1 2))
(define r4rs+slib #f)
(define export-alist '())
(define all-exports '())
(define slib-exports
(union '(system getenv current-time difftime offset-time)
(union (file->exports
(in-vicinity (library-vicinity) "Template.scm"))
(file->exports
(in-vicinity (library-vicinity) "require.scm")))))
(define (show lst name)
(cond ((not (null? lst))
(display " ") (display name) (display ":") (newline)
(code-walk-justify lst 10)
(newline))))
(define (dopath path)
(define paths (cons path (file->loads path)))
(let ((requires (requires<-files paths))
(defines (definitions<-files paths))
(exports (exports<-files paths))
(top-refs (top-refs<-files paths)))
(define orphans (set-difference (set-difference defines exports)
top-refs))
(define missings (set-difference
(set-difference top-refs defines)
r4rs+slib))
(set! all-exports (union exports all-exports))
(for-each (lambda (req)
(define pr (assq req export-alist))
(and pr (set! missings (set-difference missings (cdr pr)))))
requires)
(let ((undocs (set-difference exports (union r4rs-symbols infos))))
(cond ((not (every null? (list undocs orphans missings)))
(write paths) (newline)
;;(show requires 'requires)
;;(show defines 'defines)
;;(show exports 'exports)
(show undocs 'undocumented-exports)
(show orphans 'orphans)
(show missings 'missing)
)))))
(set! r4rs+slib (union r4rs-symbols slib-exports))
(for-each (lambda (entry)
(set! export-alist
(cons (cons (car entry)
(feature->exports (car entry) slib:catalog))
export-alist)))
slib:catalog)
(for-each (lambda (entry)
(define path (path<-entry entry))
(and path (dopath path)))
slib:catalog)
(write '("SLIB"))
(show (set-difference infos (union r4rs+slib all-exports))
'documented-unexports))
|
