bootstrap

annotate genesis/ometa/ometa-interpreter.church @ 754:cbea15e41381

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