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


; Structures 'n' packages.

; --------------------
; Structures
;
; A structure is a map from names to binding records, determined by an
; interface (a set of names) and a package (a map from names to binding
; records).
;
; The interface is specified as a thunk.  This removes dependencies on the
; order in which structures are defined.  Also, if the interface is redefined,
; re-evaluating the thunk produces the new, correct interface (see
; env/pedit.scm).
;
; Clients are structures and packages that import the structure's bindings.

(define-record-type structure :structure
  (really-make-structure package interface-thunk interface client-alist name)
  structure?
  (interface-thunk structure-interface-thunk)
  (interface structure-interface-really set-structure-interface!)
  (package   structure-package)
  ;; alist phase -> population
  (client-alist structure-client-alist set-structure-client-alist!)
  (name	     structure-name set-structure-name!))

(define-record-discloser :structure
  (lambda (structure)
    (list 'structure
	  (package-uid (structure-package structure))
	  (structure-name structure))))

; Get the actual interface, calling the thunk if necessary.

(define (structure-interface structure)
  (or (structure-interface-really structure)
      (begin (initialize-structure! structure)
	     (structure-interface-really structure))))

(define (initialize-structure! structure)
  (let ((int ((structure-interface-thunk structure))))
    (if (interface? int)
	(begin (set-structure-interface! structure int)
	       (note-reference-to-interface! int structure))
	(assertion-violation 'initialize-structure!
			     "invalid interface" structure))))

; Make a structure over PACKAGE and the interface returned by INT-THUNK.

