smalltalk-tng

annotate experiments/unipat.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents
children
rev   line source
tonyg@233 1 ;; Unifying pattern-matching, parsing, and method dispatch
tonyg@233 2
tonyg@233 3 (define (alt p1 p2)
tonyg@233 4 (lambda (msg kt kf)
tonyg@233 5 (p1 msg
tonyg@233 6 kt
tonyg@233 7 (lambda () (p2 msg kt kf)))))
tonyg@233 8
tonyg@233 9 ;; { .foo (x, 2, y) -> .ok }
tonyg@233 10 ;;
tonyg@233 11 ;; seq(literal("foo"), seq(tuple(3, [bind(x, discard()), literal(2), bind(y, discard())]),
tonyg@233 12 ;; cut( ... )))
tonyg@233 13
tonyg@233 14 (define (p . xs)
tonyg@233 15 (write xs)
tonyg@233 16 (newline)
tonyg@233 17 (last xs))
tonyg@233 18
tonyg@233 19 (define (seq p1 p2)
tonyg@233 20 (lambda (msg kt kf)
tonyg@233 21 (p 'seq msg)
tonyg@233 22 (if (null? msg)
tonyg@233 23 (kt (seq p1 p2) msg)
tonyg@233 24 (p1 (car msg)
tonyg@233 25 (lambda (sv remainder) (p2 (cdr msg) kt kf))
tonyg@233 26 kf))))
tonyg@233 27
tonyg@233 28 (define (empty-seq)
tonyg@233 29 (literal '()))
tonyg@233 30
tonyg@233 31 (define (tuple n pats)
tonyg@233 32 (let ((tp (fold-right seq (empty-seq) pats)))
tonyg@233 33 (lambda (msg kt kf)
tonyg@233 34 (p `(tuple ,n) msg)
tonyg@233 35 (if (and (vector? msg)
tonyg@233 36 (= (vector-length msg) n))
tonyg@233 37 (tp (vector->list msg) kt kf)
tonyg@233 38 (kf)))))
tonyg@233 39
tonyg@233 40 (define (discard)
tonyg@233 41 (lambda (msg kt kf)
tonyg@233 42 (p 'discard msg)
tonyg@233 43 (kt msg '())))
tonyg@233 44
tonyg@233 45 (define (literal v)
tonyg@233 46 (lambda (msg kt kf)
tonyg@233 47 (p `(literal ,v) msg)
tonyg@233 48 (if (eqv? msg v)
tonyg@233 49 (kt msg '())
tonyg@233 50 (kf))))
tonyg@233 51
tonyg@233 52 (define (cut obj-producer-thunk)
tonyg@233 53 (lambda (msg kt kf)
tonyg@233 54 (p 'cut msg)
tonyg@233 55 (kt (obj-producer-thunk) msg)))
tonyg@233 56
tonyg@233 57 (define (fail)
tonyg@233 58 (lambda (msg kt kf)
tonyg@233 59 (p 'fail msg)
tonyg@233 60 (kf)))
tonyg@233 61
tonyg@233 62
tonyg@233 63 (define (feed parser msg)
tonyg@233 64 (parser msg
tonyg@233 65 (lambda (sv remainder)
tonyg@233 66 (p 'SUCCESS sv remainder)
tonyg@233 67 (if (null? remainder)
tonyg@233 68 'complete
tonyg@233 69 (feed sv remainder)))
tonyg@233 70 (lambda ()
tonyg@233 71 (p 'FAILURE)
tonyg@233 72 'incomplete)))
tonyg@233 73
tonyg@233 74
tonyg@233 75 ;; { .x -> { .y -> 1 } ;
tonyg@233 76 ;; .x -> { .z -> 2 } ;
tonyg@233 77 ;; .z -> { _ -> 3 } }
tonyg@233 78
tonyg@233 79 (define (t)
tonyg@233 80 (alt (seq (literal 'x) (cut (lambda () (seq (literal 'y) (cut (lambda () 1))))))
tonyg@233 81 (alt (seq (literal 'x) (cut (lambda () (seq (literal 'z) (cut (lambda () 2))))))
tonyg@233 82 (alt (seq (literal 'z) (cut (lambda () (seq (discard) (cut (lambda () 3))))))
tonyg@233 83 (fail)))))
tonyg@233 84
tonyg@233 85 ;; { .x .y -> 1 ;
tonyg@233 86 ;; .x .z -> 2 ;
tonyg@233 87 ;; .z _ -> 3 }
tonyg@233 88
tonyg@233 89 (define (t2)
tonyg@233 90 (alt (seq (literal 'x) (seq (literal 'y) (cut (lambda () 1))))
tonyg@233 91 (alt (seq (literal 'x) (seq (literal 'z) (cut (lambda () 2))))
tonyg@233 92 (alt (seq (literal 'z) (seq (discard) (cut (lambda () 3))))
tonyg@233 93 (fail)))))
tonyg@233 94
tonyg@233 95 (define (drive name parser msg)
tonyg@233 96 (p '------------DRIVE name msg)
tonyg@233 97 (p '--> (feed parser msg))
tonyg@233 98 (newline))
tonyg@233 99
tonyg@233 100 (define (drive4 name parser)
tonyg@233 101 (drive name parser '(x y))
tonyg@233 102 (drive name parser '(x z))
tonyg@233 103 (drive name parser '(x x))
tonyg@233 104 (drive name parser '(z z)))
tonyg@233 105
tonyg@233 106 (define (run)
tonyg@233 107 (drive4 't (t))
tonyg@233 108 (drive4 't2 (t2)))