57 lines
1.6 KiB
Scheme
57 lines
1.6 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
; Added really-noting-undefined-variables proc, which gives you noise control.
|
||
|
|
; -Olin 6/95.
|
||
|
|
|
||
|
|
|
||
|
|
; Maintain and display a list of undefined names.
|
||
|
|
|
||
|
|
(define $note-undefined (make-fluid #f))
|
||
|
|
|
||
|
|
(define (note-undefined! p name)
|
||
|
|
(let ((note (fluid $note-undefined)))
|
||
|
|
(if note (note p name))))
|
||
|
|
|
||
|
|
(define (noting-undefined-variables p thunk)
|
||
|
|
(really-noting-undefined-variables p (current-output-port) thunk))
|
||
|
|
|
||
|
|
(define (really-noting-undefined-variables p noise thunk)
|
||
|
|
(let* ((losers '())
|
||
|
|
(foo (lambda (env name)
|
||
|
|
(let ((probe (assq env losers)))
|
||
|
|
(if probe
|
||
|
|
(if (not (member name (cdr probe)))
|
||
|
|
(set-cdr! probe (cons name (cdr probe))))
|
||
|
|
(set! losers (cons (list env name) losers)))))))
|
||
|
|
|
||
|
|
(let-fluid $note-undefined (lambda (p name)
|
||
|
|
(if (generated? name)
|
||
|
|
(foo (generated-env name)
|
||
|
|
(generated-symbol name))
|
||
|
|
(foo p name)))
|
||
|
|
(lambda ()
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda () #f)
|
||
|
|
thunk
|
||
|
|
(lambda ()
|
||
|
|
(for-each (lambda (p+names)
|
||
|
|
(let* ((env (car p+names))
|
||
|
|
;; Keep the ones that are still unbound:
|
||
|
|
(names (filter (lambda (nm)
|
||
|
|
(unbound? (generic-lookup env nm)))
|
||
|
|
(cdr p+names))))
|
||
|
|
(cond ((and (not (null? names)) noise)
|
||
|
|
(display "Undefined" noise)
|
||
|
|
(if (and p (not (eq? env p)))
|
||
|
|
(begin (display " in " noise)
|
||
|
|
(write (car p+names) noise)))
|
||
|
|
(display ": " noise)
|
||
|
|
(write (map (lambda (name)
|
||
|
|
(if (generated? name)
|
||
|
|
(generated-symbol name)
|
||
|
|
name))
|
||
|
|
(reverse names))
|
||
|
|
noise)
|
||
|
|
(newline noise)))))
|
||
|
|
losers)))))))
|