; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; Uses ALPHA

(define files
  (apply append
	 (map (lambda (f)
		(append 
		 (if (memq (car  f) '(- +)) '() (list (car  f)))
		 (if (memq (cadr f) '(- +)) '() (list (cadr f)))))
	      (append *basic-files*
		      *vm-files*
		      '((     boot      +           s48)
			(     -         transport   scheme))))))

(define *xref* '())

(define (xref file-list)
  (let loop ((a '())
	     (l file-list))
    (if (null? l)
	;; Free vars in all files:
	(begin (set! *xref* a)
	       (print-xref))
	(begin (newline)
	       (display "Reading ")
	       (write (car l))
	       (xref-one-file
		 (car l)
		 (lambda (occurring defined)
		   (loop (cons (list (car l) occurring defined)
			       a)
			 (cdr l))))))))

(define (print-xref)
  (let ((a *xref*))
    (call-with-output-file
      "XREF.OUT"
      (lambda (port)
	(display "Cross reference of " port)
	(write (map car a) port)
	(newline port)
	(for-each (lambda (z)
		    ;; z = (filename free defined)
		    (newline)
		    (display "Analyzing ")
		    (write (car z))
		    (newline port)
		    (display "File " port)
		    (write (car z) port)
		    (for-each (lambda (zz)
				(if (not (eq? zz z))
				    (let ((l (intersectq (cadr zz) (caddr z))))
				      (cond ((not (null? l))
					     (newline port)
					     (display "  provides to " port)
					     (write (car zz) port)
					     (write-sorted l port)
					     (newline port))))))
			      a))
		  (cons `(<none> () ,(setdiffq (reduce unionq (map cadr a) '())
					       (reduce unionq (map caddr a) '())))
			a))))
    (newline)
    (display "XREF.OUT written")))

(define (write-sorted l port)
  (for-each (lambda (x)
	      (newline port)
	      (display "    " port)
	      (write x port))
	    (lisp:sort l
		       (lambda (x1 x2)
			 (string<? (symbol->string x1) (symbol->string x2))))))

(define (xref-one-file i-name k)
  (let ((occurring '())
	(defined '()))
    (letrec ((recur
	      (lambda (form)
		(cond ((global-variable? form)
		       (if (not (memq form occurring))
			   (set! occurring (cons form occurring))))
		      ((pair? form)
		       (case (car form)
			 ((define)
			  (if (not (memq (cadr form) defined))
			      (set! defined (cons (cadr form) defined)))
			  (recur (caddr form)))
			 ((@ quote system-ref))
			 ((lambda)
			  (recur (caddr form)))
			 ((letrec)
			  (for-each (lambda (spec) (recur (cadr spec)))
				    (cadr form))
			  (recur (caddr form)))
			 ((if set! begin)
			  (for-each recur (cdr form)))
			 (else (for-each recur form))))))))
      (for-each recur
		(alpha-file (string-append (symbol->string i-name) ".SCM")))
      (k occurring defined))))

(define (free-vars-in-file i-name)
  (xref-one-file i-name setdiffq))