; Identifier resolution

; tail-calls either on-lexical or on-global:
; - if the identifier is lexically bound:
;   calls on-lexical on exact non-negative integer, representing the phase of a lexical binding
;   + the result of renaming
; - if the identifier is free/global:
;   calls on-global on (optional) result of lookup + package-context or #f if none present

(define (resolve stx phase on-lexical on-global)
  (let resolve* ((name (syntax-e stx))
		 (ctx (syntax-object-context stx))
		 (phase phase)
		 (phase-delta 0)
		 (dctxs-seen '()))
    (if (null? ctx)
	(on-global #f #f)
	(let ((ctxe (car ctx)))
	  (cond
	   ((mark? ctxe)
	    (resolve* name (cdr ctx) phase phase-delta dctxs-seen))
	   ((rename? ctxe)
	    (let ((name-renamed (rename-from-name ctxe))
		  (marks-renamed (rename-from-marks ctxe)))
	      (if (and (eq? name name-renamed)
		       (marks=? (marks-of (cdr ctx)) marks-renamed))
		  (on-lexical (+ (rename-to-phase ctxe) phase-delta) (rename-to-name ctxe))
		  (resolve* name (cdr ctx) phase phase-delta dctxs-seen))))
	   ((definition-context? ctxe)
	    (cond
	     ((assq ctxe dctxs-seen)
	      (resolve* name (cdr ctx) phase phase-delta dctxs-seen))
	     (else
	      (cond
	       ((definition-context-resolved-table ctxe)
		=> (lambda (resolved-table)
		     (table-set! resolved-table (cons name (marks-of (cdr ctx))) 'resolved))))
	      (resolve* name
			(append (definition-context-renames ctxe)
				(cdr ctx))
			phase phase-delta
			(cons (cons ctxe '()) dctxs-seen)))))
	   ((package-context? ctxe)
	    ;; (assert (null? (cdr ctx)))
	    (on-global #f
		       (and (= (+ phase phase-delta)
			       (package-context-phase ctxe))
			    ctxe)))
	   ((phase-shift? ctxe)
	    (resolve* name (cdr ctx) phase (+ phase-delta (phase-shift-delta ctxe)) dctxs-seen))
	   ((operator-context? ctxe)
	    (on-global (operator-context-ref ctxe)
		       #f))
	   (else
	    (assertion-violation 'resolve "unknown context element" stx ctxe)))))))

; returns resolved name, and result of lookup
(define (resolve+lookup stx env)
  (let ((ephase (env-phase env)))
    (resolve stx ephase
	     (lambda (phase lbl)
	       (values lbl
		       (and (= phase ephase)
			    (generic-lookup env lbl))))
	     (lambda (l pkgctx)
	       (let ((e (syntax-object-expr stx)))
		 (values e
			 (or l
			     (complete-lookup (generic-lookup env stx))
			     (and pkgctx
				  ;; last-ditch effort
				  (complete-lookup
				   (package-lookup-generated-name-at-phase (package-context-package pkgctx)
									   (package-context-phase pkgctx)
									   stx 
									   (- ephase 
									      (package-context-phase pkgctx))
									   #f))))))))))

(define (complete-lookup b)
  (cond
   ((operator? b) b)
   ((eq? b 'stop) 'stop)
   ((binding? b)
    (let ((s (binding-static b)))
      (if (operator? s) 
	  s
	  b)))
   (else #f)))  

(define (resolve+label stx phase)
  (resolve stx phase
	   (lambda (phase lbl) lbl)
	   (lambda (l pkgctx) (syntax-object-expr stx))))

(define $expand-time-environment (make-fluid #f))
(define (current-expand-time-environment)
  (cell-ref (fluid $expand-time-environment)))
(define (transform-current-expand-time-environment! proc)
  (let ((cell (fluid $expand-time-environment)))
    (cell-set! cell
	       (proc (cell-ref cell)))))
(define (current-phase)
  (comp-env-phase (current-expand-time-environment)))

(define (free-identifier=? id1 id2)
  ;; (assert (identifier? id1))
  ;; (assert (identifier? id2))
  (let ((env (current-expand-time-environment)))
    (or (eq? id1 id2)
	(call-with-values
	    (lambda () (resolve+lookup id1 env))
	  (lambda (lbl1 l1)
	    (call-with-values
		(lambda () (resolve+lookup id2 env))
	      (lambda (lbl2 l2)
		(or (and (eq? l1 l2)
			 (or l1 (eq? lbl1 lbl2)))
		    (and (binding? l1)
			 (binding? l2)
			 (same-denotation? l1 l2))))))))))

