smalltalk-tng

view experiments/packrat-utils.scm @ 323:454c18798969

find changesets by author, revision, files, or words in the commit message
merger
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Tue Feb 07 11:34:20 2012 -0500 (3 months ago)
parents
children
line source
1 (require 'srfi-1)
2
3 (define (rule-matcher nonterminal)
4 (lambda (b) (eq? (car b) nonterminal)))
5
6 (define (list->lset = l)
7 (apply lset-adjoin = '() l))
8
9 (define nonterminal-firsts
10 (let ()
11 (define (rule-firsts rule)
12 (if rule
13 (list->lset eq? (map car (filter pair? (cdr rule))))
14 '()))
15
16 (lambda (nonterminal grammar)
17 (let loop ((seen '())
18 (work (list (rule-firsts (assq nonterminal grammar)))))
19 (if (null? work)
20 seen
21 (let ((firsts (car work))
22 (remaining-work (cdr work)))
23 (loop (apply lset-adjoin eq? seen firsts)
24 (fold (lambda (rule acc)
25 (if (memq rule seen)
26 acc
27 (let ((f (rule-firsts (assq rule grammar))))
28 (if (null? f)
29 acc
30 (cons f acc)))))
31 remaining-work
32 firsts))))))))
33
34 (define (rule-left-recursive? nonterminal grammar)
35 (if (memq nonterminal (nonterminal-firsts nonterminal grammar))
36 #t
37 #f))
38
39 (define (rule-degenerate? nonterminal terminals grammar)
40 (let ((firsts (nonterminal-firsts nonterminal grammar)))
41 (and (memq nonterminal firsts)
42 (null? (lset-intersection eq? terminals firsts)))))
43
44 (define (factor-left-recursion grammar)
45 (let* ((nonterminals (list->lset eq? (map car grammar)))
46 (allnames (apply lset-union eq? nonterminals (map cddr grammar)))
47 (terminals (lset-difference eq? allnames nonterminals))
48
49 (grammar (map (lambda (nonterminal)
50 (cons nonterminal
51 (map cddr (filter (rule-matcher nonterminal) grammar))))
52 nonterminals)))
53 (for-each (lambda (nonterminal)
54 (display "----------------------------------------")
55 (newline)
56 (display (list nonterminal '-->first (nonterminal-firsts nonterminal grammar)))
57 (newline)
58 (display (list nonterminal '-->rec (rule-left-recursive? nonterminal grammar)))
59 (newline)
60 (display (list nonterminal '-->degen
61 (rule-degenerate? nonterminal terminals grammar)))
62 (newline))
63 nonterminals)
64 'nothing))
65
66 (define g
67 (map butlast
68 '((toplevel --> expr dot toplevel (0 . 2))
69 (toplevel --> expr dot (0))
70 (toplevel --> expr (0))
71
72 (expr --> method-definition 0)
73 (expr --> nary 0)
74 (expr --> caret expr (reply 1))
75
76 (nary --> binary nary-args ,fixup-nary)
77 (nary --> binary)
78 (nary-args --> selector binary nary-args ((0 1) . 2))
79 (nary-args --> selector binary ((0 1)))
80
81 (binary --> binary binaryop unary (send 1 (0 2)))
82 (binary --> unary 0)
83 (binaryop --> punct 0)
84
85 (unary --> unary identifier (send 1 (0)))
86 (unary --> value 0)
87
88 (value --> simple-value 0)
89 (value --> oparen expr cparen 1)
90 (value --> oparen updates cparen (update #f 1))
91 (value --> oparen expr pipe updates cparen (update 1 3))
92
93 (simple-value --> identifier (ref 0))
94 (simple-value --> identifier oparen updates cparen stateful-block
95 (stateful-block 0 2 . 4))
96 (simple-value --> stateless-block 0)
97 (simple-value --> string (string 0))
98 (simple-value --> symbol (symbol 0))
99 (simple-value --> integer (number 0))
100
101 (updates --> update updates (0 . 1))
102 (updates --> update (0))
103 (update --> identifier colonequal value (0 2))
104
105 (stateful-block --> obrack binders stateful-expr-seq cbrack (1 2))
106 (stateful-expr-seq --> stateful-expr dot stateful-expr-seq (0 . 2))
107 (stateful-expr-seq --> stateful-expr (0))
108 (stateful-expr-seq --> ())
109 (stateful-expr --> identifier oparen updates cparen (loop 0 2))
110 (stateful-expr --> expr 0)
111
112 (stateless-block --> obrack binders expr-seq cbrack (block 1 2))
113 (expr-seq --> let-expr dot expr-seq (0 . 2))
114 (expr-seq --> let-expr (0))
115 (expr-seq --> ())
116 (let-expr --> identifier equal expr (let 0 2))
117 (let-expr --> expr 0)
118
119 (binders --> binders+ pipe 0)
120 (binders --> ())
121 (binders+ --> binder binders+ (0 . 1))
122 (binders+ --> binder (0))
123 (binder --> colon identifier 1)
124
125 (method-definition --> method-params obrack expr-seq cbrack (method 0 2))
126 (method-params --> method-param identifier (send 1 (0)))
127 (method-params --> method-param binaryop method-param (send 1 (0 2)))
128 (method-params --> method-param method-nary ,fixup-nary)
129 (method-param --> underscore at value (#f 2))
130 (method-param --> identifier at value (0 2))
131
132 (method-nary --> selector method-param method-nary ((0 1) . 2))
133 (method-nary --> selector method-param ((0 1)))
134 )))
135
136 (define g '((a --> d)
137 (a --> a d)
138 (b --> d)
139 (b --> b d)
140 (d --> e)
141 (e --> f d)
142 (e --> g)))
143
144 (define g '((t --> a m)
145 (t --> b n)
146 (a --> c)
147 (b --> c)
148 (c --> d)
149 (c --> a)))
150
151 (define g
152 (map butlast
153 '((sum --> sum + val ,(lambda (a b c) (+ a c)))
154 (sum --> val val ,(lambda (a b) a))
155 (val --> num ,(lambda (a) a)))))
156
157 (define g
158 (map butlast
159 '((sum --> val val sumk ,(lambda (a b k) (k a)))
160 (val --> num ,(lambda (a) a))
161 (sumk --> + val ,(lambda (b c) (lambda (a) (+ a c))))
162 (sumk --> ,(lambda () (lambda (a) a))))))
163
164 (pretty-print (factor-left-recursion g))
165 (exit)