; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Scanning structures and processing package clauses.

; Utility for compile-structures (link/link.scm) and
; ensure-loaded (env/load-package.scm).
;
; Returns a list of all package-phase pairs reachable from
; STRUCTS-OR-PACKAGES that answer true to INCLUDE-THIS-PACKAGE?.
; INCLUDE-MACRO-OPEN? decides whether a macro open should be followed:
; it's passed a structure and a phase.

(define (collect-packages structs-or-packages phase include-this-package? include-macro-open?)
  ;; these are all (list (pair ... phase))
  (let ((package-seen '())
	(structure-seen '())
	(packages '()))
    (letrec ((recur-structure
	      (lambda (structure phase visited)
		(let ((package (structure-package structure)))
		  (if (memq package visited)
		      (warning 'collect-packages "cycle in structures dependencies"
			       structure phase visited))
		  (let ((structure+phase (cons structure phase)))
		    (if (not (member structure+phase structure-seen))
			(begin
			  (set! structure-seen (cons structure+phase structure-seen))
			  (recur-package package phase visited)))))))
	     (recur-package
	      (lambda (package phase visited)
		(let ((package+phase (cons package phase)))
		  (if (not (member package+phase package-seen))
		      (begin
			(set! package-seen (cons package+phase package-seen))
			(if (include-this-package? package phase)
			    (let ((visited (cons package visited)))
			      (for-each (lambda (struct)
					  (recur-structure struct phase visited))
					(package-opens package))
			      (for-each (lambda (phase+structs)
					  (let ((open-phase (car phase+structs)))
					    (for-each (lambda (struct)
							(if (include-macro-open? struct open-phase)
							    (recur-structure struct (+ phase open-phase) visited)))
						      (cdr phase+structs))))
					(package-macro-opens->alist package))
			      (set! packages (cons package+phase packages))))))))))
	      
      (for-each (lambda (thing)
		  (cond
		   ((structure? thing)
		    (recur-structure thing phase '()))
		   ((package? thing)
		    (recur-package thing phase '()))
		   (else
		    (assertion-violation 'collect-packages "not a structure or package" thing))))
		structs-or-packages)
      (reverse packages))))

; Walk through PACKAGE's clauses to find the source code.  The relevant
; clauses are:
;   (files name ...)
;   (begin form ...)
;   (define-all-operators)
;   (usual-transforms name ...)
;
; Returns a list of pairs (file . (node1 node2 ...)), after setting
; the `reader', `expander', `all-operators?', `usual-transforms', and
; `optimizers' fields of the package.

(define (package-source package)
  (let* ((config-file (package-file-name package))
	 (dir (cond
	       (config-file => file-name-directory)
	       (else #f))))
    (reverse
     (fold (lambda (clause stuff)
	     (case (car clause)
	       ((files)
		(read-files (cdr clause) stuff dir package))
	       ((begin)
		(cons (cons config-file (cdr clause))
		      stuff))
	       (else
		(case (car clause)
		  ((integrate)
		   (set-package-integrate?! package
					    (or (null? (cdr clause))
						(cadr clause))))
		  ((optimize)
		   (set-package-optimizers! package
					    (append-uniq (package-optimizers package)
							 (cdr clause))))
		  ((define-all-operators)
		   (set-package-all-operators?! package #t))
		  ((usual-transforms)
		   (set-package-usual-transforms! package
						  (append-uniq (package-usual-transforms package)
							       (cdr clause))))
		  ((reader)
		   (set-package-reader! package 
					(contents
					 (binding-place
					  (package-lookup-at-phase package 0 (cadr clause) 1)))))
		  ((expander)
		   (set-package-expander! package
					  (contents
					   (binding-place
					    (package-lookup-at-phase package 0 (cadr clause) 1)))))
		  ((declare) (values)) ; #### handled elsewhere for now
		  (else
		   (assertion-violation 'package-source
					"unrecognized define-structure keyword"
					clause)))
		stuff)))
	   (package-clauses package)
	   '()))))

; append all elements of `new' to 'lis' that aren't in there already
(define (append-uniq lis new)
  (reverse
   (fold (lambda (one result)
	   (if (memq one result)
	       result
	       (cons one result)))
	 new
	 (reverse lis))))

; Also prints out the filenames (courtesy of READ-FORMS).

(define (read-files all-files stuff dir package)
  (force-output (current-output-port))		; just to be nice
  (fold (lambda (filespec stuff)
	  (let ((file (namestring filespec
				  dir
				  *scheme-file-type*)))
	    (display #\space (current-noise-port))
	    (cons (cons file (read-forms file package #f))
		  stuff)))
	all-files
	stuff))

(define (check-structure structure)
  (let ((undefined '()))
    (for-each-export
         (lambda (name phase want-type binding)
	   (if (binding? binding)
	       (let ((have-type (binding-type binding)))
		 (if (not (compatible-types? have-type want-type))
		     (warning 'check-structure
			      "Type in interface doesn't match binding"
			      name
			      `(binding: ,(type->sexp have-type #t))
			      `(interface: ,(type->sexp want-type #t))
			      structure)))
	       (set! undefined (cons name undefined))))
	 structure)
    (if (not (null? undefined))
	(warning 'check-structure
		 "Structure has undefined exports"
		 structure
		 undefined))))

