s c h e m a t i c s : c o o k b o o k

/ Cookbook.MacroExampleASimplePatternMatcher

This Web


WebHome 
WebChanges 
TOC (with recipes)
NewRecipe 
WebTopicList 
WebStatistics 

Other Webs


Chicken
Cookbook
Erlang
Know
Main
Plugins
Sandbox
Scm
TWiki  

Schematics


Schematics Home
Sourceforge Page
SchemeWiki.org
Original Cookbook
RSS

Scheme Links


Schemers.org
Scheme FAQ
R5RS
SRFIs
Scheme Cross Reference
PLT Scheme SISC
Scheme48 SCM
MIT Scheme scsh
JScheme Kawa
Chicken Guile
Bigloo Tiny
Gambit LispMe
GaucheChez

Lambda the Ultimate
TWiki.org

Macro Example: A simple pattern matcher

Problem

Write a simple pattern matcher with syntax-rules.

Solution

The following is a very na´ve implementation of a subset of the pattern matcher used in PLT Scheme. It is not meant to be used instead of (lib "match.ss"), but rather to show how syntax-rules can be used in an example of medium size.

;; jas-match.scm

;;; NOTE

;  Uncomment match-define-values and match-define-values-helper,
;  if your Scheme doesn't support define-values.

;;; INSTRUCTIONS OF USE

; The user macros are
;    (match expr (pattern <guard> expr) ...)    , <guard> can be omitted
;    (match-lambda (pattern expr ...) ...)
;    (match-let ((pattern expr) ...) expr ...)
;    (match-let* ((pattern expr) ...) expr ...)

; The syntax of patterns are a subset of the one in:
;     <http://download.plt-scheme.org/scheme/plt-clean-cvs/collects/mzlib/plt-match.ss>

; The semantics of the match functions are explained in
;     <http://download.plt-scheme.org/scheme/docs/html/mzlib/mzlib-Z-H-22.html#node_chap_22>

; Notably features missing:
;   - quasi-patterns
;   - set! and get!
;   - match-define
;   - match-letrec
;   - the ooo and ook extension in list and vector patterns
;   - structures (easily added but they are non portable)

;;; IMPLEMENTATION

; The implementation is divided into layers, each layer
; handles one aspect of the pattern matching process.

; The main macro from the user perspective is the match macro.
;   (match expr [(pattern expr ...) ...])
; which binds the value to be matched to a variable, and leaves
; the real work to guarded match. Match also handles the case
; of multple patterns.

; The macro guarded-match
;    (guarded-match var pattern success failure)
; expands to success if the value bound to var matches the pattern,
; otherwise it expands to failure.
; Guarded-match takes care of guards and then macro calls logical-match.

; The macro logical-match
;    (logical-match var pattern success failure)
; expands to success if the value bound to var matches the pattern,
; otherwise it expands to failure.
; Logical-match takes care of patterns of the form
;   (and pattern ...)
;   (or  pattern ...)
;   (not pattern pattern ...)
;   (?   expr pattern ...)
; and then macro calls compound-match.

; The macro compound-match
;    (compound-match var pattern success failure)
; expands to success if the value bound to var matches the pattern,
; otherwise it expands to failure.
; Compound-match takes care of patterns of the form
;   (cons pattern pattern)
;   (list pattern ...)
;   (list-rest pattern ... pattern)
;   (vector pattern pattern ...)
;   (app expr pattern)
; and then macro calls simple-match.

; The macro simple-match
;    (simple-match var pattern success failure)
; expands to success if the value bound to var matches the pattern,
; otherwise it expands to failure.
; Simple-match takes care of patterns of the form
;   (quote symbol)
;   (quote datum)
;   pattern-var
;   literal
; and possible macro calls literal-match.

; The macro literal-match
;    (literal-match var pattern success failure)
; expands to success if the value bound to var matches the pattern,
; otherwise it expands to failure.
; Literal-match takes care of patterns of atoms of the form
;   the empty list
;   booleans
;   strings
;   numbers
;   characters
; and compound literals.

