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