Import Upstream version 3a1upstream/3a1

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))