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

(define-usual-macro 'syntax-rules
  (lambda (here)
    (let ((let-stx (datum->syntax here 'let))
	  (let-syntax-stx (datum->syntax here 'let-syntax))
	  (quote-stx (datum->syntax here 'quote))
	  (code-quote-stx (datum->syntax here 'code-quote))
	  (unquote-stx (datum->syntax here 'unquote))
	  (quasiquote-stx (datum->syntax here 'quasiquote))
	  (ellipsis-stx (datum->syntax here '...))
	  (list-stx (datum->syntax here 'list))
	  (stx-cdr-stx (datum->syntax here 'stx-cdr))
	  (cond-stx (datum->syntax here 'cond))
	  (match?-stx (datum->syntax here 'match?))
	  (syntax-stx (datum->syntax here 'syntax))
	  (make-pattern-variable-stx (datum->syntax here 'make-pattern-variable))
	  (make-pattern-env-stx (datum->syntax here 'make-pattern-env))
	  (else-stx (datum->syntax here 'else))
	  (assertion-violation-stx (datum->syntax here 'assertion-violation))
	  (assq-stx (datum->syntax here 'assq))
	  (cdr-stx (datum->syntax here 'cdr))
	  (make-transformer/free-identifier=?-stx (datum->syntax here 'make-transformer/free-identifier=?)))

      (lambda (stx)

	;; returns
	;; - (list (list pattern template pattern-env))
	;; - pattern-env [for everything]
	(define (compile-rules)
	  (let* ((meat (stx-cdr stx))
		 (subkeywords (stx->list (stx-car meat))))
	    (let loop ((rules (stx-cdr meat)) 
		       (compiled '())
		       (pattern-env '())) ; alist pattern-variable -> name
	      (if (null? rules)
		  (values (reverse compiled) pattern-env)
		  (receive (c pattern-env)
		      (compile-rule (stx-car rules) subkeywords pattern-env)
		    (loop (stx-cdr rules)
			  (cons c compiled)
			  pattern-env))))))

	;; returns:
	;; - (list pattern template pattern-env)
	;; - pattern-env [for everything so far]
	(define (compile-rule rule subkeywords pattern-env-all)
	  (let ((pattern (stx-cdr (stx-car rule))) ; #### ignores the operator position
		(template (stx-car (stx-cdr rule))))

	    (if (not (stx-2list? rule))
		(syntax-violation 'syntax-rules "invalid rule" stx rule))

	    (receive (pattern pattern-env pattern-env-all)
		(compile-pattern pattern subkeywords pattern-env-all)
	      (values (list pattern template pattern-env) 
		      pattern-env-all))))

	;; The compiled pattern itself is a regular datum, except at the
	;; leaves, for identifiers, pattern variables, and ellipsis forms.
	
	;; Should we move to syntax objects, the use of vectors for pattern
	;; variables and ellipsis forms may become a problem.

	;; returns:
	;; - compiled pattern
	;; - local pattern env
	;; - pattern env with everything so far
	(define (compile-pattern the-pattern subkeywords pattern-env-before)
	  (let label ((pattern the-pattern) (pattern-env '()) (pattern-env-all pattern-env-before) (rank 0))
	    (cond
	     ((identifier? pattern)
	      (cond 
	       ((first (lambda (p)
			 (free-identifier=? pattern (car p)))
		       subkeywords)
		(values pattern pattern-env pattern-env-all))
	       ((lookup-pattern-variable pattern rank pattern-env)
		(syntax-violation 'syntax-rules "duplicate pattern variable" stx pattern))
	       ((lookup-pattern-variable pattern rank pattern-env-before)
		=> (lambda (p)
		     (values `(,unquote-stx ,(cdr p)) 
			     (cons p pattern-env)
			     pattern-env-all)))
	       (else
		(let ((var (make-pattern-variable pattern rank))
		      (name (car (generate-temporaries (list pattern)))))
		  (let ((p (cons var name)))
		  (values `(,unquote-stx ,name) 
			  (cons p pattern-env)
			  (cons p pattern-env-all)))))))
	     ((syntax? pattern)
	      (label (syntax-e pattern) pattern-env pattern-env-all rank))
	     ((vector? pattern)
	      (receive (patterns pattern-env pattern-env-all)
		  (label (vector->list pattern) pattern-env pattern-env-all rank)
		(values (make-vector-marker patterns)
			pattern-env
			pattern-env-all)))
	     ((not (pair? pattern))
	      (values pattern pattern-env pattern-env-all))
	     ((not (and (pair? (cdr pattern))
			(ellipsis? (stx-car (cdr pattern)))))
	      (receive (head pattern-env pattern-env-all)
		  (label (car pattern) pattern-env pattern-env-all rank)
		(receive (tail pattern-env pattern-env-all)
		    (label (cdr pattern) pattern-env pattern-env-all rank)
		  (values (cons head tail) pattern-env pattern-env-all))))
	     ;; ellipsis
	     ((null? (stx-cdr (cdr pattern)))
	      (receive (compiled ellipsis-pattern-env ellipsis-pattern-env-all)
		  (label (car pattern)
			 '() ; so as to get a clean ellipsis-pattern-env
			 pattern-env-all
			 (+ rank 1))
		(values (make-ellipsis-form compiled 
					    `(,unquote-stx 
					      (,list-stx ,@(map cdr ellipsis-pattern-env))))
			(merge-pattern-envs stx ellipsis-pattern-env pattern-env)
			ellipsis-pattern-env-all
			)))
	     (else
	      (syntax-violation 'compile-pattern "invalid syntax pattern" the-pattern pattern)))))

	(define (ellipsis? stx)
	  (and (identifier? stx)
	       (free-identifier=? stx ellipsis-stx)))

	(receive (rules pattern-env)
	    (compile-rules)
	  (let ((pattern-names (generate-temporaries rules)))
	    (datum->syntax
	       here
	       `(,let-stx 
		 ,(map (lambda (p)
			 `(,(cdr p)
			   (,quote-stx ,(car p)))) ; could be *anything*
		       pattern-env)
		 (,let-stx
		  ,(map (lambda (rule pattern-name)
			  `(,pattern-name (,quasiquote-stx ,(car rule))))
			rules pattern-names)
		  (,make-transformer/free-identifier=?-stx
		   (,syntax/lambda 
		    (input free-identifier=?)
		    (,let-stx ((body (,stx-cdr-stx input)))
			      (,cond-stx
			       ,@(map (lambda (pattern-name rule)
					(let* ((pattern-env (caddr rule))
					       (matched-names (generate-temporaries (map cdr pattern-env))))
					  `((,match?-stx ,pattern-name body free-identifier=?)
					    (,let-stx
					     ((penv (,make-pattern-env-stx ,pattern-name body)))
					     (,let-stx
					      ,(map (lambda (p name)
						      `(,name
							(,cdr-stx (,assq-stx ,(cdr p) penv))))
						    pattern-env matched-names)
					      (,let-syntax-stx 
					       ,(map (lambda (p name)
						       `(,(pattern-variable-name (car p))
							 (,make-pattern-variable-stx (,code-quote-stx ,name)
										     ,(pattern-variable-rank (car p)))))
						     pattern-env matched-names)
							    
					       (,syntax-stx ,(cadr rule))))))))
				      pattern-names rules)
			       (,else-stx
				(,assertion-violation-stx 'syntax-rules "none of the rules matched" input)))))))))))))))


(define-usual-macro 'syntax
  (lambda (here)
    (let ((ellipsis-stx (datum->syntax here '...))
	  (quote-stx (datum->syntax here 'quote))
	  (quasiquote-stx (datum->syntax here 'quasiquote))
	  (unquote-stx (datum->syntax here 'unquote))
	  (let-stx (datum->syntax here 'let))
	  (list-stx (datum->syntax here 'list))
	  (cons-stx (datum->syntax here 'cons))
	  (datum->syntax-stx (datum->syntax here 'datum->syntax))
	  (rewrite-stx (datum->syntax here 'rewrite)))

      (define (compile-template the-template)
	(let label ((template the-template)
		    (rank 0)
		    (referenced '())	; pattern variables referenced, 
					; like pattern-env, goes into ellipsis-template
		    (pattern-env '())) ; all pattern variables seen so far
	  (cond ((identifier? template)
		 (cond
		  ((syntax-local-value template)
		   => (lambda (patvar)
			(cond
			 ((not (pattern-variable? patvar))
			  (values template referenced pattern-env))
			 ((<= (pattern-variable-rank patvar)
			      rank)
			  (cond
			   ((lookup-pattern-variable (pattern-variable-name patvar) rank pattern-env)
			    => (lambda (p)
				 (values `(,unquote-stx ,(cdr p))
					 (if (lookup-pattern-variable (pattern-variable-name patvar)
								      rank referenced)
					     referenced
					     (cons p referenced))
					 pattern-env)))
			   (else
			    (let* ((name (car (generate-temporaries (list template))))
				   (p (cons patvar name)))
			      (values `(,unquote-stx  ,name)
				      (cons p referenced)
				      (cons p pattern-env))))))
			 (else
			  (syntax-violation 'compile-template
					    "invalid pattern variable rank"
					    the-template template)))))
		  (else
		   (values template referenced pattern-env))))
		((syntax? template)
		 (label (syntax-e template) rank referenced pattern-env))
		((vector? template)
		 (receive (templates referenced pattern-env)
		     (label (vector->list template) rank referenced pattern-env)
		   (values (make-vector-marker templates)
			   referenced
			   pattern-env)))
		((not (pair? template))
		 (values template referenced pattern-env))
		(else
		 (let ((count (count-ellipsis (cdr template) ellipsis?)))
		   (receive (head head-referenced pattern-env)
		       (label (car template)
			      (+ rank count)
			      '()
			      pattern-env)
		     (receive (tail referenced pattern-env)
			 (label (list-tail (stx->list (cdr template)) count)
				rank
				(union-pattern-envs head-referenced referenced)
				pattern-env)
		       (values (cons (make-ellipsis-template head
							     count
							     head-referenced
							     rank)
				     tail)
			       referenced
			       pattern-env))))))))
    
      (define (count-ellipsis template ellipsis?)
	(let loop ((template template) (count 0))
	  (if (and (pair? template)
		   (ellipsis? (car template)))
	      (loop (cdr template) (+ count 1))
	      count)))
      
      (define (ellipsis? stx)
	(and (identifier? stx)
	     (free-identifier=? stx ellipsis-stx)))

      (define (make-ellipsis-template template count referenced rank)
	(if (= count 0)
	    template
	    (let ((ellipsis-vars (filter (lambda (p)
					   (< rank
					      (pattern-variable-rank (car p))))
					 referenced)))
	      (if (null? ellipsis-vars)
		  (syntax-violation 'make-ellipsis-template
				    "invalid ellipsis rank"
				    template) ; #### more info
		  (do ((template template 
				 (make-ellipsis-form template 
						     `(,unquote-stx
						       (,list-stx ,@(map cdr ellipsis-vars)))))
		       (count count (- count 1)))
		      ((= count 0) 
		       template))))))

      (lambda (stx)
	(let ((template (stx-cadr stx))) ; #### error checking

	  (receive (compiled referenced pattern-env)
	      (compile-template template)

	    (datum->syntax
	     here
	     `(,datum->syntax-stx #f ; #### keeping fingers crossed
				 (,let-stx
				   ,(map (lambda (p)
					   `(,(cdr p)
					     (,quote-stx ,(car p)))) ; could be *anything*
					 referenced)
				   (,rewrite-stx
				    (,quasiquote-stx ,compiled)
				    (,list-stx 
				     ,@(map (lambda (p)
					      `(,cons-stx ,(cdr p)
							  ,(syntax-local-introduce (pattern-variable-name (car p)))))
					    referenced))))))))))))

; Utilities

(define (pattern-variable=? v1 v2)
  (and (= (pattern-variable-rank v1)
	  (pattern-variable-rank v2))
       (bound-identifier=? (pattern-variable-name v1)
			   (pattern-variable-name v2))))

(define (union-pattern-envs x y)
  (cond ((null? x)
         y)
        ((let ((var (caar x)))
	   (first (lambda (p)
		    (pattern-variable=? var (car p)))
		  y))
         (union-pattern-envs (cdr x) y))
        (else
         (union-pattern-envs (cdr x) (cons (car x) y)))))

; like append, with duplicate check
(define (merge-pattern-envs stx x y)
  (let loop ((x x) (y y))
    (if (null? x)
	y
	(let ((var (caar x)))
	  (for-each (lambda (p)
		      (if (pattern-variable=? var (car p))
			  (syntax-violation 'syntax-rules "duplicate pattern variable" 
					    stx (pattern-variable-name var))))
		    y)
	  (loop (cdr x) (cons (car x) y))))))

(define (lookup-pattern-variable v rank pattern-env)
  (first (lambda (p)
	   (and (= rank (pattern-variable-rank (car p)))
		(bound-identifier=? v (pattern-variable-name (car p)))))
	 pattern-env))
