summaryrefslogtreecommitdiffstats
path: root/vet.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /vet.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'vet.scm')
-rw-r--r--vet.scm218
1 files changed, 218 insertions, 0 deletions
diff --git a/vet.scm b/vet.scm
new file mode 100644
index 0000000..56b13cb
--- /dev/null
+++ b/vet.scm
@@ -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))