;; Syntax patterns *would* be defined as a variant type, except for
;; the fact that they appear as literal data in the expansion of
;; syntax-case forms. I suppose we could automatically convert a
;; syntax-pattern into an equivalent constructor parsed-expression,
;; but it would certainly be verbose...

;; <syntax-pattern>	::==	#(any <identifier>)	| any
;;			|	#(key <identifier>)
;;			|	#(atom <value>)
;;			|	(<syntax-pattern> . <syntax-pattern>)
;;			|	#(list-of <syntax-pattern>)
;;			|	#(vector <syntax-pattern>)
;;
;; Future: support patterns like (((bar) ()) ... (() (foo)) ... . zot)
;; (ie, with something following the ellipsis)

(define (ellipsis? x)
  (free-identifier=? x '...))

(define (syntax-pattern-kind x) (vector-ref x 0))
(define (syntax-pattern-arg x) (vector-ref x 1))

(define (stx->syntax-pattern keys stx)
  (let walk ((stx stx))
    (let ((sexp (expose stx)))
      (cond
       ((pair? sexp)
	(let ((rest (expose (cdr sexp))))
	  (if (and (pair? rest)
		   (ellipsis? (car rest)))
	      (if (not (syntax-null? (cdr rest)))
		  (syntax-error "Ellipsis must not be followed by any pattern" stx)
		  `#(list-of ,(walk (car sexp))))
	      (cons (walk (car sexp)) (walk (cdr sexp))))))
       ((vector? sexp)
	`#(vector ,(walk (vector->list sexp))))
       ((symbol? sexp)
	(if (find (lambda (x) (bound-identifier=? x stx)) keys)
	    `#(key ,stx)
	    `#(any ,stx)))
       (else
	`#(atom ,(syntax-object->datum stx)))))))

(define (syntax-pattern-result-levels pat)
  (if (pair? pat)
      (append (syntax-pattern-result-levels (car pat))
	      (syntax-pattern-result-levels (cdr pat)))
      (case (syntax-pattern-kind pat)
	((any) `((,(syntax-pattern-arg pat) 0)))
	((key atom) '())
	((list-of) (map (lambda (x) `(,(car x) ,(+ (cadr x) 1)))
			(syntax-pattern-result-levels (syntax-pattern-arg pat))))
	((vector) (syntax-pattern-result-levels (syntax-pattern-arg pat)))
	(else (error "Illegal syntax-pattern in syntax-pattern-result-levels" pat)))))

(define (syntax-pattern-strip pat)
  (if (pair? pat)
      (cons (syntax-pattern-strip (car pat))
	    (syntax-pattern-strip (cdr pat)))
      (case (syntax-pattern-kind pat)
	((any) 'any)
	((key atom) pat)
	((list-of vector) `#(,(syntax-pattern-kind pat)
			     ,(syntax-pattern-strip (syntax-pattern-arg pat))))
	(else (error "Illegal syntax-pattern in syntax-pattern-strip" pat)))))

(define (syntax-pattern-result-count pat)
  (cond
   ((pair? pat)
    (+ (syntax-pattern-result-count (car pat))
       (syntax-pattern-result-count (cdr pat))))
   ((eq? pat 'any) 1)
   (else (case (syntax-pattern-kind pat)
	   ((any) (error "Syntax pattern must be stripped for processing by syntax-dispatch"
			 pat))
	   ((key atom) 0)
	   ((list-of vector) (syntax-pattern-result-count (syntax-pattern-arg pat)))
	   (else (error "Illegal syntax-pattern in syntax-pattern-result-count" pat))))))

(define (transpose-syntax-dispatch-matches matches)
  (do ((matches matches (map cdr matches))
       (acc '() (cons (map car matches) acc)))
      ((null? (car matches)) (reverse acc))))

(define (syntax-dispatch stx pat)
  (cond
   ((pair? pat)
    (syntax-pair-fields stx
      (lambda (a d) (let ((ma (syntax-dispatch a (car pat)))
			  (md (syntax-dispatch d (cdr pat))))
		      (and ma md (append ma md))))
      (lambda (_) #f)))
   ((eq? pat 'any) (list stx))
   (else (case (syntax-pattern-kind pat)
	   ((any) (error "Syntax pattern must be stripped for processing by syntax-dispatch"
			 pat))
	   ((key) (if (free-identifier=? (syntax-pattern-arg pat) stx)
		      '()
		      #f))
	   ((atom) (if (equal? (syntax-pattern-arg pat) (syntax-object->datum stx))
		       '()
		       #f))
	   ((list-of) (let ((pattern (syntax-pattern-arg pat)))
			(let ((stxs (syntax->list stx)))
			  (and (list? stxs)
			       (if (null? stxs)
				   (make-list (syntax-pattern-result-count pattern) '())
				   (let loop ((stxs stxs)
					      (reversed-matches '()))
				     (if (null? stxs)
					 (transpose-syntax-dispatch-matches
					  (reverse reversed-matches))
					 (let ((m (syntax-dispatch (car stxs) pattern)))
					   (and m (loop (cdr stxs)
							(cons m reversed-matches)))))))))))
	   ((vector) (let ((exp (expose stx)))
		       (and (vector? exp)
			    (syntax-dispatch (vector->list exp)
					     (syntax-pattern-arg pat)))))
	   (else (error "Illegal syntax-pattern in syntax-dispatch" pat))))))