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