bootstrap
view genesis/ometa/ometa-interpreter.church @ 758:42c043932622
rename parse to parse-memo
add comments to ometa grammar
add 'transient' flags to ometa grammar
'memoize' instructions used by the interpreter so that we don't duplicate cons lists
add comments to ometa grammar
add 'transient' flags to ometa grammar
'memoize' instructions used by the interpreter so that we don't duplicate cons lists
| author | John Leuner <jewel@subvert-the-dominant-paradigm.net> |
|---|---|
| date | Sun Apr 24 12:42:17 2011 +0200 (13 months ago) |
| parents | 96f6eb9a4278 |
| children | 350b4488683d |
line source
1 extern o-fail
3 class ometa-rule
4 with-slots
5 name
6 instructions
7 original-instructions
8 variables
9 flags
11 get-variable-position rule-variables sym
12 (position sym rule-variables)
14 replace-variables-with-positions variables form quoting
15 if (null? form)
16 form
17 else
18 typecase form
19 cons
20 cond
21 (and quoting (eq? (first form) 'unquote))
22 pos = position (second form) variables
23 `[_ometa_get_variable ,pos]
24 (and quoting (eq? (first form) 'unquote-splice))
25 pos = position (second form) variables
26 `[_ometa_get_variable_splice ,pos]
27 (eq? (first form) 'quote)
28 ,(replace-variables-with-positions variables (second form) true)
29 (eq? (first form) 'quasiquote)
30 loop
31 for f in (second form)
32 collect (replace-variables-with-positions variables f true)
33 true
34 loop
35 for f in form
36 collect (replace-variables-with-positions variables f quoting)
37 else
38 if (string? form)
39 form
40 else
41 if quoting
42 if (and (cons? form) (eq? (first form) 'quote))
43 form
44 else
45 `[quote ,form]
46 else
47 pos = get-variable-position variables form
48 if (null? pos)
49 error "var not found " (list form variables)
50 `[_ometa_get_variable ,pos]
53 class ometa-interpreter
54 with-slots
55 data-stack
56 rules
57 rules-map
58 memo
59 actions
60 instructions-map
61 profile-map
62 init
63 self.memo = new 'native-dictionary
64 create self.memo 10000
65 self.profile-map = new 'native-dictionary
66 create self.profile-map 10000
67 self.instructions-map = new 'equal-native-dictionary
68 create self.instructions-map 10000
69 self.actions = nil
70 reset-memo
71 self.memo = new 'native-dictionary
72 create self.memo 10000
73 rewrite-instruction rule form
74 new-form = actual-rewrite-instruction self rule form
75 lookup = get self.instructions-map new-form nil
76 if (null? lookup)
77 put self.instructions-map new-form new-form
78 new-form
79 else
80 lookup
81 actual-rewrite-instruction rule form
82 ; print "rewrite-instruction 3"
83 ; print form
84 case (first form)
85 and
86 new-forms = [(rewrite-instruction self rule x) for x in (cdr form)]
87 `[and |,(remove nil new-forms)]
88 or
89 new-forms = [(rewrite-instruction self rule x) for x in (cdr form)]
90 `[or |,(remove nil new-forms)]
91 set
92 ; print "set"
93 ; print form
94 ; print rule.variables
95 rhs = third form
96 variable-position = get-variable-position rule.variables (intern (second form))
97 `[set ,variable-position ,(rewrite-instruction self rule rhs)]
98 app
99 rule-name = second form
100 if (and (string? rule-name) (string-equal? rule-name "token"))
101 return-from actual-rewrite-instruction `[app-token ,rule-name ,(coerce rule-name 'array)]
102 if (eq? rule-name 'token)
103 str = (third form)
104 `[app-token ,str ,(coerce str 'array)]
105 else
106 if (eq? rule-name 'exactly)
107 args = cddr form
108 str = third form
109 if (cons? str)
110 str = second str
111 `[match-char ,(char-at str 0)]
112 else
113 ; print form
114 if (== (length form) 3)
115 if (and (cons? (third form)) (eq? (first (third form)) 'string))
116 `[app-with-string ,(intern (second form)) ,(second (third form))]
117 else
118 if (or (null? (third form)) (or (null? (third form)) (eq? 'nil (third form)) (string-equal? (third form) "nil")))
119 if (symbol? (second form))
120 `[app-with-nil ,(second form)]
121 else
122 `[app-with-nil ,(intern (second form))]
123 else
124 `[app-with-argument ,(second form) ,(get-variable-position rule.variables (intern (third form)))]
125 else
126 if (string? (second form))
127 `[app ,(intern (second form))]
128 else
129 form
130 act
131 ; print "*** rewrite act"
132 ; print rule.variables
133 ; print form
134 ; print (coerce (second form) 'array)
135 forms = (parse-sexps-from-array (coerce (second form) 'array))
136 if (null? forms)
137 error "bad sexp" form
138 act-form = first forms
139 res = `[act ,(replace-variables-with-positions rule.variables act-form nil)]
140 res
141 many
142 `[many ,(rewrite-instruction self rule (second form))]
143 many1
144 `[many1 ,(rewrite-instruction self rule (second form))]
145 not
146 `[not ,(rewrite-instruction self rule (second form))]
147 lookahead
148 `[not [not ,(rewrite-instruction self rule (second form))]]
149 loadarg
150 `[loadarg]
151 else
152 error "unhandled form" form
153 parse-memo rule-name stream frame-pointer stack-pointer
154 memo = self.memo
155 inputpos = stream.input-position
156 found = has? memo rule-name
157 mark stream
158 ; print "** parse-memo"
159 ; print rule-name
160 if found
161 lookup = get memo rule-name nil
162 lookup2 = get lookup inputpos nil
163 if (null? lookup2)
164 result = (actual-parse self rule-name stream frame-pointer stack-pointer)
165 put lookup inputpos (list result stream.input-position)
166 ; print "put result 1"
167 ; print (list result stream.input-position)
168 pop-mark stream
169 result
170 else
171 if (not (eq? (car lookup2) o-fail))
172 ; print "got memo "
173 ; print lookup2
174 reset-to stream (second lookup2)
175 else
176 reset-to-mark stream
177 pop-mark stream
178 car lookup2
179 else
180 result = (actual-parse self rule-name stream frame-pointer stack-pointer)
181 d = new 'native-dictionary
182 create d 100
183 put d inputpos (list result stream.input-position)
184 put memo rule-name d
185 ; print "put result 2"
186 ; print rule-name
187 ; print result
188 pop-mark stream
189 result
190 actual-parse rule-name stream frame-pointer stack-pointer
191 lookup = get self.rules-map rule-name nil
192 if (null? lookup)
193 ; out "** primitive parse "
194 ; print rule-name
195 prim-result = apply rule-name self stream
196 ; print prim-result
197 ; print (remaining stream)
198 prim-result
199 else
200 r = lookup
201 frame-pointer = stack-pointer
202 stack-pointer = + (+ stack-pointer (length r.variables)) 1
203 loop
204 for i from frame-pointer to stack-pointer
205 do
206 self.data-stack[i] = nil
208 result = interpret self r.instructions stream frame-pointer stack-pointer
209 ; print result
210 ; print (remaining stream)
211 result
212 parse-with-arg rule-name stream frame-pointer stack-pointer arg
213 ; print "** parse with arg"
214 ; print rule-name
215 ; print arg
216 lookup = get self.rules-map rule-name nil
217 if (null? lookup)
218 apply rule-name self stream arg
219 else
220 r = lookup
221 frame-pointer = stack-pointer
222 stack-pointer = + (+ stack-pointer (length r.variables)) 1
223 loop
224 for i from frame-pointer to stack-pointer
225 do
226 self.data-stack[i] = nil
228 self.data-stack[ frame-pointer ] = arg
229 interpret self r.instructions stream frame-pointer stack-pointer
230 seq stream arg
231 if (o-fail? arg)
232 return-from seq o-fail
233 ; print "in seq"
234 ; print arg
235 mark stream
236 loop
237 for x in arg
238 do
239 str = x
240 ; print "seq str"
241 ; print str
242 ; print "next"
243 if (string? str)
244 print "is string"
245 error "not string" str
246 else
247 if (at-end? stream)
248 reset-to-mark stream
249 pop-mark stream
250 return-from seq o-fail
251 c = read-next stream
252 if (not (eq? c str))
253 reset-to-mark stream
254 pop-mark stream
255 return-from seq o-fail
257 pop-mark stream
258 ; print "in seq ret"
259 arg
260 anything stream
261 if (at-end? stream)
262 o-fail
263 else
264 read-next stream
265 cnewline stream
266 if (at-end? stream)
267 o-fail
268 else
269 c = peek stream
270 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
271 x = nil
272 inline (set! |x| (|church-make-character| 10))
273 if (eq? c x)
274 read-next stream
275 else
276 unpeek stream
277 o-fail
278 stringquote stream
279 if (at-end? stream)
280 o-fail
281 else
282 c = peek stream
283 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
284 x = nil
285 inline (set! |x| (|church-make-character| 34))
286 if (eq? c x)
287 read-next stream
288 else
289 unpeek stream
290 o-fail
291 digit stream
292 if (>= (remaining-byte-count stream) 1)
293 c = peek stream
294 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
295 if (and (char? c) (digit? c))
296 read-next stream
297 c
298 else
299 unpeek stream
300 o-fail
301 else
302 o-fail
303 letter stream
304 if (>= (remaining-byte-count stream) 1)
305 c = peek stream
306 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
307 if (and (char? c) (letter? c))
308 read-next stream
309 else
310 unpeek stream
311 o-fail
312 else
313 o-fail
314 interpret-action form frame-pointer stack-pointer quoting
315 ; print "interpret-action"
316 ; print form
317 ; print frame-pointer
318 typecase form
319 cons
320 if (eq? (first form) 'quote)
321 second form
322 else
323 if (eq? (first form) '_ometa_get_variable)
324 ; print "getting variable"
325 ; print (second form)
326 ; print self.data-stack[frame-pointer]
327 self.data-stack[+ frame-pointer (second form)]
328 else
329 collector = nil
330 loop
331 for x in form
332 do
333 if (and (cons? x) (eq? (first x) '_ometa_get_variable_splice))
334 mylist = self.data-stack[+ frame-pointer (second x)]
335 collector = append! (reverse! mylist) collector
336 else
337 push (interpret-action self x frame-pointer stack-pointer quoting) collector
339 ; print collector
340 reverse! collector
341 else
342 error "bad type in interpret-action" form
343 interpret ins stream frame-pointer stack-pointer
344 ; out "<-------- "
345 ; if (not (at-end? stream))
346 ; print (remaining stream)
347 ; print ins
348 ; print stream.input-position
349 ; print "stack-pointer"
350 ; print stack-pointer
351 ; print ">"
352 ; loop
353 ; for i from 0 to frame-pointer
354 ; do
355 ; print self.data-stack[i]
356 ;
357 ; print ">>"
358 ; loop
359 ; for i from frame-pointer to stack-pointer
360 ; do
361 ; print self.data-stack[i]
362 ;
363 ; pm = self.profile-map
364 ; entry = get pm ins nil
365 ; if (null? entry)
366 ; put pm ins 1
367 ; else
368 ; put pm ins (+ 1 entry)
369 case (first ins)
370 match-char
371 if (>= (remaining-byte-count stream) 1)
372 arg = second ins
373 c = peek stream
374 ; assert (== (peek-distance stream) 1) (list "bad peek distance" (peek-distance stream))
375 if (eq? c arg)
376 read-next stream
377 else
378 unpeek stream
379 o-fail
380 else
381 o-fail
382 app (parse-memo self (second ins) stream frame-pointer stack-pointer)
383 app-no-memo (actual-parse self (second ins) stream frame-pointer stack-pointer)
384 and
385 args = rest ins
386 if (null? args)
387 true
388 else
389 mark stream
390 answer = nil
391 loop
392 for x in args
393 do (answer = interpret self x stream frame-pointer stack-pointer)
394 when (o-fail? answer)
395 do
396 reset-to-mark stream
397 pop-mark stream
398 return-from interpret o-fail
400 pop-mark stream
401 answer
402 or
403 mark stream
404 args = rest ins
405 if (null? args)
406 error "bad or" ins
407 loop
408 for x in args
409 do
410 reset-to-mark stream
411 answer = interpret self x stream frame-pointer stack-pointer
412 if (not (o-fail? answer))
413 pop-mark stream
414 return-from interpret answer
416 pop-mark stream
417 o-fail
418 many
419 answer = nil
420 loop
421 do
422 mark stream
423 v = interpret self (second ins) stream frame-pointer stack-pointer
424 if (o-fail? v)
425 reset-to-mark stream
426 pop-mark stream
427 return-from interpret (reverse! answer)
428 push v answer
429 pop-mark stream
431 many1
432 x = second ins
433 v = interpret self x stream frame-pointer stack-pointer
434 if (o-fail? v)
435 o-fail
436 else
437 answer = list v
438 loop
439 do
440 mark stream
441 v = interpret self x stream frame-pointer stack-pointer
442 if (o-fail? v)
443 reset-to-mark stream
444 pop-mark stream
445 return-from interpret (reverse! answer)
446 push v answer
447 pop-mark stream
449 act
450 ; print "act"
451 ; print ins
452 v = interpret-action self (second ins) frame-pointer stack-pointer nil
453 ; print "interpret-action "
454 ; print v
455 v
456 set
457 index = second ins
458 x = third ins
459 v = interpret self x stream frame-pointer stack-pointer
460 self.data-stack[+ frame-pointer index] = v
461 v
462 not
463 mark stream
464 if (o-fail? (interpret self (second ins) stream frame-pointer stack-pointer))
465 pop-mark stream
466 true
467 else
468 reset-to-mark stream
469 pop-mark stream
470 o-fail
471 app-token
472 str = second ins
473 char-array = third ins
474 len = length char-array
475 if (>= (remaining-byte-count stream) len)
476 input-position = stream.input-position
477 native1 = char-array.native-array
478 native2 = stream.input-array.native-array
479 result = 0
480 inline (set! result (tf (call-c memcmp native1 (+ native2 (* (uf input-position) CHURCH_WORD_SIZE)) (* (uf len) CHURCH_WORD_SIZE))))
481 if (== result 0)
482 read-ahead stream len
483 ; print "app-token returning"
484 ; print str
485 str
486 else
487 ;print "app-token failed"
488 ;print (remaining stream)
489 o-fail
490 else
491 o-fail
492 app-with-nil
493 parse-with-arg self (second ins) stream frame-pointer stack-pointer nil
494 app-with-argument
495 parse-with-arg self (second ins) stream frame-pointer stack-pointer self.data-stack[ + frame-pointer (third ins)]
496 app-with-string
497 parse-with-arg self (second ins) stream frame-pointer stack-pointer (third ins)
498 loadarg
499 self.data-stack[frame-pointer]
500 else
501 error "invalid ins" ins