diff options
Diffstat (limited to 'top-refs.scm')
| -rw-r--r-- | top-refs.scm | 285 |
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)))))))) |