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

; Transforms

; A transform represents a source-to-source rewrite rule: either a
; macro or an in-line procedure.

(define-record-type macro-transform :macro-transform
  (really-make-macro-transform xformer env id)
  macro-transform?
  (xformer   macro-transform-procedure)
  (env	     macro-transform-env)
  (id	     macro-transform-id))

(define-record-discloser :macro-transform
  (lambda (m) (list 'macro-transform (macro-transform-id m))))

(define (make-transform/macro thing env type id)
  (let ((type (if (or (pair? type)
		      (symbol? type))
		  (sexp->type type #t)
		  type)))
    (call-with-values
	(lambda ()
	  (if (pair? thing)		; #### obsolete
	      (values (car thing) (cdr thing))
	      (values thing #f)))
      (lambda (transformer aux-names)
	(make-immutable!
	 (really-make-macro-transform transformer env id))))))

; for backwards compatibility with the PreScheme compiler
(define (make-transform thing env type source id)
  (make-transform/macro thing env syntax-type id))

(define-record-type inline-transform :inline-transform
  (really-make-inline-transform xformer env type source id)
  inline-transform?
  (xformer   inline-transform-procedure)
  (env	     inline-transform-env)
  (type	     inline-transform-type)
  (source    inline-transform-source)    ;for reification
  (id	     inline-transform-id))

(define-record-discloser :inline-transform
  (lambda (m) (list 'inline-transform (inline-transform-id m))))

(define (make-transform/inline xformer env type source id)
  (make-immutable!
   (really-make-inline-transform xformer env type source id)))

; #### obsolete
; See also: Rees, "Implementing Lexically Scoped Macros",
; Lisp Pointers VI(1), January-March 1993
(define (maybe-apply-macro-transform transform exp parent-name env-of-use env-of-use-phase)
  (let* ((mrk (make-mark parent-name env-of-use-phase (macro-transform-env transform)))
	 (rename (make-name-generator mrk))
	 (compare (make-keyword-comparator env-of-use)))
    (values ((macro-transform-procedure transform) exp name? rename compare)
	    env-of-use)))

(define (apply-inline-transform transform exp parent-name)
  (let* ((env (inline-transform-env transform))
	 (rename (make-name-generator (make-mark parent-name 0 env))))
    ((inline-transform-procedure transform) exp env rename)))

; Two keywords are the same if:
;  - they really are the same
;  - neither one is bound and they have the same symbol in the source
;  - they are bound to the same denotation (macro or location or ...)

(define (make-keyword-comparator environment)
  (lambda (name1 name2)
    (or (eqv? name1 name2)
	(and (name? name1)	; why might they not be names?
	     (name? name2)
	     (let ((v1 (lookup environment name1))
		   (v2 (lookup environment name2)))
	       (if v1
		   (and v2 (same-denotation? v1 v2))
		   (and (not v2)
			(eq? (name->source-name name1)
			     (name->source-name name2)))))))))

; Generate names for bindings reached in MARK's ENV reached via MARK's
; IDENTIFIER.  The names are cached to preserve identity if they are
; bound.  MARK is used to identify names made by this generator.

(define (make-name-generator mark)
  (let ((alist '()))			;list of (symbol . generated)
    (lambda (name)
      (if (name? name)
	  (let ((probe (assq name alist)))
	    (if probe
		(cdr probe)
		(let ((new-name (add-mark name mark)))
		  (set! alist (cons (cons name new-name)
				    alist))
		  new-name)))
	  (assertion-violation 'make-name-generator
			       "non-name argument to rename procedure"
			       mark)))))

