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
219
220
221
222
223
224
|
;"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 display do else
eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt
floor for-each 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-ref list->string list->vector 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? odd? open-input-file
open-output-file or output-port? pair? peek-char positive?
procedure? quasiquote quotient rational? 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-length string-ref string-set! string<=?
string<? string=? string>=? string>? string? sub-vicinity
substring symbol->string symbol? tan truncate unquote
unquote-splicing user-vicinity vector vector->list vector-length
vector-ref vector-set! vector? 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)))
;;@args file1 @dots{}
;;Using the procedures in the @code{top-refs} and @code{manifest}
;;modules, @0 analyzes each SLIB module and @1, @dots{}, 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.
;;
;;The optional arguments @1, @dots{} provide a simple way to vet
;;prospective SLIB modules.
(define (vet-slib . files)
(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))
(let ((catalog
(append (map (lambda (file) (cons (string->symbol file) file))
files)
slib:catalog)))
(for-each (lambda (entry)
(set! export-alist
(cons (cons (car entry)
(feature->exports (car entry) slib:catalog))
export-alist)))
catalog)
(for-each (lambda (entry)
(define path (path<-entry entry))
(and path (dopath path)))
catalog))
(write '("SLIB"))
(show (set-difference infos (union r4rs+slib all-exports))
'documented-unexports))
|
