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

; Qualified names
; 
; A qualified name is an S-expression representation of a name: It's
; mainly the original name and its marks sans the environments, which
; can be reconstructed from the original names.

; This needs to evolve into general marshalling code for identifiers.
; Right now, it only handles the marks.

(define (make-qualified path name)
  (vector '>> path name))

(define (qualified? thing)
  (and (vector? thing)
       (= (vector-length thing) 3)))

(define (qualified-path q) (vector-ref q 1))
(define (qualified-symbol q) (vector-ref q 2))

; Each path element corresponds to a mark:
(define (path-element-phase el) (vector-ref el 0))
(define (path-element-name el) (vector-ref el 1))
(define (path-element-uid el) (vector-ref el 2))

(define (make-path-element phase name uid)
  (vector phase name uid))

; We expect the generated name's name (not the parent name) to be bound in env.

(define (name->qualified name)
  (if (syntax? name)
      (make-qualified (map context-element->path-element (syntax-object-marks name))
		      (syntax-object-expr name))
      name))

(define (context-element->path-element ctxe)
  (cond
   ((mark? ctxe)
    (make-path-element (mark-phase ctxe)
		       (name->qualified (mark-identifier ctxe))
		       (mark-uid ctxe)))
   (else
    (assertion-violation 'context-element->path-element "unhandled context element" ctxe))))

(define (binding-transform-env b)
  (let ((s (binding-static b)))
    (cond
     ((inline-transform? s)
      (inline-transform-env s))
     ((eq? s 'syntax)
      (macro-transform-env (contents (binding-place b))))
     (else #f))))

(define (qualified->name qualified env)
  (if (symbol? qualified)
      qualified
      (call-with-values
	  (lambda () (qualified->name+env qualified env (env-phase env)))
	(lambda (name env)
	  name))))

; returns identifier and its transform env
(define (qualified->name+env qualified env env-phase)
  (if (qualified? qualified)
      (let* ((symbol (qualified-symbol qualified))
	     (path (qualified-path qualified)))
	(if (null? path)
	    (values symbol (binding-transform-env (generic-lookup env symbol)))
	    (call-with-values
		(lambda () (path->marks+env path env env-phase))
	      (lambda (marks new-env new-env-phase)
		(values (add-context symbol marks) 
			(binding-transform-env 
			 (generic-lookup (env-bump-phase new-env (- env-phase new-env-phase)) symbol)))))))
      (values qualified 
	      (binding-transform-env (generic-lookup env qualified)))))

(define (path->marks+env path env env-phase)
  (let loop ((path path)
	     (env env)
	     (env-phase env-phase)
	     (marks '()))
    (if (null? path)
	(values (reverse marks) env env-phase)
	(let* ((pe (car path))
	       (pe-phase (path-element-phase pe)))
	  (call-with-values
	      (lambda ()
		(qualified->name+env (path-element-name pe)
				     (env-bump-phase env (- pe-phase env-phase)) 
				     pe-phase))
	    (lambda (name new-env)
	      (loop (cdr path) 
		    new-env
		    pe-phase
		    ;; #### FIXME: we compare marks via eq?, so we need
		    ;; to preserve mark identity
		    (cons (make-mark-with-uid name pe-phase new-env (path-element-uid pe))
			  marks))))))))

