(define-syntax rule
  (sc-macro-transformer
   (lambda (form env)
     (if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
	 (compile-rule (cadr form) (caddr form) (cadddr form) env)
	 (ill-formed-syntax form)))))

(define (compile-rule pattern restriction template env)
  (let ((names (pattern-names pattern)))
    `(rule:make ,(compile-pattern pattern env)
		,(compile-restriction restriction env names)
		,(compile-instantiator template env names))))

;;; These could be generic, but I am lazy today... GJS

(define (pattern-names pattern)
  (let loop ((pattern pattern) (names '()))
    (cond ((or (match:element? pattern)
	       (match:segment? pattern))
	   (let ((name (match:variable-name pattern)))
	     (if (memq name names)
		 names
		 (cons name names))))
	  ((list? pattern)
	   (let elt-loop ((elts pattern) (names names))
	     (if (pair? elts)
		 (elt-loop (cdr elts) (loop (car elts) names))
		 names)))
	  (else names))))

(define (compile-pattern pattern env)
  (let loop ((pattern pattern))
    (cond ((match:element? pattern)
	   (if (match:restricted? pattern)
	       `(match:element ',(match:variable-name pattern)
			       ,(match:restriction pattern))
	       `(match:element ',(match:variable-name pattern))))
	  ((match:segment? pattern)
	   `(match:segment ',(match:variable-name pattern)))
	  ((null? pattern)
	   `(match:eqv '()))
	  ((list? pattern)
	   `(match:list ,@(map loop pattern)))
	  (else
	   `(match:eqv ',pattern)))))


;;; These are repeated from match.scm

(define (match:element? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?)))

(define (match:segment? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '??)))

(define (match:variable-name pattern)
  (cadr pattern))


(define (match:restricted? pattern)
  (not (null? (cddr pattern))))

(define (match:restriction pattern)
  (caddr pattern))

;;; The restriction is a predicate that must be true for the rule to
;;; be applicable.  This is not the same as a variable element
;;; restriction.

(define (compile-restriction expr env names)
  (if (eq? expr 'none)
      `#f
      (make-lambda names env
	(lambda (env)
	  (close-syntax expr env)))))


(define (compile-instantiator skel env names)
  (make-lambda names env
    (lambda (env)
      (list 'quasiquote
	    (let ((wrap (lambda (expr) (close-syntax expr env))))
	      (let loop ((skel skel))
		(cond ((skel:element? skel)
		       (list 'unquote
			     (wrap (skel:element-expression skel))))
		      ((skel:segment? skel)
		       (list 'unquote-splicing
			     (wrap (skel:segment-expression skel))))
		      ((list? skel) (map loop skel))
		      (else skel))))))))

		       
(define (skel:constant? skeleton)
  (not (pair? skeleton)))


(define (skel:element? skeleton)
  (and (pair? skeleton)
       (eq? (car skeleton) '?)))

(define (skel:element-expression skeleton)
  (cadr skeleton))


(define (skel:segment? skeleton)
  (and (pair? skeleton)
       (eq? (car skeleton) '??)))

(define (skel:segment-expression skeleton)
  (cadr skeleton))

;; Magic!
(define (make-lambda bvl use-env generate-body)
  (capture-syntactic-environment
   (lambda (transform-env)
     (close-syntax `(,(close-syntax 'lambda transform-env)
		     ,bvl
		     ,(capture-syntactic-environment
		       (lambda (use-env*)
			 (close-syntax (generate-body use-env*)
				       transform-env))))
		   use-env))))

#|
;;; For example

(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
		   none
		   (+ (+ (? a) (? b)) (? c)) )
	    (the-environment)))
(rule:make
 (match:list
  (match:eqv (quote +))
  (match:element (quote a))
  (match:list (match:eqv (quote +))
              (match:element (quote b))
              (match:element (quote c))))
 #f
 (lambda (c b a)
   (list (quote +) (list (quote +) a b) c)))

(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
		   (> a 3)
		   (+ (+ (? a) (? b)) (? c)) )
	    (the-environment)))
(rule:make
 (match:list
  (match:eqv (quote +))
  (match:element (quote a))
  (match:list (match:eqv (quote +))
              (match:element (quote b))
              (match:element (quote c))))
 (lambda (c b a)
   (> a 3))
 (lambda (c b a)
   (list (quote +) (list (quote +) a b) c)))

|#