summaryrefslogtreecommitdiffstats
path: root/top-refs.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 /top-refs.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'top-refs.scm')
-rw-r--r--top-refs.scm285
1 files changed, 285 insertions, 0 deletions
diff --git a/top-refs.scm b/top-refs.scm
new file mode 100644
index 0000000..29e25dc
--- /dev/null
+++ b/top-refs.scm
@@ -0,0 +1,285 @@
+;"top-refs.scm" List Scheme code's top-level variable references.
+;Copyright (C) 1995, 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.
+
+(require 'fluid-let)
+(require 'line-i/o) ; exports<-info-index uses
+(require 'string-case) ; exports<-info-index uses
+(require 'string-search) ; exports<-info-index uses
+(require 'manifest) ; load->path
+
+;;@code{(require 'top-refs)}
+;;@ftindex top-refs
+;;@cindex top-level variable references
+;;@cindex variable references
+;;
+;;@noindent
+;;These procedures complement those in @ref{Module Manifests} by
+;;finding the top-level variable references in Scheme source code.
+;;They work by traversing expressions and definitions, keeping track
+;;of bindings encountered. It is certainly possible to foil these
+;;functions, but they return useful information about SLIB source
+;;code.
+
+(define *references* '())
+(define *bindings* '())
+
+(define (top-refs:warn proc msg . more)
+ (for-each display (list "WARN:" proc ": " msg " "))
+ (for-each (lambda (x) (write x) (display #\ ))
+ more)
+ (newline))
+;;@body
+;;Returns a list of the top-level variables referenced by the Scheme
+;;expression @1.
+(define (top-refs obj)
+ (fluid-let ((*references* '()))
+ (if (string? obj)
+ (top-refs:include obj)
+ (top-refs:top-level obj))
+ *references*))
+;;@body
+;;@1 should be a string naming an existing file containing Scheme
+;;source code. @0 returns a list of the top-level variable references
+;;made by expressions in the file named by @1.
+;;
+;;Code in modules which @1 @code{require}s is not traversed. Code in
+;;files loaded from top-level @emph{is} traversed if the expression
+;;argument to @code{load}, @code{slib:load}, @code{slib:load-source},
+;;@code{macro:load}, @code{defmacro:load}, @code{synclo:load},
+;;@code{syncase:load}, or @code{macwork:load} is a literal string
+;;constant or composed of combinations of vicinity functions and
+;;string literal constants; and the resulting file exists (possibly
+;;with ".scm" appended).
+(define (top-refs<-file filename)
+ (fluid-let ((*references* '()))
+ (top-refs:include filename)
+ *references*))
+
+(define (top-refs:include filename)
+ (cond ((not (and (string? filename) (file-exists? filename)))
+ (top-refs:warn 'top-refs:include 'skipping filename))
+ (else (fluid-let ((*load-pathname* filename))
+ (call-with-input-file filename
+ (lambda (port)
+ (do ((exp (read port) (read port)))
+ ((eof-object? exp))
+ (top-refs:top-level exp))))))))
+
+(define (top-refs:top-level exp)
+ (cond ((not (and (pair? exp) (list? exp)))
+ (top-refs:warn 'top-refs "non-list at top level?" exp))
+ ((not (symbol? (car exp))) (top-refs:expression exp))
+ (else
+ (case (car exp)
+ ((begin) (for-each top-refs:top-level (cdr exp)))
+ ((cond) (for-each (lambda (clause)
+ (for-each top-refs:top-level clause))
+ (cdr exp)))
+ ((if) (for-each top-refs:top-level
+ (if (list? (cadr exp)) (cdr exp) (cddr exp))))
+ ((define define-operation)
+ ;;(display "; walking ") (write (cadr exp)) (newline)
+ (top-refs:binding (cadr exp) (cddr exp)))
+ ((define-syntax)
+ (top-refs:binding (cadr exp) (cddr exp)))
+ ((defmacro)
+ ;;(display "; malking ") (write (cadr exp)) (newline)
+ (if (pair? (cadr exp))
+ (top-refs:binding (cdadr exp) (cddr exp))
+ (top-refs:binding (caddr exp) (cdddr exp))))
+ ((load slib:load slib:load-source macro:load defmacro:load
+ syncase:load synclo:load macwork:load)
+ (top-refs:include (load->path (cadr exp))))
+ ;;((require) (top-refs:require ''compiling (cadr exp)))
+ ;;((require-if) (top-refs:require (cadr exp) (caddr exp)))
+ (else (top-refs:expression exp))))))
+
+(define (arglist:flatten b)
+ (cond ((symbol? b) (list b))
+ ((pair? b)
+ (if (pair? (car b))
+ (append (arglist:flatten (car b)) (arglist:flatten (cdr b)))
+ (cons (car b) (arglist:flatten (cdr b)))))
+ ((list? b) b)
+ (else (slib:error 'arglist:flatten 'bad b))))
+
+(define (top-refs:binding binding body)
+ (fluid-let ((*bindings* (append (arglist:flatten binding)
+ *bindings*)))
+ (for-each (lambda (exp)
+ (cond ((and (pair? exp) (eq? 'define (car exp)))
+ (set! *bindings* (cons (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp))
+ *bindings*)))))
+ body)
+ (for-each top-refs:expression body)))
+
+(define (top-refs:expression exp)
+ (define (cwq exp)
+ (cond ((vector? exp) (for-each cwq (vector->list exp)))
+ ((not (pair? exp)))
+ ((not (list? exp)) (top-refs:warn " dotted list? " exp))
+ ((memq (car exp) '(unquote unquote-splicing))
+ (top-refs:expression (cadr exp)))
+ (else (for-each cwq exp))))
+ (define (cwe exp)
+ (cond ((symbol? exp)
+ (if (and (not (memq exp *bindings*))
+ (not (memq exp *references*)))
+ (set! *references* (cons exp *references*))))
+ ((not (pair? exp)))
+ ((not (list? exp))
+ (for-each top-refs:expression (arglist:flatten exp)))
+ ((not (symbol? (car exp))) (for-each top-refs:expression exp))
+ (else
+ (case (car exp)
+ ((quote) #f)
+ ((quasiquote) (cwq (cadr exp)))
+ ((begin) (for-each cwe (cdr exp)))
+ ((define)
+ (cond ((pair? (cadr exp)) ; (define (foo ...) ...)
+ (top-refs:binding (cadr exp) (cddr exp)))
+ (else
+ (top-refs:binding (cadr exp) (list (cddr exp))))))
+ ((lambda) (top-refs:binding (cadr exp) (cddr exp)))
+ ((case)
+ (top-refs:expression (cadr exp))
+ (for-each (lambda (exp)
+ (for-each top-refs:expression (cdr exp)))
+ (cddr exp)))
+ ((cond)
+ (for-each (lambda (exp)
+ (for-each top-refs:expression exp))
+ (cdr exp)))
+ ((let)
+ (cond ((symbol? (cadr exp))
+ (for-each top-refs:expression (map cadr (caddr exp)))
+ (top-refs:binding (cons (cadr exp) (map car (caddr exp)))
+ (cdddr exp)))
+ (else
+ (for-each top-refs:expression (map cadr (cadr exp)))
+ (top-refs:binding (map car (cadr exp)) (cddr exp)))))
+ ((letrec with-syntax)
+ (top-refs:binding
+ (map car (cadr exp)) (append (map cadr (cadr exp)) (cddr exp))))
+ ((let*)
+ (cond ((null? (cadr exp))
+ (top-refs:binding '() (cddr exp)))
+ ((pair? (caadr exp))
+ (top-refs:expression (cadr (caadr exp)))
+ (top-refs:binding (caaadr exp)
+ `((let* ,(cdadr exp) ,@(cddr exp)))))
+ (else
+ (top-refs:binding (list (caadr exp))
+ `((let* ,(cdadr exp) ,@(cddr exp)))))))
+ ((do)
+ (for-each top-refs:expression (map cadr (cadr exp)))
+ (top-refs:binding
+ (map car (cadr exp))
+ (append
+ (map (lambda (binding)
+ (case (length binding)
+ ((2) (car binding))
+ ((3) (caddr binding))
+ (else (top-refs:warn
+ 'top-refs:expression 'bad 'do-binding exp))))
+ (cadr exp))
+ (caddr exp)
+ (cddr exp))))
+ ((syntax-rules)
+ (fluid-let ((*bindings* (append (arglist:flatten (cadr exp))
+ *bindings*)))
+ (for-each (lambda (exp)
+ (top-refs:binding (car exp) (cdr exp)))
+ (cddr exp))))
+ ((syntax-case)
+ (fluid-let ((*bindings*
+ (cons (cadr exp)
+ (append (arglist:flatten (caddr exp))
+ *bindings*))))
+ (for-each (lambda (exp)
+ (top-refs:binding (car exp) (cdr exp)))
+ (cdddr exp))))
+ (else (for-each top-refs:expression exp))))))
+ (cwe exp))
+
+;;@noindent
+;;The following function parses an @dfn{Info} Index.
+;;@footnote{Although it will
+;;work on large info files, feeding it an excerpt is much faster; and
+;;has less chance of being confused by unusual text in the info file.
+;;This command excerpts the SLIB index into @file{slib-index.info}:
+;;
+;;@example
+;;info -f slib2d6.info -n "Index" -o slib-index.info
+;;@end example
+;;}
+
+;;@body
+;;@2 @dots{} must be an increasing series of positive integers.
+;;@0 returns a list of all the identifiers appearing in the @var{n}th
+;;@dots{} (info) indexes of @1. The identifiers have the case that
+;;the implementation's @code{read} uses for symbols. Identifiers
+;;containing spaces (eg. @code{close-base on base-table}) are
+;;@emph{not} included.
+;;
+;;Each info index is headed by a @samp{* Menu:} line. To list the
+;;symbols in the first and third info indexes do:
+;;
+;;@example
+;;(exports<-info-index "slib.info" 1 3)
+;;@end example
+(define (exports<-info-index file . n)
+ (call-with-input-file file
+ (lambda (port)
+ (define exports '())
+ (and
+ (find-string-from-port? " Node: Index," port)
+ (let loop ((line (read-line port))
+ (iidx 1)
+ (ndxs n))
+ (cond ((null? ndxs) (reverse exports))
+ ((eof-object? line) #f)
+ ((not (string-ci=? "* Menu:" line))
+ (loop (read-line port) iidx ndxs))
+ ((>= iidx (car ndxs))
+ (let ((blank (read-line port)))
+ (if (not (equal? "" blank))
+ (slib:error 'funny 'blank blank)))
+ (do ((line (read-line port) (read-line port)))
+ ((or (eof-object? line)
+ (not (and (> (string-length line) 5)
+ (string=? "* " (substring line 0 2)))))
+ (loop (read-line port) (+ 1 iidx) (cdr ndxs)))
+ (let ((<n> (substring? " <" line)))
+ (define csi (or (and <n>
+ (> (string-length line) (+ 3 <n>))
+ (string-index
+ "0123456789"
+ (string-ref line (+ 2 <n>)))
+ <n>)
+ (substring? ": " line)))
+ (and
+ csi
+ (let ((str (substring line 2 csi)))
+ (if (and (not (substring? " " str))
+ (not (memq (string-ci->symbol str) exports)))
+ (set! exports (cons (string-ci->symbol str) exports))))))))
+ (else (loop (read-line port) (+ 1 iidx) ndxs))))))))