-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathcompile-peg.l
171 lines (162 loc) · 6.91 KB
/
compile-peg.l
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
;;; compile-peg.l -*- coke -*-
;;;
;;; ./eval compile-peg.l <filename>.g ... | tee <filename>.l
(require "text-parser.l")
(require "parser.l")
(require "peg.l")
(require "record-case.l")
(define-function mapN1 (fnN fn1 list)
(if (pair? list)
(if (pair? (cdr list))
(cons (fnN (car list)) (mapN1 fnN fn1 (cdr list)))
(cons (fn1 (car list)) (mapN1 fnN fn1 (cdr list))))
list))
(define value-pe)
(define effect-pe)
(define-function value-pe (pe)
(record-case pe
(match-rule (name . args) (if args
`(text-parser-invoke-rule-simply ',name ,(concat-symbol '$ name) self ,@args)
`(text-parser-invoke-rule ',name ,(concat-symbol '$ name) self)))
(match-first exps `(or ,@(map value-pe exps)))
(match-all exps `(let ((pos self.position)) (unless (and ,@(mapN1 effect-pe value-pe exps)) (set self.position pos) ())))
(match-zero-one (exp) `(let ((_list_ (array)))
(and ,(value-pe exp) (array-append _list_ self.result))
(set self.result (array->list _list_))
1))
(match-zero-more (exp) `(let ((_list_ (array)))
(while ,(value-pe exp) (array-append _list_ self.result))
(set self.result (array->list _list_))
1))
(match-one-more (exp) `(let ((_list_ (array)))
(while ,(value-pe exp) (array-append _list_ self.result))
(set self.result (array->list _list_))))
(peek-for (exp) `(let ((pos self.position))
(and ,(value-pe exp) (set self.position pos))))
(peek-expr (exp) exp)
(peek-not (exp) `(not (let ((pos self.position))
(and ,(effect-pe exp) (set self.position pos)))))
(match-class (str) (let ((len (string-length str)))
(cond
((= len 0) 1)
((= len 1) `(text-parser-match-object self ,(string-at str 0)))
(else `(text-parser-match-class self ,(text-parser-make-class str))))))
(match-string (str) (let ((len (string-length str)))
(cond
((= len 0) 1)
((= len 1) `(text-parser-match-char self ,(string-at str 0)))
(else `(text-parser-match-string self ,str ,(string-length str))))))
(match-any () '(text-parser-match-any self))
(make-span (exp) `(let ((pos self.position))
(when ,(effect-pe exp)
(set self.result (text-parser-list-from-to self pos self.position))
1)))
(make-string (exp) (record-case exp
(make-span (exp) `(let ((pos self.position))
(when ,(effect-pe exp)
(set self.result (text-parser-string-from-to self pos self.position)))))
(else `(and ,(value-pe exp) (set self.result (list->string self.result))))))
(make-symbol (exp) (record-case exp
(make-span (exp) `(let ((pos self.position))
(when ,(effect-pe exp)
(set self.result (string->symbol (text-parser-string-from-to self pos self.position))))))
(else `(and ,(value-pe exp) (set self.result (string->symbol (list->string self.result)))))))
(make-number (r exp) `(and ,(value-pe exp) (set self.result (string->number-base (list->string self.result) ,r))))
(assign-result (name exp) `(when ,(value-pe exp) (set ,name self.result) 1))
(result-expr (exp) `(let () (set self.result ,exp) 1))
(else (error "cannot generate value for: "pe))))
(define-function effect-pe (pe)
(record-case pe
(match-rule (name . args) (if args
`(text-parser-invoke-rule-simply ',name ,(concat-symbol '$$ name) self ,@args)
`(text-parser-invoke-rule ',name ,(concat-symbol '$$ name) self)))
(match-first exps `(or ,@(map effect-pe exps)))
(match-all exps `(let ((pos self.position)) (unless (and ,@(map effect-pe exps)) (set self.position pos) ())))
(match-zero-one (exp) `(let () ,(effect-pe exp) 1))
(match-zero-more (exp) `(let () (while ,(effect-pe exp)) 1))
(match-one-more (exp) `(let ((_ok_ ()))
(while ,(effect-pe exp) (set _ok_ 1))
_ok_))
(peek-for (exp) `(let ((pos self.position))
(and ,(effect-pe exp) (set self.position pos))))
(peek-expr (exp) exp)
(peek-not (exp) `(not (let ((pos self.position))
(and ,(effect-pe exp) (set self.position pos)))))
(match-class (str) (let ((len (string-length str)))
(cond
((= len 0) 1)
((= len 1) `(text-parser-match-object self ,(string-at str 0)))
(else `(text-parser-match-class self ,(text-parser-make-class str))))))
(match-string (str) (let ((len (string-length str)))
(cond
((= len 0) 1)
((= len 1) `(text-parser-match-object self ,(string-at str 0)))
(else `(text-parser-match-string self ,str ,(string-length str))))))
(match-any () '(text-parser-match-any self))
(make-span (exp) (effect-pe exp))
(make-string (exp) (effect-pe exp))
(make-symbol (exp) (effect-pe exp))
(make-number (r exp) (effect-pe exp))
(assign-result (name exp) `(when ,(value-pe exp) (set ,name self.result) 1))
(result-expr (exp) `(let () ,exp 1))
(else (error "cannot generate effect for: "pe))))
(define-function find-vars-in (pe arr)
(let ((op (car pe)))
(cond
((or (= op 'match-first)
(= op 'match-all)) (list-do exp (cdr pe) (find-vars-in exp arr)))
((or (= op 'match-zero-one)
(= op 'match-zero-more)
(= op 'match-one-more)
(= op 'peek-for)
(= op 'peek-not)
(= op 'make-span)
(= op 'make-string)
(= op 'make-symbol)) (find-vars-in (cadr pe) arr))
((or (= op 'make-number)) (find-vars-in (caddr pe) arr))
((or (= op 'assign-result)) (array-append arr (cadr pe))
(find-vars-in (caddr pe) arr))
((or (= op 'match-class)
(= op 'match-string)
(= op 'match-any)
(= op 'match-rule)
(= op 'peek-expr)
(= op 'result-expr)))
(else (error "cannot find vars in: "pe)))))
(define-function find-vars (pe)
(let ((arr (array))
(vars ()))
(find-vars-in pe arr)
(array-do var arr (or (member? var vars) (push vars var)))
vars))
(define-function compile-rule (rule class)
(let* ((name (car rule))
(body (cadr rule))
(args (caddr rule))
(vars (find-vars body)))
;;(print ";; ") (dumpln rule)
(print "(define-method $"name" "class" "args" ")
(print "(let "vars" ")
(dump (value-pe body))
(print ")")
(println ")")
(print "(define-method $$"name" "class" "args" ")
(print "(let "vars" ")
(dump (effect-pe body))
(print ")")
(println ")")
))
(while *arguments*
(let* ((spec (parse-file <peg> $parser_spec (next-argument)))
(decl (caar spec))
(rules (cdr spec))
(names (map car rules))
(class (or (car decl) "<text-parser>")))
;;(map dumpln grammar)
;;(println names)
(println "(require \"text-parser.l\")")
;;(println ";; "decl)
(and decl (println "(define-class "(car decl)" "(cadr decl)" "(caddr decl)")"))
(list-do name names (println "(define-selector $" name")"))
(list-do name names (println "(define-selector $$"name")"))
(map-with compile-rule rules class)))