(define (make-structure package int-thunk . name-option)
  (if (not (package? package))
      (assertion-violation 'make-structure
			   "invalid package" package int-thunk))
  (let ((struct (really-make-structure package
				       (if (procedure? int-thunk)
					   int-thunk
					   (lambda () int-thunk))
				       #f
				       '()
				       #f)))
    (if (not (null? name-option))
	(note-structure-name! struct (car name-option)))
    (add-to-population! struct (package-clients package))
    struct))

; Add a client to the structure; client opens struct at that phase.

(define (add-structure-client! struct client phase)
  (cond
   ((assv phase (structure-client-alist struct))
    => (lambda (p)
	 (add-to-population! client (cdr p))))
   (else
    (let ((pop (make-population)))
      (add-to-population! client pop)
      (set-structure-client-alist! struct
				   (cons (cons phase pop)
					 (structure-client-alist struct)))))))

; Return population of all clients that open struct at that phase, or #f.
(define (structure-clients struct phase)
  (cond
   ((assv phase (structure-client-alist struct)) => cdr)
   (else (make-population)))) ; this probably makes the procedure unwise to use

; proc gets called on client, phase
(define (for-each-structure-client proc struct)
  (for-each (lambda (p)
	      (let ((phase (car p)))
		(walk-population (lambda (client)
				   (proc client phase))
				 (cdr p))))
	    (structure-client-alist struct)))


; Make a structure by using COMMANDS to modify the STRUCTURE's interface.
; We parse the commands first so that errors are detected before the new
; structure is installed anywhere.

(define (make-modified-structure structure commands)
  (let* ((interface-maker (make-modified-interface-maker commands))
	 (new-struct (make-structure (structure-package structure)
				     (lambda ()
				       (interface-maker
				         (structure-interface structure)))
				    (structure-name structure))))
    (if (structure-unstable? structure)
	(add-structure-client! structure new-struct 0))
    new-struct))

; STRUCT has name NAME.  NAME can then also be used to refer to STRUCT's
; package.

(define (note-structure-name! struct name)
  (if (and name (not (structure-name struct)))
      (begin (set-structure-name! struct name)
	     (note-package-name! (structure-package struct) name))))

; A structure is unstable if its package is.  An unstable package is one
; where new code may be added, possibly modifying the exported bindings.

(define (structure-unstable? struct)
  (package-unstable? (structure-package struct)))

; The #F returned for compile-time environments is conservative.  You could
; look up the name of interest and see where it came from.  It might come
; from a lexical binding or a stable package or structure.  A procedure to
; do this could go in cenv.scm.

(define (environment-stable? env)
  (cond ((package? env)
         (not (package-unstable? env)))
        ((structure? env)
         (not (structure-unstable? env)))
        ((compiler-env? env)
         #f)                    ; conservative
        (else
         (assertion-violation 'environment-stable? "invalid environment" env))))

; Map PROC down the the [name phase type binding] triples provided by STRUCT.

(define (for-each-export proc struct)
  (let ((int (structure-interface struct))
	(package (structure-package struct)))
    (for-each-declaration
        (lambda (name base-name phase want-type)
	  (let ((binding (real-structure-lookup struct package 0 base-name phase want-type #t)))
	    (proc name
		  phase
		  (if (and (binding? binding)
			   (eq? want-type undeclared-type))
		      (let ((type (binding-type binding)))
			(if (variable-type? type)
			    (variable-value-type type)
			    type))
		      want-type)
		  binding)))
	int)))

; --------------------
; Packages

(define-record-type package :package
  (really-make-package uid
		       opens-suspension
		       definitions
		       generated-definitions
		       undefineds
		       undefined-but-assigneds
		       get-location
		       cached
		       clients
		       unstable?
		       integrate?
		       file-name reader expander clauses all-operators? usual-transforms optimizers
		       macro-compile-syntax-node make-lookup-package default-opens ; tower
		       macro-opens-table
		       invoke-template
		       visit-template
		       visited? invoked?
		       phase)
  package?
  (uid	           package-uid)
  (opens-suspension package-opens-suspension)
  ;; The `definitions' and `generated-definitions' tables together contain the package's global bindings: 
  ;; - `definitions' contains the vanilla bindings to names that are symbols
  ;; - `generated-definitions' contains the bindings to generated names
  ;; symbol-table name -> binding
  (definitions     package-definitions)
  ;; other half of definitions: symbol -> (cell (alist (list mark) -> binding))
  (generated-definitions package-generated-definitions)
  (unstable?       package-unstable?)
  ;; value of integrate clause; use integration in this packages
  (integrate?      package-integrate? set-package-integrate?!)

  ;; For EVAL and LOAD (which can only be done in unstable packages)
  ;; package name -> location
  (get-location    package-get-location set-package-get-location!)
  (file-name       package-file-name)
  (reader          package-reader set-package-reader!)
  ;; may be #f
  (expander        package-expander set-package-expander!)
  ;; #0 of tower
  (macro-compile-syntax-node package-macro-compile-syntax-node)
  ;; #1 of tower
  ;; procedure that loads a structure
  (make-lookup-package package-make-lookup-package set-package-make-lookup-package!)
  ;; #2 of tower
  (default-opens package-default-opens)
  ;; phase -> :suspension, created from default opens
  (macro-opens-table package-macro-opens-table set-package-macro-opens-table!)
  (clauses         package-clauses)
  ;; structure had define-all-operators clause?
  (all-operators?   package-all-operators? set-package-all-operators?!)
  ;; names of usual transforms
  (usual-transforms package-usual-transforms set-package-usual-transforms!)
  ;; names of optimizers
  (optimizers      package-optimizers set-package-optimizers!)
  (visited? package-visited? set-package-visited?!)
  (invoked? package-invoked? set-package-invoked?!)
  ;; compiler environment
  (env             package->environment set-package->environment!)

  ;; locations introduced for missing values
  ;; name-table name -> location
  (undefineds      package-real-undefineds set-package-undefineds!)
  ;; locations introduced for missing cells
  ;; name-table name -> location
  (undefined-but-assigneds
                   package-real-undefined-but-assigneds
		   set-package-undefined-but-assigneds!)
  (clients         package-clients)
  ;; locations used here that were supposed to have been provided by someone else
  ;; name-table name -> place, see binding.scm
  (cached	   package-cached)

  ;; template (unlinked) that invokes this package, i.e. runs the
  ;; run-time part of the package
  (invoke-template package-invoke-template set-package-invoke-template!)
  ;; ditto for the expand-time part of the package
  (visit-template package-visit-template set-package-visit-template!)

  ;; absolute phase at which the package is instantiated
  (phase package-phase set-package-phase!)
  )

(define-record-discloser :package
  (lambda (package)
    (let* ((d (list 'package (package-uid package)))
	   (d
	    (cond
	     ((package-name package)
	      => (lambda (name)
		   (append d (list name))))
	     (else d)))
	   (d
	    (if (zero? (package-phase package))
		d
		(append d (list (package-phase package))))))
      d)))

; questionable
(define (package-opens-really package)
  (suspension-structures (package-opens-suspension package)))

(define (make-package opens unstable? tower file clauses
		      uid name)
  (call-with-values
      (lambda () (process-opens opens (if tower (vector-ref tower 2) '())))
    (lambda (opens-suspension macro-opens-table)
      (let ((new (really-make-package
		  (if uid
		      (begin (if (>= uid *package-uid*)
				 (set! *package-uid* (+ uid 1)))
			     uid)
		      (new-package-uid))
		  opens-suspension
		  (make-symbol-table)	;definitions
		  (make-symbol-table)   ;generated-definitions
		  #f			;undefineds
		  #f			;undefined-but-assigned
		  (fluid-cell-ref $get-location)
					;procedure for making new locations
		  (make-name-table)	;bindings cached in templates
		  (make-population)	;structures
		  unstable?		;unstable (suitable for EVAL)?
		  #t			;integrate?
		  file		;file containing DEFINE-STRUCTURE form
		  vanilla-read-forms
		  #f			;expander
		  clauses		;misc. DEFINE-STRUCTURE clauses
		  #f			;all-operators?
		  '()			;usual-transforms
		  '()			;optimizers
		  (and tower (vector-ref tower 0))
		  (and tower (vector-ref tower 1))
		  (if tower
		      (vector-ref tower 2)
		      '())
		  macro-opens-table
		  #f			;invoke-template
		  #f			;visit-template
		  #f #f			;visited? invoked?
		  0)))			;phase
	(note-package-name! new name)
	(set-package->environment! new (really-package->environment new))
	new))))

; both arguments are:
; (list (mixed (thunk (list structure))
;              (pair phase (thunk (list structure)))))
; The thunks are taken to be at phase 0
; returns 2 values:
; - suspension for phase-0 opens
; - suspension table for phases != 0
(define (process-opens opens default-opens)
  (let ((table (make-integer-table))
	(phase-0 '()))
    (for-each (lambda (open)
		(call-with-values
		    (lambda () (if (pair? open)
				   (values (car open) (cdr open))
				   (values 0 open)))
		  (lambda (phase open)
		    (cond
		     ((zero? phase)
		      (set! phase-0 (cons open phase-0)))
		     ((table-ref table phase)
		      => (lambda (susp)
			   (let ((thunk (suspension-thunk susp)))
			     (set-suspension-thunk!
			      susp
			      (lambda ()
				(append (thunk) (open)))))))
		     (else
		      (table-set! table phase
				  (make-suspension open)))))))
	      (append opens default-opens))
    (let ((phase-0 (reverse phase-0)))
      (values (make-suspension (lambda ()
				 (apply append
					(map (lambda (thunk)
					       (thunk))
					     phase-0))))
	      table))))

(define (package-recreate-opens p)
  (let ((phase-0 (package-opens p))
	(nonzero '()))
    (table-walk (lambda (phase susp)
		  (let ((opens (force-suspension susp values)))
		    (set! nonzero
			  (cons (cons phase (lambda () opens))
				nonzero))))
		(package-macro-opens-table p))
    (cons (lambda () phase-0) nonzero)))

(define (really-package->environment package)
  (make-compiler-env (lambda (name phase)
		       (package-lookup-at-phase package 0 name phase))
		     (lambda (name type . maybe-static)
		       (cond
			((and (symbol? name) ; generated names are hopefully of no interest here
			      (opened-structure-for-name package name))
			 => (lambda (struct)
			      (warning 'package-define!
				       "name from opened structure redefined"
				       package name struct))))
		       (package-define! package
					name
					type
					#f
					(if (null? maybe-static)
					    #f
					    (car maybe-static))))
		     package))	; interim hack

(define (opened-structure-for-name package name)
  (let loop ((opens (package-opens-really package)))
    (cond
     ((null? opens)
      #f)
     ((structure-lookup (car opens) name #t)
      (car opens))
     (else
      (loop (cdr opens))))))

(define (package-initialized? package)
  (suspension-forced? (package-opens-suspension package)))

; for env/pedit.scm

(define (package-add-opens! p phase thunk)
  (let* ((sus 
	  (cond
	   ((zero? phase)
	    (package-opens-suspension p))
	   ((table-ref (package-macro-opens-table p) phase))
	   (else
	    (let ((sus (make-suspension (lambda () '()))))
	      (table-set! (package-macro-opens-table p) phase sus)
	      sus))))
	 (previous-thunk (suspension-thunk sus)))
    (set-suspension-thunk! sus 
			   (lambda ()
			     (let loop ((new (reverse (thunk)))
					(structs (previous-thunk)))
			       (cond
				((null? new)
				 structs)
				((memq (car new) structs)
				 (loop (cdr new) structs))
				(else
				 (loop (cdr new) (cons (car new) structs)))))))))

; for the static linker

(define (package-zap-macro-opens! p)
  (set-package-macro-opens-table! p (make-integer-table)))

(define (package-macro-opens->alist p)
  (let ((alist '()))
    (table-walk (lambda (phase susp)
		  (set! alist
			(cons (cons phase (force-suspension susp values))
			      alist)))
		(package-macro-opens-table p))
    alist))

; Two tables that we add lazily.

(define (lazy-table-accessor slot-ref slot-set!)
  (lambda (package)
    (or (slot-ref package)
	(let ((table (make-name-table)))
	  (slot-set! package table)
	  table))))

(define package-undefineds
  (lazy-table-accessor package-real-undefineds
		       set-package-undefineds!))

(define package-undefined-but-assigneds
  (lazy-table-accessor package-real-undefined-but-assigneds
		       set-package-undefined-but-assigneds!))

; Unique id's

(define (new-package-uid)
  (let ((uid *package-uid*))		;unique identifier
    (set! *package-uid* (+ *package-uid* 1))
    uid))

(define *package-uid* 0)

; Package names

(define package-name-table (make-table))

(define (package-name package)
  (table-ref package-name-table (package-uid package)))

(define (note-package-name! package name)
  (if name
      (let ((uid (package-uid package)))
	(if (not (table-ref package-name-table uid))
	    (table-set! package-name-table uid name)))))

(define (package-opens package)
  (initialize-package-if-necessary! package)
  (force-suspension (package-opens-suspension package) values))

(define (initialize-package-if-necessary! package)
  (if (not (package-initialized? package))
      (initialize-package! package)))

; --------------------
; A simple package has no opens at phases != 0, ACCESSes or other far-out clauses.

(define (make-simple-package opens unstable? tower . name-option)
  (if (not (list? opens))
      (assertion-violation 'make-simple-package "invalid package opens list" opens))
  (let ((package (make-package (list (lambda () opens))
			       unstable?
			       tower
			       ""	;file containing DEFINE-STRUCTURE form
			       '((declare no-syntax no-state))	;clauses
			       #f	;uid
			       (if (null? name-option)
				   #f
				   (car name-option)))))
    (set-package-visited?! package #t)
    (set-package-invoked?! package #t)
    package))

; --------------------
; The definitions table

; Returns a binding or #f.

(define (package-definition package name)
  (initialize-package-if-necessary! package)
  (cond
   ((package-lookup-definition package name)
    => (lambda (probe)
	 (maybe-fix-place! probe)
	 (maybe-fix-transform! package name probe)
	 probe))
   (else #f)))

; kludge: (re-)visiting a package doesn't create transforms, only the
; transformation procedures; fix that up
(define (maybe-fix-transform! package name binding)
  (if (and (eq? (binding-static binding) 'syntax)
	   (not (macro-transform? (contents (binding-place binding)))))
      (let ((loc (binding-place binding)))
	(set-contents! loc
		       (make-transform/macro (contents loc)
					     package
					     syntax-type
					     name)))))

(define (package-define! package name type place static)
  (cond
   ((package-lookup-definition package name)
    => (lambda (probe)
	 (clobber-binding! probe type place static)
	 (binding-place (maybe-fix-place! probe))))
   (else
    (let* ((place (or place (get-new-location package name)))
	   (binding (make-binding type place static)))
      (cond
       ((symbol? name)
	(table-set! (package-definitions package) name binding))
       ((syntax? name)
	(let ((symbol (syntax-object-expr name))
	      (marks (syntax-object-marks name)))
	  (if (null? marks)
	      (table-set! (package-definitions package) symbol binding)
	      (let ((entry (cons marks binding))
		    (generated-definitions (package-generated-definitions package)))
		(cond
		 ((table-ref generated-definitions symbol)
		  => (lambda (cell)
		       ;; we know this entry isn't there
		       (cell-set! cell (cons entry (cell-ref cell)))))
		 (else
		  (table-set! generated-definitions symbol
			      (make-cell (list entry)))))))))
       (else
	(assertion-violation 'package-define! "invalid name" package name)))
      place))))

(define (package-remove-definition! package name)
  (cond
   ((symbol? name)
    (table-set! (package-definitions package) name #f))
   ((syntax? name)
    (cond
     ((table-ref (package-generated-definitions package) (syntax-object-expr name))
      => (lambda (cell)
	   (let ((marks (syntax-object-marks name)))
	     (cell-set! cell
			(filter (lambda (p)
				  (not (marks=? marks (car p))))
				(cell-ref cell))))))))
   (else
    (assertion-violation 'package-remove-definition! "invalid name" package name))))

(define (package-add-static! package name static)
  (cond
   ((package-lookup-definition package name)
    => (lambda (probe)
	 (clobber-binding! probe
			   (binding-type probe)
			   (binding-place probe)
			   static)))
   (else
    (assertion-violation 'package-add-static!
			 "internal error: name not bound" package name))))

(define (package-refine-type! package name type)
  (cond
   ((package-lookup-definition package name)
    => (lambda (probe)
	 (clobber-binding! probe
			   type
			   (binding-place probe)
			   (binding-static probe))))
   (else
    (assertion-violation 'package-refine-type!
			 "internal error: name not bound" package name))))

; --------------------
; Lookup

; This is a compile-time environment to support the proper
; implementation of phases.

; lookup-package : package-0 phase |-> package
; package-0 is the package at phase 0

(define $lookup-package (make-fluid (lambda (package-0 phase) package-0)))

(define (call-with-lookup-package lookup thunk)
  (let-fluid $lookup-package
	     lookup
	     thunk))

; Look up a name in a package.  Returns a binding if bound or #F if not.

(define (package-lookup package name)
  (package-lookup-at-phase package 0 name 0))

(define (package-lookup-at-phase package package-phase name name-phase)
  (let ((integrate? (package-integrate? package)))
    (cond
     ((symbol? name)
      (really-package-lookup package package-phase name name-phase integrate?))
     ((syntax? name)
      (package-lookup-generated-name-at-phase package package-phase name name-phase integrate?))
     (else
      (assertion-violation 'package-lookup-at-phase "invalid name" package name)))))

; Only for generated names: Here, package may be #f, as the name
; carries a link path.
(define (package-lookup-generated-name-at-phase package package-phase name name-phase integrate?)
  (let ((symbol (syntax-object-expr name)))
    (let loop ((marks (syntax-object-marks name))
	       (env package)
	       (package-phase package-phase)
	       (name-phase name-phase))
      (cond
       ((pair? marks)
	(cond
	 ((not (mark-identifier (car marks)))
	  (loop (cdr marks) env package-phase name-phase))
	 ((and package
	       (zero? name-phase)
	       (table-ref (package-generated-definitions (env->package env)) symbol))
	  => (lambda (cell)
	       (cond
		((first (lambda (p)
			  (marks=? marks (car p)))
			(cell-ref cell))
		 => (lambda (p)
		      (if integrate?
			  (cdr p)
			  (forget-integration (cdr p)))))
		(else 
		 (let ((mrk (car marks)))
		   (loop (cdr marks)
			 (mark-transform-env mrk)
			 (mark-phase mrk)
			 (- name-phase (mark-phase mrk))))))))
	 (else
	  (let ((mrk (car marks)))
	    (loop (cdr marks)
		  (mark-transform-env mrk)
		  (mark-phase mrk)
		  (- name-phase (mark-phase mrk)))))))
       ((package? env)
	(really-package-lookup env package-phase symbol name-phase integrate?))
       (package
	;; #### kludge: as package-lookup is being abused to do local lookup
	(lookup env symbol))
       (else #f)))))

; package-phase is absolute
; name-phase is relative to package-phase
(define (really-package-lookup package package-phase name name-phase integrate?)
  (cond ((and (zero? name-phase)
	      (package-definition package name))
	 => (lambda (probe)
	      (if integrate?
		  probe
		  (forget-integration probe))))
	((search-opens (package-opens package) package-phase name name-phase integrate?))
	(else
	 (search-macro-opens package package-phase name name-phase integrate?))))

; Look for name in macro opens for PACKAGE
; phase != 0
(define (search-macro-opens package package-phase name name-phase integrate?)
  (let ((table (package-macro-opens-table package)))
    (let loop ((search-phase 1))
      (cond
       ((> search-phase name-phase) #f)
       ((table-ref table search-phase)
	=> (lambda (susp)
	     (let ((opens
		    (force-suspension susp
				      (lambda (struct)
					(if (structure-unstable? struct)
					    (add-structure-client! struct package search-phase))))))
	       (or (search-opens opens
				 (+ package-phase search-phase)
				 name
				 (- name-phase search-phase)
				 integrate?)
		   (loop (+ search-phase 1))))))
       (else (loop (+ search-phase 1)))))))

; Look for NAME in structures OPENS.

(define (search-opens opens package-phase name name-phase integrate?)
  (let loop ((opens opens))
    (if (null? opens)
	#f
	(let* ((open (car opens))
	       (package ((fluid $lookup-package) (structure-package open) package-phase)))
	  (or (real-structure-lookup-at-phase open package package-phase name name-phase integrate?)
	      (loop (cdr opens)))))))

(define (structure-lookup struct name integrate?)
  (structure-lookup-at-phase struct 0 name 0 integrate?))

(define (structure-lookup-at-phase struct struct-phase name name-phase integrate?)
  (real-structure-lookup-at-phase struct (structure-package struct) struct-phase name name-phase integrate?))

; `package' may be different from (structure-package struct) because
; of the lookup in `search-opens'.
(define (real-structure-lookup-at-phase struct package package-phase name name-phase integrate?)
  (call-with-values
      (lambda ()
	(interface-ref (structure-interface struct) name name-phase))
    (lambda (base-name type)
      (if type
	  (real-structure-lookup struct package package-phase base-name name-phase type integrate?)
	  #f))))

(define (real-structure-lookup struct package package-phase name name-phase type integrate?)
  (impose-type type
	       (really-package-lookup package package-phase
				      name name-phase
				      integrate?)
	       integrate?))

(define (generic-lookup env name)
  (cond ((package? env)
	 (package-lookup env name))
	((structure? env)
	 (or (structure-lookup env
			       name
			       (package-integrate? (structure-package env)))
	     (assertion-violation 'generic-lookup "not exported" env name)))
	((compiler-env? env)
	 (lookup env name))
	(else
	 (assertion-violation 'generic-lookup "invalid environment" env name))))

(define (package-lookup-definition package name)
  (cond
   ((symbol? name)
    (table-ref (package-definitions package) name))
   ((syntax? name)
    (cond
     ((table-ref (package-generated-definitions package) (syntax-object-expr name))
      => (lambda (cell)
	   (cond
	    ((assoc (syntax-object-marks name) (cell-ref cell)) => cdr)
	    (else #f))))
     (else #f)))
   (else
    (assertion-violation 'package-lookup-definition "invalid name" package name))))
	     

; --------------------
; Treating packages and compile-time environments interchangeably

(define (env-bump-phase env level)
  (let ((env (if (package? env)
		 (package->environment env)
		 env)))
    (comp-env-bump-phase env level)))

(define (env->package env)
  (cond ((compiler-env? env)
         ;; This returns #f if package is stable (static linking).
         (comp-env-package env))
        ((package? env) env)
	((structure? env) (structure-package env))
	(else
	 (assertion-violation 'env->package "can't be coerced to a package" env))))

(define (env-phase env)
  (cond ((compiler-env? env) (comp-env-phase env))
        ((package? env) 0)
        ((structure? env) 0)
	(else
	 (assertion-violation 'env-phase "can't be coerced to a package" env))))

; --------------------
; Package initialization

(define (initialize-package! package)
  (let ((opens (reforce-suspension (package-opens-suspension package))))
    (table-walk (lambda (phase susp)
		  (reset-suspension! susp))
		(package-macro-opens-table package))
    (for-each (lambda (struct)
		(if (structure-unstable? struct)
		    (add-structure-client! struct package 0)))
	      opens)))

(define (check-package-for-duplicates! package)
  (let ((imported-names (make-name+phase-table)) ; maps name+phase to pair of first binding, list of structures
	(duplicates '()))		; (list (pair name phase))

    (define (check-struct struct struct-phase)
      (for-each-export 
       (lambda (name export-phase type binding)
	 (let ((phase (+ struct-phase export-phase)))
	   (receive (p token) (name+phase-table-ref imported-names name phase)
	     (cond
	      ((not p)
	       (name+phase-table-set! imported-names name phase token (cons binding (list struct))))
	      ((not (same-denotation? (car p) binding))
	       (set! duplicates (cons (cons name phase) duplicates))
	       (if (not (memq struct (cdr p)))
		   (set-cdr! p (cons struct (cdr p)))))))))
       struct))

    (for-each (lambda (open) (check-struct open 0)) (package-opens package))
    (table-walk (lambda (phase susp)
		  (for-each (lambda (struct)
			      (check-struct struct phase))
			    (force-suspension susp values)))
		(package-macro-opens-table package))
    (for-each (lambda (p)
		(receive (stuff token) (name+phase-table-ref imported-names (car p) (cdr p))
		  (apply warning 'check-for-duplicates!
			 "duplicate name in opened structure"
			 (car p)
			 (cdr p)
			 package
			 (cdr stuff))))
	      duplicates)))

; --------------------
; For implementation of INTEGRATE-ALL-PRIMITIVES! in scanner, etc.

;; #### should probably iterate over a separate, immutable set of
;; names created by the expander, as in unstable package, this table
;; includes the "volatile" definitions made afterwards
(define (for-each-definition proc package)
  (table-walk (lambda (name binding)
		(proc name (maybe-fix-place! binding)))
	      (package-definitions package))
  (table-walk (lambda (name cell)
		(for-each (lambda (p)
			    (proc name (maybe-fix-place! (cdr p))))
			  (cell-ref cell)))
	      (package-generated-definitions package)))

; --------------------
; Utilities for phases

(define (package-syntactic-tower package)
  (vector (package-macro-compile-syntax-node package)
	  (package-make-lookup-package package)
	  (package-default-opens package)))

; --------------------
; Suspensions

; like a promise, but can be re-initialized
(define-record-type suspension :suspension
  (really-make-suspension thunk structures)
  suspension?
  ;; yields list of structures
  (thunk suspension-thunk really-set-suspension-thunk!)
  ;; #f if uninitialized
  (structures suspension-structures set-suspension-structures!))

(define (make-suspension thunk)
  (really-make-suspension thunk #f))

(define (set-suspension-thunk! sus thunk)
  (reset-suspension! sus)
  (really-set-suspension-thunk! sus thunk))

(define-record-discloser :suspension
  (lambda (r)
    (list 'suspension (suspension-structures r))))

(define (suspension-forced? s)
  (and (suspension-structures s)
       #t))

(define (force-suspension s ensure)
  (or (suspension-structures s)
      (let ((structs (reforce-suspension s)))
	(for-each ensure structs)
	structs)))

(define (reforce-suspension s)
  (let ((structs ((suspension-thunk s))))
    (set-suspension-structures! s structs)
    structs))

(define (reset-suspension! s)
  (set-suspension-structures! s #f))

; --------------------
; Locations

(define (get-new-location package name)
  ((package-get-location package) package name))

; Default new-location method for new packages

(define (make-new-location package name)
  (let ((uid *location-uid*))
    (set! *location-uid* (+ *location-uid* 1))
    (table-set! location-info-table uid
		(make-immutable!
		 (cons (name->symbol name) (package-uid package))))
    (make-undefined-location uid)))

(define $get-location (make-fluid (make-cell make-new-location)))

(define *location-uid* 5000)  ; 1510 in initial system as of 1/22/94

(define location-info-table (make-table))


(define (flush-location-names)
  (set! location-info-table (make-table))
  ;; (set! package-name-table (make-table)) ;hmm, not much of a space saver
  )

; (put 'package-define! 'scheme-indent-hook 2)


