[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Scheme pattern matcher

For those who would like to look at and perhaps try out a simple
match facility, here's mine.

The Scheme84 MATCH has a bit different syntax and a very different
implementation, due to Bruce Duba.  He uses Eugene's extend-syntax
in clever ways to compile MATCH expressions to conditional expressions
(rather than the interpretive approach I use).  It is available via
anonymous ftp as part of pub/scheme84/synstd.s on cs.indiana.edu.

;; match:  Chez Scheme pattern matching and destructuring facility.
;; 
;; Author:  Chris Haynes (haynes@cs.indiana.edu)
;;
;;
;; (match <exp> (<pattern> <body> ...) ...)
;; 
;; <pattern> ::= <variable>
;; 	    | <number> | <string> | <character> | <boolean> | (quote <datum>) 
;; 	    | #(<pattern> ...)
;; 	    | #&<pattern>                        ; Chez Scheme box (reference)
;; 	    | (? <predicate> <pattern>)
;; 	    | (<pattern> ...)
;; 	    | (<pattern> <pattern> ... . <pattern>)
;; 
;; MATCH is a fairly general pattern matching and destructuring
;; facility.  <exp> is evaluated and its value is matched against the
;; <pattern>s in order until a matching pattern is found.  An error is
;; signaled if no pattern matches.  When a match is found, the value
;; of <exp> is destructured with the variables in the matching pattern
;; bound to the corresponding components of <exp>'s value.  The <body>
;; expressions of the matching pair are then evaluated in an
;; environment formed by extending the environment of the MATCH
;; expression with these new bindings.  The value of the last <body>
;; expression is returned as the value of the MATCH expression.
;; 
;; The symbols QUOTE and ? are used in patterns to identify literals
;; and predicate tests, so they may not be used as pattern variables.
;; Number, string, boolean, character and quoted literal <datum>s must
;; be EQUAL? to corresponding components of <exp>s value, or the
;; pattern fails.  <predicate> expressions should evaluate (in the
;; environment of the MATCH expression) to unary functions that are
;; applied to the corresponding component of <exp>s value when
;; matching of the ? pattern is attempted.  If the predicate returns
;; false, the pattern fails.  Otherwise, the value applied to the
;; predicate is matched against the pattern following the predicate.
;; 
;; 
;; (match '(2 . 3) ((a . b) (* a b)))  ==>  6
;; 
;; (match '(1 2) ((a) a) ((a b) (+ a b)) (c c))  ==>  3
;; 
;; (match (list 33 "string" #\c (not #t) #(1 2)) 
;;   ((33 "string" #\c #f #(a b)) (cons a b)))  ==>  (1 . 2)
;; 
;; (let ((num 3))
;;   (match (cons 'x 4)
;;     (((? (lambda (v) (or (symbol? v) (and (number? v) (= v num)))) 
;; 	 c)
;;       . (? number? d)) (list c d))))  ==>  (x 4)
;; 
;; (match '(bar 3 4 5)
;;   (('foo x y) (cons x y))
;;   (('bar x y . z) (list x y z))
;;   (else (error "didn't match: " else)))  ==>  (3 4 (5))
;; 

(define matcher 
  (lambda (exp pairs-info)
    (if (null? pairs-info)
	(error 'match "no pattern for: ~s" exp)
	(let ((pat (caar pairs-info))
	      (fn (cadar pairs-info))
	      (preds (cddar pairs-info))
	      (fail (lambda () (matcher exp (cdr pairs-info)))))
	  (let loop ((exp exp) 
		     (pat pat)
		     (succeed (lambda (args) (apply fn args))))
	    (cond
	     ((or (null? pat) (number? pat) (char? pat) 
		  (string? pat) (boolean? pat))
	      (if (equal? pat exp) (succeed '()) (fail)))
	     ((symbol? pat) (succeed (list exp)))
	     ((box? pat)
	      (if (box? exp)
		  (loop (unbox exp) (unbox pat) succeed)
		  (fail)))
	     ((vector? pat)
	      (if (vector? exp)
		  (let ((len (vector-length pat)))
		    (if (= len (vector-length exp))
			(let inner ((n 0) (args '()))
			  (if (= n len)
			      (succeed args)
			      (loop (vector-ref exp n)
				    (vector-ref pat n)
				    (lambda (car-args)
				      (inner (+ 1 n) 
					     (append! args car-args))))))
			(fail)))
		  (fail)))
	     ((eq? (car pat) 'quote) 
	      (if (equal? (cadr pat) exp) (succeed '()) (fail)))
	     ((eq? (car pat) '?)
	      (if ((car preds) exp)
		  (begin (set! preds (cdr preds))
			 (loop exp (caddr pat) succeed))
		  (fail)))
	     ((pair? exp) 
	      (loop (car exp) (car pat)
		    (lambda (car-args)
		      (loop (cdr exp)
			    (cdr pat)
			    (lambda (cdr-args)
			      (succeed (append! car-args 
						cdr-args)))))))
	     (else (fail))))))))
  
(define-macro! match (exp . pairs)
  (let ((ids&preds-of
	 (lambda (pat)
	   (let* ((preds '())
		  (ids (let loop ((pat pat))
			 (cond
			  ((or (null? pat) (number? pat) (char? pat) 
			       (string? pat) (boolean? pat))
			   '())
			  ((symbol? pat) (list pat))
			  ((box? pat) (loop (unbox pat)))
			  ((vector? pat) (loop (vector->list pat)))
			  ((eq? (car pat) 'quote) '())
			  ((eq? (car pat) '?)
			   (set! preds (cons (cadr pat) preds))
			   (loop (caddr pat)))
			  (else
			   (let ((cdrids (loop (cdr pat))))
			     (append! (loop (car pat)) cdrids)))))))
	     (cons ids preds)))))
    `(matcher
      ,exp
      (list . ,(map (lambda (pair)
		      (let ((pattern (car pair))
			    (body (cdr pair)))
			(let ((ids&preds (ids&preds-of pattern)))
			  `(cons ',pattern 
				 (cons (lambda ,(car ids&preds) . ,body)
				       (list . ,(cdr ids&preds)))))))
		    pairs)))))