/usr/share/slib/vet.scm is in slib 3b1-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 #\space)))
(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 #\space)))
(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 #\space)
(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))
|