;;; Consider this crude little matcher:

(define (match p1 p2 dict)
  (cond ((variable? p1)
	 (bind (variable-name p1)
	       p2
	       dict))
	((and (pair? p1) (pair? p2))
	 (let ((dict
		(match (car p1)
		       (car p2)
		       dict)))
	   (if dict
	       (match (cdr p1)
		      (cdr p2)
		      dict)
	       #f)))
	((eqv? p1 p2) dict)
	(else #f)))

(define (bind var val dict)
  (let ((binding1 (lookup var dict)))
    (cond (binding1
	   (equal? (value binding1)
		   val
		   dict))
	  (else
	   (extend var val dict)))))

;;; Support for the dictionary.

(define (extend variable data-object dict)
  (cons (list variable data-object)
	dict))

(define (lookup variable dict)
  (assq variable dict))

(define (value vcell)
  (cadr vcell))


(define (variable? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '?)))

(define (variable-name pattern)
  (cadr pattern))

;;; Let's soup it up!  
;;; We compile each pattern into a procedure.

(define (explode-match p)
  `(lambda (expr dict)
     ,(let lp ((p p) (expr 'expr) (dict 'dict))
	(cond ((variable? p)
	       `(bind ,(variable-name p)
				    ,expr
				    ,dict))
	      ((pair? p)
	       `(if (pair? ,expr)
		    (let ((expr ,expr))
		      (let ((ndict
			     ,(lp (car p)
				  `(car expr)
				  dict)))
			(if ndict
			    ,(lp (cdr p)
				 `(cdr expr)
				 `ndict)
			    #f)))
		    #f))
	      (else
	       `(if (eqv? ,expr ',p)
		    ,dict
		    #f))))))

#|
;;; For example

(pp (explode-match `(a . b)))
(lambda (expr dict)
  (if (pair? expr)
      (let ((expr expr))
        (let ((ndict
	       (if (eqv? (car expr)
			 (quote a))
		   dict #f)))
          (if ndict
              (if (eqv? (cdr expr)
			(quote b))
                  ndict
                  #f)
              #f)))
      #f))

;;; But pretty gross...

(pp (explode-match `(a (? x) b)))
(lambda (expr dict)
  (if (pair? expr)
      (let ((expr expr))
        (let ((ndict
	       (if (eqv? (car expr) (quote a))
		   dict #f)))
          (if ndict
              (if (pair? (cdr expr))
                  (let ((expr (cdr expr)))
                    (let ((ndict
			   (bind x (car expr) ndict)))
                      (if ndict
                          (if (pair? (cdr expr))
                              (let ((expr (cdr expr)))
                                (let ((ndict
                                       (if (eqv? (car expr)
						 (quote b))
                                           ndict
                                           #f)))
                                  (if ndict
                                      (if (eqv? (cdr expr)
						(quote ()))
                                          ndict
                                          #f)
                                      #f)))
                              #f)
                          #f)))
                  #f)
              #f)))
      #f))
|#

#|
(pp
 (peephole-optimizer
  (explode-match `(a (? x) b))))
(lambda (expr dict)
  (and (pair? expr)
       (let ((ndict (and (eqv? (car expr) (quote a)) dict)))
         (and ndict
              (pair? (cdr expr))
              (let ((expr (cdr expr)))
                (let ((ndict (bind x (car expr) ndict)))
                  (and ndict
                       (pair? (cdr expr))
                       (let ((expr (cdr expr)))
                         (let ((ndict
				(and (eqv? (car expr) (quote b))
				     ndict)))
                           (and ndict
                                (null? (cdr expr))
                                ndict))))))))))
|#