(defun scheme-mbe-ellipsis? (x)
  (and (consp x) (consp (cdr x)) (eq (cadr x) '***)))

(defun scheme-mbe-matches-pattern? (p e k)
  (cond ((scheme-mbe-ellipsis? p)
         (if (not (= (list-length p) 2)) (error "bad ellipsis: ~a" p))
         (and (scheme-list? e)
              (let ((p0 (car p)))
                (every #'(lambda (e_i) (scheme-mbe-matches-pattern? p0 e_i k))
                       e))))
        ((consp p)
         (and (consp e) (scheme-mbe-matches-pattern? (car p) (car e) k)
              (scheme-mbe-matches-pattern? (cdr p) (cdr e) k)))
        ((scheme-symbol? p) (if (member p k) (eq p e) t))
        (t (equal p e))))

(defun scheme-mbe-get-ellipsis-nestings (p k)
  (labels ((sub (p)
             (cond ((scheme-mbe-ellipsis? p)
                    (cons (sub (car p)) (sub (cddr p))))
                   ((consp p) (nconc (sub (car p)) (sub (cdr p))))
                   ((scheme-symbol? p) (if (member p k) '() (list p)))
                   (t '()))))
    (sub p)))

(defun scheme-mbe-ellipsis-sub-envs (nestings r)
  (some #'(lambda (c)
            (if (scheme-mbe-intersect? nestings (car c)) (cdr c) nil))
        r))

(defun scheme-mbe-intersect? (v y)
  (if (or (scheme-symbol? v) (scheme-symbol? y))
      (eq v y)
    (some #'(lambda (v_i)
              (some #'(lambda (y_j) (scheme-mbe-intersect? v_i y_j)) y))
          v)))

(defun scheme-mbe-get-bindings (p e k)
  (cond ((scheme-mbe-ellipsis? p)
         (let ((p0 (car p)))
           (list (cons (scheme-mbe-get-ellipsis-nestings p0 k)
                       (mapcar #'(lambda (e_i)
                                   (scheme-mbe-get-bindings p0 e_i k))
                               e)))))
        ((consp p)
         (nconc (scheme-mbe-get-bindings (car p) (car e) k)
                (scheme-mbe-get-bindings (cdr p) (cdr e) k)))
        ((scheme-symbol? p) (if (member p k) '() (list (cons p e))))
        (t '())))

(defun scheme-mbe-expand-pattern (p r k)
  (cond ((scheme-mbe-ellipsis? p)
         (nconc (let* ((p0 (car p))
                       (nestings (scheme-mbe-get-ellipsis-nestings p0 k))
                       (rr (scheme-mbe-ellipsis-sub-envs nestings r)))
                  (mapcar #'(lambda (r_i)
                              (scheme-mbe-expand-pattern p0 (append r_i r) k))
                          rr))
                (scheme-mbe-expand-pattern (cddr p) r k)))
        ((consp p)
         (cons (scheme-mbe-expand-pattern (car p) r k)
               (scheme-mbe-expand-pattern (cdr p) r k)))
        ((scheme-symbol? p)
         (if (member p k) p (let ((x (assoc p r))) (if x (cdr x) p))))
        (t p)))

(defun scheme-mbe-syntax-rules-proc (macro-name kk cc arg-sym kk-sym)
  (let ((kk (cons macro-name kk)))
    `(let ((,arg-sym (cons ',macro-name ,arg-sym))
           (,kk-sym ',kk))
       (cond ,@(mapcar #'(lambda (c)
                           (let ((in-pat (car c)) (out-pat (cadr c)))
                             `((scheme-mbe-matches-pattern?
                                ',in-pat ,arg-sym ,kk-sym)
                               (let ((r (scheme-mbe-get-bindings ',in-pat
                                                                ,arg-sym
                                                                ,kk-sym)))
                                 ,(if (and (consp out-pat)
                                           (eq (car out-pat) 'with))
                                      `(scheme-mbe-expand-pattern
                                        ',(caddr out-pat)
                                        (nconc (list ,@(mapcar #'(lambda (w)
                                                                   `(cons ',(car w)
                                                                          ,(cadr w)))
                                                               (cadr out-pat)))
                                               r)
                                        ,kk-sym)
                                    `(scheme-mbe-expand-pattern ',out-pat r
                                                               ,kk-sym))))))
                       cc)
             (t (error "~a: no matching clause" ',macro-name))))))
