scsh-0.5/bcomp/undefined.scm

57 lines
1.6 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; 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)))))))