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

; The entry point for all this.

; The phase says how much to phase-shift the package's code, i.e. its
; syntax objects.

(define (link! template env phase noise?)
  (if (not (zero? phase))
      ;; sorry ...
      (assertion-violation 'link! "can't link in-place with a phase shift" template env phase noise?))
  (if noise?
      (noting-undefined-variables (env->package env)
				  (lambda ()
				    (really-link! template phase env)))
      (really-link! template phase env)))

(define (really-link! template phase env)  
  (let recur ((template template))
    (do ((size (template-length template))
	 (i 0 (+ i 1)))
	((= i size) template)
      (template-set! template i
		     (link-one (template-ref template i) env phase recur)))))

; The same thing, but persistent.

(define (link template package phase noise?)
  (if noise?
      (noting-undefined-variables package
				  (lambda ()
				    (really-link template phase package)))
      (really-link template phase package)))

(define (really-link template phase env)  
  (let recur ((template template))
    (do ((new (make-template (template-length template) 0))
	 (size (template-length template))
	 (i 0 (+ i 1)))
	((= i size) new)
      (template-set! new i
		     (link-one (template-ref template i) env phase recur)))))

(define (link-one x env phase recur)
  (cond ((thingie? x)
	 (get-location (thingie-binding x)
		       env
		       (thingie-name x)
		       (thingie-assigned? x)))
	((placecard? x)
	 (compute-location env
			   (placecard-qualified-name x)
			   (sexp->type (placecard-type-sexp x) #t)
			   (placecard-assigned? x))) 

	((syntax? x)
	 (add-phase-shift x phase))
	((template? x)
	 (recur x))
	(else x)))

; GET-LOCATION returns a location to be stored away in a template.  If
; ASSGINED? (which is #t if the variable is SET!) matches the type of
; the binding, then we just return the binding's location after noting
; that we are doing so.
;
; If the type doesn't match then we make a location and remember that we
; have done so.  If correct location becomes available later we will replace
; the bogus one (see env/pedit.scm).

(define (get-location binding env name assigned?)
  (cond
   ((binding? binding)
    (note-location! env name (binding-place binding) (binding-type binding) assigned?))
   (assigned?
    (get-location-for-undefined env name location-for-assignment))
   (else
    (get-location-for-undefined env name location-for-reference))))

(define (compute-location env qualified type assigned?)
  (let* ((env (if (syntax-type? type)
		  ;; The toplevel syntax templates are at phase 1, but create
		  ;; bindings at phase 0; hence we must shift down.
		  (env->package env)
		  env))
	 (name (qualified->name qualified env)))
    (cond
     ((generic-lookup env name)
      => (lambda (binding) 
	   (note-location! env name (binding-place binding) type assigned?)))
     (assigned?
      (warning 'compute-location "undefined and assigned" env qualified name)
      (get-location-for-undefined env name location-for-assignment))
     (else
      (warning 'compute-location "undefined" env qualified name)
      (get-location-for-undefined env name location-for-reference)))))

(define (note-location! env name place type assigned?)
  (cond
   ((variable-type? type)
    (note-caching! env name place)
    place)
   (assigned?
    (get-location-for-unassignable env name))
   ((value-type? type)
    (note-caching! env name place)
    place)
   ((syntax-type? type)
    (note-caching! env name place)
    place)
   (else
    (warning 'note-location! "invalid variable reference" name env)
    (note-caching! env name place)
    place)))

; Freeze the thingies for transportation or relinking

(define (freeze-template! template env)
  (let recur ((template template))
    (do ((size (template-length template))
	 (i 0 (+ i 1)))
	((= i size) template)
      (let ((x (template-ref template i)))
	(cond
	 ((thingie? x)
	  (template-set! template i (thingie->placecard x env)))
	 ((template? x)
	  (recur x)))))))

; essentially the inverse to compute-location
(define (thingie->placecard thingie env)
  (let* ((binding (thingie-binding thingie))
	 (type (and (binding? binding)
		    (binding-type binding))))
    (make-placecard (if type
			(type->sexp type #t)
			undeclared-type)
		    (name->qualified (thingie-name thingie))
		    (thingie-assigned? thingie))))

; Packages have three tables used by env/pedit.scm:
;   undefineds
;     locations introduced for missing values
;   undefined-but-assigneds
;     locations introduced for missing cells
;   cached
;     locations used here that were supposed to have been provided by
;     someone else

; Get a location from PACKAGE's table at ACCESSOR.

(define (location-on-demand accessor)
  (lambda (package name)
    (let ((table (accessor package)))
      (or (table-ref table name)
	  (let ((new (make-new-location package name)))
	    (table-set! table name new)
	    new)))))

(define get-undefined
  (location-on-demand package-undefineds))

(define get-undefined-but-assigned
  (location-on-demand package-undefined-but-assigneds))

; If this package is mutable and it gets NAME from some other structure
; then add NAME and PLACE to its table of cached locations.

(define (package-note-caching! package name phase place)
  (if (and (package-unstable? package)
	   (or (not (zero? phase))
	       (not (package-lookup-definition package name))))
      (receive (struct struct-phase internal-name type)
	  (package-lookup-in-opens package name phase)
	(if internal-name
	    (begin
	      (if (zero? phase)
		  (table-set! (package-cached package) name place))
	      (package-note-caching! (structure-package struct) 
				     internal-name struct-phase place))))))

; Find the actual package providing PLACE and remember that it is being used.

(define (note-caching! env name place)
  (receive (package name phase) (resolve-generated-name env name)
    (if (package? package)
	(package-note-caching! package name phase place))))

; Get a location for NAME which is SET! but isn't supposed to be.

; In this case, we're creating a new, local location for the
; assignment to happen - the original location isn't touched.

(define (get-location-for-unassignable env name)
  (receive (package name phase) (resolve-generated-name env name)
    (warning 'get-location-for-unassignable "invalid assignment" package name phase)
    (if (and (zero? phase) (package? package))
	(lambda () (get-undefined-but-assigned package name))
	(lambda () (make-undefined-location name)))))

; Get a location for NAME, which is undefined.

(define (get-location-for-undefined env name get-location)
  (receive (package name phase) (resolve-generated-name env name)
    ((or (fluid $note-undefined) values) env name)
    (if (package? package)
	(let ((place (get-location package name phase)))
	  (package-note-caching! package name phase place)
	  place)
	(make-undefined-location name))))

(define (resolve-generated-name env name)
  (if (identifier? name)
      (let recur ((env env) (ctx (syntax-object-context name)) (phase (env-phase env)))
	(cond
	 ((null? ctx)
	  (values (env->package env) (identifier name) phase))
	 ((mark? (car ctx))
	  (recur (mark-transform-env (car ctx)) (cdr ctx) (mark-phase (car ctx))))
	 (else ; #### need to do real real resolution at some point
	  (recur env (cdr ctx) phase))))
      (values (env->package env) name (env-phase env))))


; returns struct, base-name, type
; cf search-opens, structure-lookup-at-phase
(define (search-opens-export opens name phase)
  (let loop ((opens opens))
    (if (null? opens)
	(values #f #f #f)
	(let ((struct (car opens)))
	  (call-with-values
	      (lambda ()
		(interface-ref (structure-interface struct) name phase))
	    (lambda (base-name type)
	      (if base-name
		  (values struct base-name type)
		  (loop (cdr opens)))))))))

; returns structure, phase within that structure, base-name, and type
; cf. search-macro-opens
(define (package-lookup-in-opens package name phase)
  (receive (struct base-name type) (search-opens-export (package-opens package) name phase)
      (if struct
	  (values struct 0 base-name type)
	  (let ((table (package-macro-opens-table package)))
	    (let loop ((phase-level 1))
	      (cond
	       ((> phase-level phase)
		(values #f #f #f #f))
	       ((table-ref table phase-level)
		=> (lambda (susp)
		     (receive (struct base-name type)
			 (search-opens-export (force-suspension susp values)
					      name
					      (- phase phase-level))
		       (if struct
			   (values struct (- phase phase-level) base-name type)
			   (loop (+ phase-level 1))))))
	       (else (loop (+ phase-level 1)))))))))

(define $note-undefined (make-fluid (lambda (env name) (values))))

; Exported for env/pedit.scm.

(define (location-for-reference package name phase)
  (get-undefined-location package name phase get-undefined #f))

(define (location-for-assignment package name phase)
  (get-undefined-location package name phase get-undefined-but-assigned #t))

(define (get-undefined-location package name phase get-undefined warn-assignment?)
  (let location ((package package)
		 (name name)
		 (phase phase)
		 (warn? warn-assignment?))
    (receive (struct struct-phase internal-name type) 
	(package-lookup-in-opens package name phase)
      (if struct
	  (begin
	    (if warn?
		(warning 'location-for-assignment "invalid assignment" name))
	    (location (structure-package struct)
		      internal-name
		      struct-phase
		      #f))
	  (get-undefined package name)))))



;----------------
; Maintain and display a list of undefined names.
; We bind $NOTE-UNDEFINED to a procedure that adds names to LOSERS, an a-list of
; (<package> . <undefined-names>).  Once THUNK has finished we print out any
; names that are still undefined.  CURRENT-PACKAGE is used only to avoid printing
; out the name of the current package unnecessarily.  CURRENT-PACKAGE may be #f.

(define (noting-undefined-variables current-package thunk)
  (let ((losers '()))
    (let-fluid $note-undefined
        (lambda (env name)
	  (receive (package name phase) (resolve-generated-name env name)
	    (let ((probe (assoc (cons package phase) losers)))
	      (if probe
		  (if (not (member name (cdr probe)))
		      (set-cdr! probe (cons name (cdr probe))))
		  (set! losers (cons (list (cons package phase) name) losers))))))
      (lambda ()
	(dynamic-wind
	 (lambda () #f)
	 thunk
	 (lambda ()
	   (for-each (lambda (package/phase+names)
		       (print-undefined-names (caar package/phase+names)
					      (cdar package/phase+names)
					      (cdr package/phase+names)
					      current-package))
		     losers)))))))

(define (print-undefined-names package phase names current-package)
  (let ((names (filter (lambda (name)
			 ;; Keep the ones that are still unbound.
			 (not (package-lookup-at-phase package 0 name phase)))
		       names)))
    (if (pair? names)
	(apply warning
	       'print-undefined-names
	       "undefined variables"
	       package
	       phase
	       names))))
