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

; We compile each rule into a pattern and template which are then used at
; expansion time.  The compiler performs error checking, replaces pattern
; variables and ellipses with markers, and lists the introduced variables.
;
; Expansion is done in three steps:
;  - see if the pattern matches
;  - build the pattern-variable environment
;  - instantiate the template
; We could match the pattern and build the environment in a single pass, but
; separating them is simpler and may be faster for complex macros, as it
; avoids creating partial environments which are then discarded when the
; match fails.
;
; This would all be simple if it weren't for the ellipses.
;
; RANK is the ellipsis depth, initially zero.

;----------------------------------------------------------------
; This is the expansion part.  All it shares with the definition part
; is the format of the patterns and templates.

(define (match? pattern stx free-identifier=?)
  (let label ((pattern pattern) (stx stx))
    (cond ((pair? pattern)
           (and (stx-pair? stx)
                (label (car pattern) (stx-car stx))
                (label (cdr pattern) (stx-cdr stx))))
          ((identifier? pattern)
           (and (identifier? stx)
		(free-identifier=? pattern stx)))
          ((pattern-variable? pattern)
           #t)
          ((ellipsis-form? pattern)
           (let loop ((stx stx))
             (or (stx-null? stx)
                 (and (stx-pair? stx)
                      (label (ellipsis-form-body pattern) (stx-car stx))
                      (loop (stx-cdr stx))))))
          ((vector-marker? pattern)
	   (cond
	    ((stx-vector stx)
	     => (lambda (vec)
		  (label (vector-marker-contents pattern)
			 (vector->list vec))))
	    (else #f)))
          (else
           (equal? pattern (syntax->datum stx))))))
                           
(define (make-pattern-env pattern stx)
  (let label ((pattern pattern) (stx stx) (pattern-env '()))
    (cond ((pair? pattern)
           (label (cdr pattern)
                  (stx-cdr stx)
                  (label (car pattern) (stx-car stx) pattern-env)))
          ((pattern-variable? pattern)
           (cons (cons pattern stx)
                 pattern-env))
          ((ellipsis-form? pattern)
           (let ((envs (map (lambda (stx)
                              (label (ellipsis-form-body pattern)
                                     stx
                                     '()))
                            (stx->list stx))))
             (append (map (lambda (var)
                            (cons var
                                  (map (lambda (env)
                                         (cdr (assq var env)))
                                       envs)))
                          (ellipsis-form-vars pattern))
                     pattern-env)))
          ((vector-marker? pattern)
           (label (vector-marker-contents pattern)
                  (vector->list (stx-vector stx))
                  pattern-env))
          (else
           pattern-env))))

(define (rewrite template pattern-env)
  (let label ((template template) (pattern-env pattern-env))
    (cond ((null? template)
           '())
          ((pair? template)
           ((if (ellipsis-form? (car template))
                append
                cons)
            (label (car template) pattern-env)
            (label (cdr template) pattern-env)))
          ((identifier? template)
	   template)
          ((pattern-variable? template)
           (cdr (assq template pattern-env)))
          ((ellipsis-form? template)
           (rewrite-ellipsis label template pattern-env))
          ((vector-marker? template)
           (list->vector (label (vector-marker-contents template)
                                pattern-env)))
          (else
           template))))
  
(define (rewrite-ellipsis label template pattern-env)
  (let ((template (ellipsis-form-body template))
        (vars     (ellipsis-form-vars template)))
    (let ((vals (map (lambda (var)
                       (reverse (cdr (assq var pattern-env))))
                     vars)))
      (if (or (null? (cdr vals))
              (apply = (map length vals)))
          (let loop ((vals vals) (results '()))
            (if (null? (car vals))
                results
                (loop (map cdr vals)
                      ((if (ellipsis-form? template)
                           append
                           cons)
                       (label template
                              (append (map (lambda (var vals)
                                             (cons var (car vals)))
                                           vars
                                           vals)
                                      pattern-env))
                       results))))
	  (assertion-violation 'syntax-rules "ellipses don't match" template)))))