(define-syntax symbol??
  ;; From Oleg's "How to write symbol? with syntax-rules.
  ;; <http://okmij.org/ftp/Scheme/macro-symbol-p.txt>
  (syntax-rules ()
    ((symbol?? (x . y) kt kf) kf)   ; It's a pair, not a symbol
    ((symbol?? #(x ...) kt kf) kf)   ; It's a vector, not a symbol
    ((symbol?? maybe-symbol kt kf)
     (let-syntax
         ((test
      (syntax-rules ()
        ((test maybe-symbol t f) t)
        ((test x t f) f))))
       (test abracadabra kt kf)))))

(define (literal? datum)
  (or (string? datum)
      (number? datum)
      (char? datum)
      (null? datum)
      (boolean? datum)))


(define-syntax literal-match
  (syntax-rules ()
    [(_ var () success failure)        (if (null? var)  success failure)]
    [(_ var #t success failure)        (if (eq? var #t) success failure)]
    [(_ var #f success failure)        (if (eq? var #f) success failure)]
    [(_ var literal success failure)   (if (and (literal? var)
                                               (equal? var literal))
                                          success
                                          failure)]))

(define-syntax simple-match
  ; (simple-match var pattern success failure)
  ;     If the value bound to var matches pattern then the
  ;     expression expands into a let binding the pattern variables
  ;     in the pattern to the matched (sub)values, success becomes the
  ;     body of the let. Otherwise the macro call expands to failure.
  (syntax-rules (quote)
    [(_ var (quote symbol/datum)     success failure)  (if ((symbol?? symbol/datum eq? equal?) var 'symbol/datum)
                                                          success 
                                                          failure)]
    [(_ var name/literal             success failure)  (symbol?? name/literal
                                                                ; pattern variable
                                                                (let ([name/literal var])
                                                                  success)
                                                                ; literal
                                                                (literal-match var name/literal success failure))]))

(define-syntax compound-match 
  (syntax-rules (cons list list-rest app vector)
    [(_ var (cons p1 p2)            success failure)   (let ([failure-thunk (lambda () failure)])
                                                         ; Note: Converting failure to a failure thunk
                                                         ;       considerably reduces the size if the
                                                         ;       exapnded code
                                                         ;      (at the cost of generating closures at runtime)
                                                         (if (pair? var)
                                                             (match (car var)
                                                               [p1 (match (cdr var) 
                                                                     [p2 success] 
                                                                     [_ (failure-thunk)])]
                                                               [_  (failure-thunk)])
                                                             (failure-thunk)))]
    
    [(_ var (list)                   success failure)  (compound-match var () success failure)]
    [(_ var (list p1)                success failure)  (compound-match var (cons p1 ()) success failure)]
    [(_ var (list p1 p2 ...)         success failure)  (compound-match var (cons p1 (list p2 ...)) success failure)]
    
    [(_ var (vector p1 ...)          success failure)  (let ([vector-var (if (vector? var)
                                                                             (vector->list var)
                                                                             'failed-vector-match)])
                                                         (compound-match vector-var (list p1 ...) success failure))]
    
    [(_ var (list-rest p1 p2)        success failure)  (compound-match var (cons p1 p2) success failure)]
    [(_ var (list-rest p1 p2 p3 ...) success failure)  (compound-match var (cons p1 (list-rest p2 p3 ...)) 
                                                                       success failure)]
    
    [(_ var (app expr p1)            success failure)  (let ([new-var (expr var)])
                                                        (match new-var p1 success failure))]
    [(_ var pattern          success failure)  (simple-match var pattern success failure)]))


(define-syntax logical-match 
  (syntax-rules (and or not ?)
    [(_ var (and)            success failure)  success]
    [(_ var (and p1)         success failure)  (compound-match var p1 success failure)]
    [(_ var (and p1 p2 ...)  success failure)  (compound-match var p1 
                                                              (logical-match var (and p2 ...) success failure)
                                                              failure)]

    [(_ var (or p1)          success failure)  (compound-match var p1 success failure)]
    [(_ var (or p1 p2 ...)   success failure)  (compound-match var p1 success 
                                                              (logical-match var (or p2 ...) success failure))]
    
    [(_ var (not p)          success failure)  (logical-match var p failure success)]
    [(_ var (not p1 p2 ...)  success failure)  (logical-match var (and (not p1) (not p2) ...) failure success)]
    
    [(_ var (? expr p ...)   success failure)  (if expr
                                                  (logical-match var (and p ...) success failure)
                                                  failure)]

    [(_ var pattern          success failure)  (compound-match var pattern success failure)]))


(define-syntax guarded-match
  (syntax-rules ()
    [(_ var pattern success failure)          (logical-match var pattern success failure)]
    [(_ var pattern guard success failure)    (guarded-match var pattern (if guard success failure) failure)]))


(define-syntax match
  (syntax-rules ()
    [(_ expr)                                  (let ([v expr])
                                                 'no-match)]
    [(_ expr [pattern template]
             clauses ...)                      (let ([v expr])
                                                 (guarded-match v pattern
                                                                template
                                                                (match v clauses ...)))]
    [(_ expr [pattern guard template]
             clauses ...)                      (let ([v expr])
                                                 (guarded-match v pattern guard
                                                                template
                                                                (match v clauses ...)))]))

(define-syntax match-lambda
  (syntax-rules ()
    [(_ (pat expr ...) ...)         (lambda (x) (match x (pat expr ...) ...))]))

(define-syntax match-lambda*
  (syntax-rules ()
    [(_ (pat expr ...) ...)         (lambda x   (match x (pat expr ...) ...))]))

(define-syntax match-let*
  (syntax-rules ()
    [(_ () body ...)                                (let () body ...)]
    [(_ ((pat expr)) body ...)                      ((match-lambda (pat body ...)) expr)]
    [(_ ((pat expr) (pat2 expr2) ...) body ...)     (match-let* ([pat expr])
                                                      (match-let* 
                                                          ((pat2 expr2) ...) 
                                                        body ...))]))

(define-syntax match-let 
  (syntax-rules ()
    [(_ () body ...)               (let () body ...)]
    [(_ ((pat expr) ...) body ...) (match-let* ([(list pat ...) (list expr ...)]) body ...)]))


(define-syntax match-define-values-helper
  (syntax-rules ()
    [(_ (id ...) (pat) (expr))                   (match expr
                                                   [pat  (values id ...)])]
    [(_ (id ...) (pat . pats) (expr . exprs))    (match expr
                                                   [pat  (values id ...)]
                                                   [else (match-define-values-helper (id ...) pats exprs)])]))

(define-syntax match-define-values
  (syntax-rules ()
    [(_ (id ...) [pat expr])                   (define-values (id ...)
                                                 (match-define-values-helper (id ...) (pat) (expr)))]
    [(_ (id ...) [pat expr] ...)               (define-values (id ...)
                                                 (match-define-values-helper (id ...) (pat ...) (expr ...)))]))

;;;
;;; TEST
;;;

(define-syntax test-simple 
  (syntax-rules ()
    [(_ value pattern success failure) (let ([test-simple-var value])
                                        (simple-match test-simple-var pattern success failure))]))
'SIMPLE
(test-simple '() () 'ok 'fail)
(test-simple 1 1 'ok 'fail)
(test-simple 1 2 'fail 'ok)
(test-simple 'foo 'foo 'ok 'fail)
(test-simple 'foo 'bar 'fail 'ok)

(define-syntax test-compound 
  (syntax-rules ()
    [(_ value pattern success failure) (let ([test-compund-var value])
                                        (compound-match test-compund-var pattern success failure))]))
'COMPOUND
(test-compound (cons 1 "foo") (cons 1 "foo") 'ok 'fail)
(test-compound (cons 1 2) (cons a b) (if (= a 1) 'ok 'fail1) 'fail2)
(test-compound (list 1 2 3) (list a b c) (if (= (+ a b c) 6) 'ok 'fail1) 'fail2)
(test-compound (vector 1 2 3) (vector a b c) (if (= (+ a b c) 6) 'ok 'fail1) 'fail2)


(define-syntax test-logical 
  (syntax-rules ()
    [(_ value pattern success failure) (let ([test-logical-var value])
                                        (logical-match test-logical-var pattern success failure))]))

'LOGICAL
(test-logical (cons 1 2) 
              (and (cons a b) (cons 1 c) (cons d 2))
              (if (equal? (list a b c d)
                          (list 1 2 2 1))
                  'ok
                  'fail1)
              'fail2)
(test-logical (cons 1 2) 
              (or 1 "foo" (cons 1 3) (cons 1 2) #\c)
              'ok
              'fail)
(test-logical (cons 1 2)
              (not (cons a b))
              'fail
              'ok)
(test-logical (cons 1 2)
              (not (cons a b))
              'fail
              'ok)
(test-logical (cons 1 2)
              (not 1 2 "foo" (cons 3 4))
              'ok
              'fail)
'GUARDED
(guarded-match (cons 42 2) (cons a b) (even? a) 'ok   'fail)
(guarded-match (cons 43 2) (cons a b) (even? a) 'fail 'ok)

'FULL
(match (cons 1 2)
           [()         'empty]
           [(cons 1 b) (if (= b 2) 'ok 'fail)])

(match (cons 1 (cons 2 3))
            [()         'empty]
            [(cons 1 (cons 2 b)) (if (= b 3) 'ok 'fail)])

(match 'foo
            ['foo 'ok]
            [else 'fail])
(match 'foo
            ['bar 'fail]
            [else 'ok])


'MATCH-LET*
(match-let* ([(list x y z)    (list 1 2 3)]
             [(vector a b c)  (vector 4 5 6)])
  (if (= (+ x y z a b c) 21)
      'ok
      'fail))

(match-let* ([(list x y)    (list 1 2)]
            [(vector a b)   (vector 3 x)])
  (if (= (+ x y a b) 7)
      'ok
      'fail))

'MATCH-LET
(match-let ([(list x y z)    (list 1 2 3)]
            [(vector a b c)  (vector 4 5 6)])
  (if (= (+ x y z a b c) 21)
      'ok
      'fail))


'MATCH-DEFINE-VALUES
(match-define-values (x y z)
                     [(vector x (list y z))  (list 1 (list 2 3))]
                     [(list x (list y z))    (list 1 (list 2 3))])

(list x y z)

Discussion


Comments about this recipe

Contributors

-- JensAxelSoegaard - 23 May 2007

CookbookForm
TopicType: Other
ParentTopic:
TopicOrder: 999

 
 
Copyright © 2004 by the contributing authors. All material on the Schematics Cookbook web site is the property of the contributing authors.
The copyright for certain compilations of material taken from this website is held by the SchematicsEditorsGroup - see ContributorAgreement & LGPL.
Other than such compilations, this material can be redistributed and/or modified under the terms of the GNU Lesser General Public License (LGPL), version 2.1, as published by the Free Software Foundation.
Ideas, requests, problems regarding Schematics Cookbook? Send feedback.
/ You are Main.guest