diff options
Diffstat (limited to 'vet.scm')
| -rw-r--r-- | vet.scm | 218 |
1 files changed, 218 insertions, 0 deletions
@@ -0,0 +1,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)) |