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

; Names (symbols) and generated names.

(define (name? thing)
  (or (symbol? thing)
      (generated? thing)))

(define (generated? thing)
  (identifier? thing))

; When a macro generates a name, it attaches a mark to an identifier:
;
; The mark carries:
; - the identifier from which the macro was looked up
; - the macro's transform environment
; - the phase at which the macro lookup was performed
;   (This is needed because the transform environment is typically a
;   package that may not know the phase at which it was instantiated.)
; - a token corresponding to the macro-expansion step that performed
;   the renaming

(define (generate-name name parent-phase env parent-name)
  (add-mark name (make-mark parent-name parent-phase env)))
 
; Get the name that appeared in the source.

(define (name->source-name name)
  (if (syntax? name)
      (syntax-object-expr name)
      name))

(define (name->symbol name)
  (cond
   ((symbol? name) name)
   ((syntax? name)
    (string->symbol (apply string-append
			   (symbol->string (syntax-object-expr name))
			   (map (lambda (mrk)
				  (string-append "##"
						 (number->string (mark-uid mrk))))
				(syntax-object-marks name)))))
   (else
    (assertion-violation 'name->symbol "invalid name"))))

; Name tables: Not the most efficient way of doing it, but the
; interface is historical ...

(define (name-hash name)
  (cond ((symbol? name)
	 (symbol-hash name))
	((identifier name) => symbol-hash)
	(else
	 (assertion-violation 'name-hash "invalid name" name))))

(define (bound-name=? n1 n2)
  (or (eq? n1 n2)
      (and (syntax? n1) ; #### what if one is a symbol and the other is an identifier with no marks
	   (syntax? n2)
	   (eq? (syntax-object-expr n1) (syntax-object-expr n2))
	   (marks=? (syntax-object-marks n1) (syntax-object-marks n2)))))

(define make-name-table
  (make-table-maker bound-name=? name-hash))

; Used by QUOTE to turn generated names back into symbols

(define (desyntaxify thing)
  (cond ((or (boolean? thing) (null? thing) (number? thing)
	     (symbol? thing) (char? thing))
	 thing)
	((string? thing)
	 (make-immutable! thing))
	((syntax? thing)
	 (desyntaxify (syntax-object-expr thing)))
	((sym? thing)
	 (string->symbol (sym-pretty-string thing)))
	((pair? thing)
	 (make-immutable!
	  (cons (desyntaxify (car thing))
		(desyntaxify (cdr thing)))))
	((vector? thing)
	 (make-immutable! 
	  (let ((new (make-vector (vector-length thing) #f)))
	    (let loop ((i 0))
	      (if (>= i (vector-length thing))
		  new
		  (begin
		    (vector-set! new i (desyntaxify (vector-ref thing i)))
		    (loop (+ i 1))))))))
	(else
	 (warning 'desyntaxify "invalid datum in quotation" thing)
	 thing)))

