1# -*- tcl -*- 2# 3# Copyright (c) 2009-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 4 5# # ## ### ##### ######## ############# ##################### 6## Package description 7 8## Implementation of the PackRat Machine (PARAM), a virtual machine on 9## top of which parsers for Parsing Expression Grammars (PEGs) can be 10## realized. This implementation is tied to Tcl for control flow. We 11## (will) have alternate implementations written in TclOO, and critcl, 12## all exporting the same API. 13# 14## RD stands for Recursive Descent. 15 16# # ## ### ##### ######## ############# ##################### 17## Requisites 18 19package require Tcl 8.5 20package require TclOO 21package require struct::stack 1.5 ; # Requiring peekr, getr, get, trim* methods 22package require pt::ast 23package require pt::pe 24 25# # ## ### ##### ######## ############# ##################### 26## Support narrative tracing. 27 28package require debug 29debug level pt/rdengine 30debug prefix pt/rdengine {} 31 32 33# # ## ### ##### ######## ############# ##################### 34## Implementation 35 36oo::class create ::pt::rde::oo { 37 # # ## ### ##### ######## ############# ##################### 38 ## Instruction counter for tracing. Unused else. Plus other helpers. 39 40 method TraceInitialization {} { 41 # Creation of the tracing support procedures. 42 # Conditional on debug tag "pt/rdengine". 43 # The instance namespace is the current context. 44 # This is where the procedures go. 45 46 proc Instruction {label {a {}} {b {}}} { 47 upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst 48 set theinst [list $label $a $b] 49 return "[uplevel 1 self] <<[format %08d [incr mytracecounter]]>> START I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]" 50 } 51 52 proc InstReturn {} { 53 upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst 54 lassign $theinst label a b 55 return "[uplevel 1 self] <<[format %08d $mytracecounter]>> END__ I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]" 56 } 57 58 proc State {} { 59 upvar 1 myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror 60 set sv [expr {[info exists mysvalue] ? $mysvalue : ""}] 61 return "ST $myok CL $myloc CC ($mycurrent) SV ($sv) ER ($myerror)" 62 } 63 64 proc TraceSetupStacks {} { 65 set selfns [namespace current] 66 67 # Move stack instances aside. 68 rename ${selfns}::LOC ${selfns}::LOC__ 69 rename ${selfns}::ERR ${selfns}::ERR__ 70 rename ${selfns}::AST ${selfns}::AST__ 71 rename ${selfns}::MARK ${selfns}::MRK__ 72 73 # Create procedures doing tracing, and forwarding to 74 # the renamed actual instances. 75 76 interp alias {} ${selfns}::LOC {} ${selfns}::WRAP LS LOC__ 77 interp alias {} ${selfns}::ERR {} ${selfns}::WRAP ES ERR__ 78 interp alias {} ${selfns}::AST {} ${selfns}::WRAP ARS AST__ 79 interp alias {} ${selfns}::MARK {} ${selfns}::WRAP ASM MRK__ 80 81 proc WRAP {label stack args} { 82 debug.pt/rdengine { $label ___ $args} 83 set res [$stack {*}$args] 84 85 # Show state state after the op 86 set n [$stack size] 87 if {!$n} { 88 set c {()} 89 } elseif {$n == 1} { 90 set c <<[$stack peek $n]>> 91 } else { 92 set c <<[join [$stack peek $n] {>> <<}]>> 93 } 94 debug.pt/rdengine { $label == ($n):$c} 95 96 # And op return 97 debug.pt/rdengine { $label ==> ($res)} 98 return $res 99 } 100 return 101 } 102 103 return 104 } 105 106 # # ## ### ##### ######## ############# ##################### 107 ## API - Lifecycle 108 109 constructor {} { 110 debug.pt/rdengine {[my TraceInitialization][self] constructor} 111 112 #set selfns [self namespace] 113 114 set mystackloc [struct::stack LOC] ; # LS 115 set mystackerr [struct::stack ERR] ; # ES 116 set mystackast [struct::stack AST] ; # ARS/AS 117 set mystackmark [struct::stack MARK] ; # s.a. 118 119 debug.pt/rdengine {[TraceSetupStacks][self] constructor /done} 120 my reset {} 121 return 122 } 123 124 method reset {chan} { 125 debug.pt/rdengine {[self] reset ($chan)} 126 127 set mychan $chan ; # IN 128 set mycurrent {} ; # CC 129 set myloc -1 ; # CL 130 set myok 0 ; # ST 131 set msvalue {} ; # SV 132 set myerror {} ; # ER 133 set mytoken {} ; # TC (string) 134 array unset mysymbol * ; # NC 135 136 $mystackloc clear 137 $mystackerr clear 138 $mystackast clear 139 $mystackmark clear 140 141 debug.pt/rdengine {[self] reset /done} 142 return 143 } 144 145 method complete {} { 146 debug.pt/rdengine {[self] complete [State]} 147 148 if {$myok} { 149 set n [$mystackast size] 150 debug.pt/rdengine {[self] complete ast $n} 151 if {$n > 1} { 152 # Multiple ASTs left, reduce into single containing them. 153 set pos [$mystackloc peek] 154 incr pos 155 set children [$mystackast peekr [$mystackast size]] ; # SaveToMark 156 set ast [pt::ast new {} $pos $myloc {*}$children] ; # Reduce ALL 157 158 debug.pt/rdengine {[self] complete n ==> ($ast)} 159 return $ast 160 } elseif {$n == 0} { 161 # Match, but no AST. This is possible if the grammar 162 # consists of only the start expression. 163 164 debug.pt/rdengine {[self] complete 0 ==> ()} 165 return {} 166 } else { 167 # Match, with AST. 168 set ast [$mystackast peek] 169 debug.pt/rdengine {[self] complete 1 ==> ($ast)} 170 return $ast 171 } 172 } else { 173 lassign $myerror loc messages 174 return -code error \ 175 -errorcode {PT RDE SYNTAX} \ 176 [list pt::rde $loc $messages] 177 } 178 } 179 180 # # ## ### ##### ######## ############# ##################### 181 ## API - State accessors 182 183 method chan {} { debug.pt/rdengine {[self] chan} ; return $mychan } 184 185 # - - -- --- ----- -------- 186 187 method current {} { debug.pt/rdengine {[self] current} ; return $mycurrent } 188 method location {} { debug.pt/rdengine {[self] location} ; return $myloc } 189 method lmarked {} { debug.pt/rdengine {[self] lmarked} ; return [$mystackloc getr] } 190 191 # - - -- --- ----- -------- 192 193 method ok {} { debug.pt/rdengine {[self] ok} ; return $myok } 194 method value {} { debug.pt/rdengine {[self] value} ; return $mysvalue } 195 method error {} { debug.pt/rdengine {[self] error} ; return $myerror } 196 method emarked {} { debug.pt/rdengine {[self] emarked} ; return [$mystackerr getr] } 197 198 # - - -- --- ----- -------- 199 200 method tokens {{from {}} {to {}}} { 201 debug.pt/rdengine {[self] tokens ($from) ($to)} 202 switch -exact [llength [info level 0]] { 203 4 { return $mytoken } 204 5 { return [string range $mytoken $from $from] } 205 6 { return [string range $mytoken $from $to] } 206 } 207 } 208 209 method symbols {} { 210 debug.pt/rdengine {[self] symbols} 211 return [array get mysymbol] 212 } 213 214 method scached {} { 215 debug.pt/rdengine {[self] scached} 216 return [array names mysymbol] 217 } 218 219 # - - -- --- ----- -------- 220 221 method asts {} { debug.pt/rdengine {[self] asts} ; return [$mystackast getr] } 222 method amarked {} { debug.pt/rdengine {[self] amarked} ; return [$mystackmark getr] } 223 method ast {} { debug.pt/rdengine {[self] ast} ; return [$mystackast peek] } 224 225 # # ## ### ##### ######## ############# ##################### 226 ## API - Preloading the token cache. 227 228 method data {string} { 229 debug.pt/rdengine {[self] data +[string length $string]} 230 append mytoken $string 231 return 232 } 233 234 # # ## ### ##### ######## ############# ##################### 235 ## Common instruction sequences 236 237 method si:void_state_push {} { 238 debug.pt/rdengine {[Instruction si:void_state_push]} 239 # i_loc_push 240 # i_error_clear_push 241 $mystackloc push $myloc 242 set myerror {} 243 $mystackerr push {} 244 245 debug.pt/rdengine {[InstReturn]} 246 return 247 } 248 249 method si:void2_state_push {} { 250 debug.pt/rdengine {[Instruction si:void2_state_push]} 251 # i_loc_push 252 # i_error_push 253 $mystackloc push $myloc 254 $mystackerr push {} 255 256 debug.pt/rdengine {[InstReturn]} 257 return 258 } 259 260 method si:value_state_push {} { 261 debug.pt/rdengine {[Instruction si:value_state_push]} 262 # i_ast_push 263 # i_loc_push 264 # i_error_clear_push 265 $mystackmark push [$mystackast size] 266 $mystackloc push $myloc 267 set myerror {} 268 $mystackerr push {} 269 270 debug.pt/rdengine {[InstReturn]} 271 return 272 } 273 274 # - -- --- ----- -------- ------------- --------------------- 275 276 method si:void_state_merge {} { 277 debug.pt/rdengine {[Instruction si:void_state_merge]} 278 # i_error_pop_merge 279 # i_loc_pop_rewind/discard 280 281 set olderror [$mystackerr pop] 282 # We have either old or new error data, keep it. 283 if {![llength $myerror]} { 284 set myerror $olderror 285 } elseif {[llength $olderror]} { 286 # If one of the errors is further on in the input choose 287 # that as the information to propagate. 288 289 lassign $myerror loe msgse 290 lassign $olderror lon msgsn 291 292 if {$lon > $loe} { 293 set myerror $olderror 294 } elseif {$loe == $lon} { 295 # Equal locations, merge the message lists, set-like. 296 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 297 } 298 } 299 300 set last [$mystackloc pop] 301 if {!$myok} { 302 set myloc $last 303 } 304 debug.pt/rdengine {[InstReturn]} 305 return 306 } 307 308 method si:void_state_merge_ok {} { 309 debug.pt/rdengine {[Instruction si:void_state_merge_ok]} 310 # i_error_pop_merge 311 # i_loc_pop_rewind/discard 312 # i_status_ok 313 314 set olderror [$mystackerr pop] 315 # We have either old or new error data, keep it. 316 if {![llength $myerror]} { 317 set myerror $olderror 318 } elseif {[llength $olderror]} { 319 # If one of the errors is further on in the input choose 320 # that as the information to propagate. 321 322 lassign $myerror loe msgse 323 lassign $olderror lon msgsn 324 325 if {$lon > $loe} { 326 set myerror $olderror 327 } elseif {$loe == $lon} { 328 # Equal locations, merge the message lists, set-like. 329 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 330 } 331 } 332 333 set last [$mystackloc pop] 334 if {!$myok} { 335 set myloc $last 336 set myok 1 337 } 338 339 debug.pt/rdengine {[InstReturn]} 340 return 341 } 342 343 method si:value_state_merge {} { 344 debug.pt/rdengine {[Instruction si:value_state_merge]} 345 # i_error_pop_merge 346 # i_ast_pop_rewind/discard 347 # i_loc_pop_rewind/discard 348 349 set olderror [$mystackerr pop] 350 # We have either old or new error data, keep it. 351 if {![llength $myerror]} { 352 set myerror $olderror 353 } elseif {[llength $olderror]} { 354 # If one of the errors is further on in the input choose 355 # that as the information to propagate. 356 357 lassign $myerror loe msgse 358 lassign $olderror lon msgsn 359 360 if {$lon > $loe} { 361 set myerror $olderror 362 } elseif {$loe == $lon} { 363 # Equal locations, merge the message lists, set-like. 364 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 365 } 366 } 367 368 set mark [$mystackmark pop] 369 set last [$mystackloc pop] 370 if {!$myok} { 371 $mystackast trim* $mark 372 set myloc $last 373 } 374 375 debug.pt/rdengine {[InstReturn]} 376 return 377 } 378 379 # - -- --- ----- -------- ------------- --------------------- 380 381 method si:value_notahead_start {} { 382 debug.pt/rdengine {[Instruction si:value_notahead_start]} 383 # i_loc_push 384 # i_ast_push 385 386 $mystackloc push $myloc 387 $mystackmark push [$mystackast size] 388 389 debug.pt/rdengine {[InstReturn]} 390 return 391 } 392 393 method si:void_notahead_exit {} { 394 debug.pt/rdengine {[Instruction si:void_notahead_exit]} 395 # i_loc_pop_rewind 396 # i_status_negate 397 398 set myloc [$mystackloc pop] 399 set myok [expr {!$myok}] 400 401 debug.pt/rdengine {[InstReturn]} 402 return 403 } 404 405 method si:value_notahead_exit {} { 406 debug.pt/rdengine {[Instruction si:value_notahead_exit]} 407 # i_ast_pop_discard/rewind 408 # i_loc_pop_rewind 409 # i_status_negate 410 411 set mark [$mystackmark pop] 412 if {$myok} { 413 $mystackast trim* $mark 414 } 415 set myloc [$mystackloc pop] 416 set myok [expr {!$myok}] 417 418 debug.pt/rdengine {[InstReturn]} 419 return 420 } 421 422 # - -- --- ----- -------- ------------- --------------------- 423 424 method si:kleene_abort {} { 425 debug.pt/rdengine {[Instruction si:kleene_abort]} 426 # i_loc_pop_rewind/discard 427 # i:fail_return 428 429 set last [$mystackloc pop] 430 if {$myok} { 431 debug.pt/rdengine {[InstReturn]} 432 return 433 } 434 set myloc $last 435 debug.pt/rdengine {[InstReturn]} 436 return -code return 437 } 438 439 method si:kleene_close {} { 440 debug.pt/rdengine {[Instruction si:kleene_close]} 441 # i_error_pop_merge 442 # i_loc_pop_rewind/discard 443 # i:fail_status_ok 444 # i:fail_return 445 446 set olderror [$mystackerr pop] 447 # We have either old or new error data, keep it. 448 if {![llength $myerror]} { 449 set myerror $olderror 450 } elseif {[llength $olderror]} { 451 # If one of the errors is further on in the input choose 452 # that as the information to propagate. 453 454 lassign $myerror loe msgse 455 lassign $olderror lon msgsn 456 457 if {$lon > $loe} { 458 set myerror $olderror 459 } elseif {$loe == $lon} { 460 # Equal locations, merge the message lists, set-like. 461 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 462 } 463 } 464 465 set last [$mystackloc pop] 466 if {$myok} { 467 debug.pt/rdengine {[InstReturn]} 468 return 469 } 470 set myok 1 471 set myloc $last 472 473 debug.pt/rdengine {[InstReturn]} 474 return -code return 475 } 476 477 # - -- --- ----- -------- ------------- --------------------- 478 479 method si:voidvoid_branch {} { 480 debug.pt/rdengine {[Instruction si:voidvoid_branch]} 481 # i_error_pop_merge 482 # i:ok_loc_pop_discard 483 # i:ok_return 484 # i_loc_rewind 485 # i_error_push 486 487 set olderror [$mystackerr pop] 488 # We have either old or new error data, keep it. 489 if {![llength $myerror]} { 490 set myerror $olderror 491 } elseif {[llength $olderror]} { 492 # If one of the errors is further on in the input choose 493 # that as the information to propagate. 494 495 lassign $myerror loe msgse 496 lassign $olderror lon msgsn 497 498 if {$lon > $loe} { 499 set myerror $olderror 500 } elseif {$loe == $lon} { 501 # Equal locations, merge the message lists, set-like. 502 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 503 } 504 } 505 506 if {$myok} { 507 $mystackloc pop 508 debug.pt/rdengine {[InstReturn]} 509 return -code return 510 } 511 set myloc [$mystackloc peek] 512 $mystackerr push $myerror 513 514 debug.pt/rdengine {[InstReturn]} 515 return 516 } 517 518 method si:voidvalue_branch {} { 519 debug.pt/rdengine {[Instruction si:voidvalue_branch]} 520 # i_error_pop_merge 521 # i:ok_loc_pop_discard 522 # i:ok_return 523 # i_ast_push 524 # i_loc_rewind 525 # i_error_push 526 527 set olderror [$mystackerr pop] 528 # We have either old or new error data, keep it. 529 if {![llength $myerror]} { 530 set myerror $olderror 531 } elseif {[llength $olderror]} { 532 # If one of the errors is further on in the input choose 533 # that as the information to propagate. 534 535 lassign $myerror loe msgse 536 lassign $olderror lon msgsn 537 538 if {$lon > $loe} { 539 set myerror $olderror 540 } elseif {$loe == $lon} { 541 # Equal locations, merge the message lists, set-like. 542 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 543 } 544 } 545 546 if {$myok} { 547 $mystackloc pop 548 debug.pt/rdengine {[InstReturn]} 549 return -code return 550 } 551 $mystackmark push [$mystackast size] 552 set myloc [$mystackloc peek] 553 $mystackerr push $myerror 554 555 debug.pt/rdengine {[InstReturn]} 556 return 557 } 558 559 method si:valuevoid_branch {} { 560 debug.pt/rdengine {[Instruction si:valuevoid_branch]} 561 # i_error_pop_merge 562 # i_ast_pop_rewind/discard 563 # i:ok_loc_pop_discard 564 # i:ok_return 565 # i_loc_rewind 566 # i_error_push 567 568 set olderror [$mystackerr pop] 569 # We have either old or new error data, keep it. 570 if {![llength $myerror]} { 571 set myerror $olderror 572 } elseif {[llength $olderror]} { 573 # If one of the errors is further on in the input choose 574 # that as the information to propagate. 575 576 lassign $myerror loe msgse 577 lassign $olderror lon msgsn 578 579 if {$lon > $loe} { 580 set myerror $olderror 581 } elseif {$loe == $lon} { 582 # Equal locations, merge the message lists, set-like. 583 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 584 } 585 } 586 set mark [$mystackmark pop] 587 if {$myok} { 588 $mystackloc pop 589 debug.pt/rdengine {[InstReturn]} 590 return -code return 591 } 592 $mystackast trim* $mark 593 set myloc [$mystackloc peek] 594 $mystackerr push $myerror 595 596 debug.pt/rdengine {[InstReturn]} 597 return 598 } 599 600 method si:valuevalue_branch {} { 601 debug.pt/rdengine {[Instruction si:valuevalue_branch]} 602 # i_error_pop_merge 603 # i_ast_pop_discard 604 # i:ok_loc_pop_discard 605 # i:ok_return 606 # i_ast_rewind 607 # i_loc_rewind 608 # i_error_push 609 610 set olderror [$mystackerr pop] 611 # We have either old or new error data, keep it. 612 if {![llength $myerror]} { 613 set myerror $olderror 614 } elseif {[llength $olderror]} { 615 # If one of the errors is further on in the input choose 616 # that as the information to propagate. 617 618 lassign $myerror loe msgse 619 lassign $olderror lon msgsn 620 621 if {$lon > $loe} { 622 set myerror $olderror 623 } elseif {$loe == $lon} { 624 # Equal locations, merge the message lists, set-like. 625 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 626 } 627 } 628 if {$myok} { 629 $mystackmark pop 630 $mystackloc pop 631 632 debug.pt/rdengine {[InstReturn]} 633 return -code return 634 } 635 $mystackast trim* [$mystackmark peek] 636 set myloc [$mystackloc peek] 637 $mystackerr push $myerror 638 639 debug.pt/rdengine {[InstReturn]} 640 return 641 } 642 643 # - -- --- ----- -------- ------------- --------------------- 644 645 method si:voidvoid_part {} { 646 debug.pt/rdengine {[Instruction si:voidvoid_part]} 647 # i_error_pop_merge 648 # i:fail_loc_pop_rewind 649 # i:fail_return 650 # i_error_push 651 652 set olderror [$mystackerr pop] 653 # We have either old or new error data, keep it. 654 if {![llength $myerror]} { 655 set myerror $olderror 656 } elseif {[llength $olderror]} { 657 # If one of the errors is further on in the input choose 658 # that as the information to propagate. 659 660 lassign $myerror loe msgse 661 lassign $olderror lon msgsn 662 663 if {$lon > $loe} { 664 set myerror $olderror 665 } elseif {$loe == $lon} { 666 # Equal locations, merge the message lists, set-like. 667 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 668 } 669 } 670 if {!$myok} { 671 set myloc [$mystackloc pop] 672 debug.pt/rdengine {[InstReturn]} 673 return -code return 674 } 675 $mystackerr push $myerror 676 677 debug.pt/rdengine {[InstReturn]} 678 return 679 } 680 681 method si:voidvalue_part {} { 682 debug.pt/rdengine {[Instruction si:voidvalue_part]} 683 # i_error_pop_merge 684 # i:fail_loc_pop_rewind 685 # i:fail_return 686 # i_ast_push 687 # i_error_push 688 689 set olderror [$mystackerr pop] 690 # We have either old or new error data, keep it. 691 if {![llength $myerror]} { 692 set myerror $olderror 693 } elseif {[llength $olderror]} { 694 # If one of the errors is further on in the input choose 695 # that as the information to propagate. 696 697 lassign $myerror loe msgse 698 lassign $olderror lon msgsn 699 700 if {$lon > $loe} { 701 set myerror $olderror 702 } elseif {$loe == $lon} { 703 # Equal locations, merge the message lists, set-like. 704 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 705 } 706 } 707 if {!$myok} { 708 set myloc [$mystackloc pop] 709 debug.pt/rdengine {[InstReturn]} 710 return -code return 711 } 712 $mystackmark push [$mystackast size] 713 $mystackerr push $myerror 714 715 debug.pt/rdengine {[InstReturn]} 716 return 717 } 718 719 method si:valuevalue_part {} { 720 debug.pt/rdengine {[Instruction si:valuevalue_part]} 721 # i_error_pop_merge 722 # i:fail_ast_pop_rewind 723 # i:fail_loc_pop_rewind 724 # i:fail_return 725 # i_error_push 726 727 set olderror [$mystackerr pop] 728 # We have either old or new error data, keep it. 729 if {![llength $myerror]} { 730 set myerror $olderror 731 } elseif {[llength $olderror]} { 732 # If one of the errors is further on in the input choose 733 # that as the information to propagate. 734 735 lassign $myerror loe msgse 736 lassign $olderror lon msgsn 737 738 if {$lon > $loe} { 739 set myerror $olderror 740 } elseif {$loe == $lon} { 741 # Equal locations, merge the message lists, set-like. 742 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 743 } 744 } 745 if {!$myok} { 746 $mystackast trim* [$mystackmark pop] 747 set myloc [$mystackloc pop] 748 749 debug.pt/rdengine {[InstReturn]} 750 return -code return 751 } 752 $mystackerr push $myerror 753 754 debug.pt/rdengine {[InstReturn]} 755 return 756 } 757 758 # - -- --- ----- -------- ------------- --------------------- 759 760 method si:next_str {tok} { 761 debug.pt/rdengine {[Instruction si:next_str $tok]} 762 # String = sequence of characters. 763 # No need for all the intermediate stack churn. 764 765 set n [string length $tok] 766 set last [expr {$myloc + $n}] 767 set max [string length $mytoken] 768 769 incr myloc 770 if {($last >= $max) && ![my ExtendTCN [expr {$last - $max + 1}]]} { 771 set myok 0 772 set myerror [list $myloc [list [list str $tok]]] 773 # i:fail_return 774 debug.pt/rdengine {[InstReturn]} 775 return 776 } 777 set lex [string range $mytoken $myloc $last] 778 set mycurrent [string index $mytoken $last] 779 780 # ATTENTION: The error output of this instruction is different 781 # from a regular sequence of si:next_char instructions. The 782 # error location will be the start of the string token we 783 # wanted to match, and the message will contain the entire 784 # string token. In the regular sequence we would see the exact 785 # point of the mismatch instead, with the message containing 786 # the expected character. 787 788 if {$tok eq $lex} { 789 set myok 1 790 set myloc $last 791 set myerror {} 792 } else { 793 set myok 0 794 set myerror [list $myloc [list [list str $tok]]] 795 incr myloc -1 796 } 797 debug.pt/rdengine {[InstReturn]} 798 return 799 } 800 801 method si:next_class {tok} { 802 debug.pt/rdengine {[Instruction si:next_class $tok]} 803 # Class = Choice of characters. No need for stack churn. 804 805 # i_input_next "\{t $c\}" 806 # i:fail_return 807 # i_test_<user class> 808 809 incr myloc 810 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 811 set myok 0 812 set myerror [list $myloc [list [list cl $tok]]] 813 # i:fail_return 814 debug.pt/rdengine {[InstReturn]} 815 return 816 } 817 set mycurrent [string index $mytoken $myloc] 818 819 # Note what is needle versus hay. The token, i.e. the string 820 # of allowed characters is the hay in which the current 821 # character is looked, making it the needle. 822 823 if {[string first $mycurrent $tok] >= 0} { 824 set myok 1 825 set myerror {} 826 } else { 827 set myok 0 828 set myerror [list $myloc [list [list cl $tok]]] 829 incr myloc -1 830 } 831 debug.pt/rdengine {[InstReturn]} 832 return 833 } 834 835 method si:next_char {tok} { 836 debug.pt/rdengine {[Instruction si:next_char $tok]} 837 # i_input_next "\{t $c\}" 838 # i:fail_return 839 # i_test_char $c 840 841 incr myloc 842 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 843 set myok 0 844 set myerror [list $myloc [list [list t $tok]]] 845 # i:fail_return 846 debug.pt/rdengine {[InstReturn]} 847 return 848 } 849 set mycurrent [string index $mytoken $myloc] 850 851 if {$tok eq $mycurrent} { 852 set myok 1 853 set myerror {} 854 } else { 855 set myok 0 856 set myerror [list $myloc [list [list t $tok]]] 857 incr myloc -1 858 } 859 debug.pt/rdengine {[InstReturn]} 860 return 861 } 862 863 method si:next_range {toks toke} { 864 debug.pt/rdengine {[Instruction si:next_range $toks $toke]} 865 #Asm::Ins i_input_next "\{.. $s $e\}" 866 #Asm::Ins i:fail_return 867 #Asm::Ins i_test_range $s $e 868 869 incr myloc 870 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 871 set myok 0 872 set myerror [list $myloc [list [list .. $toks $toke]]] 873 # i:fail_return 874 debug.pt/rdengine {[InstReturn]} 875 return 876 } 877 set mycurrent [string index $mytoken $myloc] 878 879 if {([string compare $toks $mycurrent] <= 0) && 880 ([string compare $mycurrent $toke] <= 0)} { 881 set myok 1 882 set myerror {} 883 } else { 884 set myok 0 885 set myerror [list $myloc [list [pt::pe range $toks $toke]]] 886 incr myloc -1 887 } 888 debug.pt/rdengine {[InstReturn]} 889 return 890 } 891 892 # - -- --- ----- -------- ------------- --------------------- 893 894 method si:next_alnum {} { 895 debug.pt/rdengine {[Instruction si:next_alnum]} 896 #Asm::Ins i_input_next alnum 897 #Asm::Ins i:fail_return 898 #Asm::Ins i_test_alnum 899 900 incr myloc 901 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 902 set myok 0 903 set myerror [list $myloc [list alnum]] 904 # i:fail_return 905 debug.pt/rdengine {[InstReturn]} 906 return 907 } 908 set mycurrent [string index $mytoken $myloc] 909 910 set myok [string is alnum -strict $mycurrent] 911 if {!$myok} { 912 set myerror [list $myloc [list alnum]] 913 incr myloc -1 914 } else { 915 set myerror {} 916 } 917 debug.pt/rdengine {[InstReturn]} 918 return 919 } 920 921 method si:next_alpha {} { 922 debug.pt/rdengine {[Instruction si:next_alpha]} 923 #Asm::Ins i_input_next alpha 924 #Asm::Ins i:fail_return 925 #Asm::Ins i_test_alpha 926 927 incr myloc 928 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 929 set myok 0 930 set myerror [list $myloc [list alpha]] 931 # i:fail_return 932 debug.pt/rdengine {[InstReturn]} 933 return 934 } 935 set mycurrent [string index $mytoken $myloc] 936 937 set myok [string is alpha -strict $mycurrent] 938 if {!$myok} { 939 set myerror [list $myloc [list alpha]] 940 incr myloc -1 941 } else { 942 set myerror {} 943 } 944 debug.pt/rdengine {[InstReturn]} 945 return 946 } 947 948 method si:next_ascii {} { 949 debug.pt/rdengine {[Instruction si:next_ascii]} 950 #Asm::Ins i_input_next ascii 951 #Asm::Ins i:fail_return 952 #Asm::Ins i_test_ascii 953 954 incr myloc 955 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 956 set myok 0 957 set myerror [list $myloc [list ascii]] 958 # i:fail_return 959 debug.pt/rdengine {[InstReturn]} 960 return 961 } 962 set mycurrent [string index $mytoken $myloc] 963 964 set myok [string is ascii -strict $mycurrent] 965 if {!$myok} { 966 set myerror [list $myloc [list ascii]] 967 incr myloc -1 968 } else { 969 set myerror {} 970 } 971 debug.pt/rdengine {[InstReturn]} 972 return 973 } 974 975 method si:next_control {} { 976 debug.pt/rdengine {[Instruction si:next_control]} 977 #Asm::Ins i_input_next control 978 #Asm::Ins i:fail_return 979 #Asm::Ins i_test_control 980 981 incr myloc 982 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 983 set myok 0 984 set myerror [list $myloc [list control]] 985 # i:fail_return 986 debug.pt/rdengine {[InstReturn]} 987 return 988 } 989 set mycurrent [string index $mytoken $myloc] 990 991 set myok [string is control -strict $mycurrent] 992 if {!$myok} { 993 set myerror [list $myloc [list control]] 994 incr myloc -1 995 } else { 996 set myerror {} 997 } 998 debug.pt/rdengine {[InstReturn]} 999 return 1000 } 1001 1002 method si:next_ddigit {} { 1003 debug.pt/rdengine {[Instruction si:next_ddigit]} 1004 #Asm::Ins i_input_next ddigit 1005 #Asm::Ins i:fail_return 1006 #Asm::Ins i_test_ddigit 1007 1008 incr myloc 1009 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1010 set myok 0 1011 set myerror [list $myloc [list ddigit]] 1012 # i:fail_return 1013 debug.pt/rdengine {[InstReturn]} 1014 return 1015 } 1016 set mycurrent [string index $mytoken $myloc] 1017 1018 set myok [string match {[0-9]} $mycurrent] 1019 if {!$myok} { 1020 set myerror [list $myloc [list ddigit]] 1021 incr myloc -1 1022 } else { 1023 set myerror {} 1024 } 1025 debug.pt/rdengine {[InstReturn]} 1026 return 1027 } 1028 1029 method si:next_digit {} { 1030 debug.pt/rdengine {[Instruction si:next_digit]} 1031 #Asm::Ins i_input_next digit 1032 #Asm::Ins i:fail_return 1033 #Asm::Ins i_test_digit 1034 1035 incr myloc 1036 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1037 set myok 0 1038 set myerror [list $myloc [list digit]] 1039 # i:fail_return 1040 debug.pt/rdengine {[InstReturn]} 1041 return 1042 } 1043 set mycurrent [string index $mytoken $myloc] 1044 1045 set myok [string is digit -strict $mycurrent] 1046 if {!$myok} { 1047 set myerror [list $myloc [list digit]] 1048 incr myloc -1 1049 } else { 1050 set myerror {} 1051 } 1052 debug.pt/rdengine {[InstReturn]} 1053 return 1054 } 1055 1056 method si:next_graph {} { 1057 debug.pt/rdengine {[Instruction si:next_graph]} 1058 #Asm::Ins i_input_next graph 1059 #Asm::Ins i:fail_return 1060 #Asm::Ins i_test_graph 1061 1062 incr myloc 1063 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1064 set myok 0 1065 set myerror [list $myloc [list graph]] 1066 # i:fail_return 1067 debug.pt/rdengine {[InstReturn]} 1068 return 1069 } 1070 set mycurrent [string index $mytoken $myloc] 1071 1072 set myok [string is graph -strict $mycurrent] 1073 if {!$myok} { 1074 set myerror [list $myloc [list graph]] 1075 incr myloc -1 1076 } else { 1077 set myerror {} 1078 } 1079 debug.pt/rdengine {[InstReturn]} 1080 return 1081 } 1082 1083 method si:next_lower {} { 1084 debug.pt/rdengine {[Instruction si:next_lower]} 1085 #Asm::Ins i_input_next lower 1086 #Asm::Ins i:fail_return 1087 #Asm::Ins i_test_lower 1088 1089 incr myloc 1090 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1091 set myok 0 1092 set myerror [list $myloc [list lower]] 1093 # i:fail_return 1094 debug.pt/rdengine {[InstReturn]} 1095 return 1096 } 1097 set mycurrent [string index $mytoken $myloc] 1098 1099 set myok [string is lower -strict $mycurrent] 1100 if {!$myok} { 1101 set myerror [list $myloc [list lower]] 1102 incr myloc -1 1103 } else { 1104 set myerror {} 1105 } 1106 debug.pt/rdengine {[InstReturn]} 1107 return 1108 } 1109 1110 method si:next_print {} { 1111 debug.pt/rdengine {[Instruction si:next_print]} 1112 #Asm::Ins i_input_next print 1113 #Asm::Ins i:fail_return 1114 #Asm::Ins i_test_print 1115 1116 incr myloc 1117 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1118 set myok 0 1119 set myerror [list $myloc [list print]] 1120 # i:fail_return 1121 debug.pt/rdengine {[InstReturn]} 1122 return 1123 } 1124 set mycurrent [string index $mytoken $myloc] 1125 1126 set myok [string is print -strict $mycurrent] 1127 if {!$myok} { 1128 set myerror [list $myloc [list print]] 1129 incr myloc -1 1130 } else { 1131 set myerror {} 1132 } 1133 debug.pt/rdengine {[InstReturn]} 1134 return 1135 } 1136 1137 method si:next_punct {} { 1138 debug.pt/rdengine {[Instruction si:next_punct]} 1139 #Asm::Ins i_input_next punct 1140 #Asm::Ins i:fail_return 1141 #Asm::Ins i_test_punct 1142 1143 incr myloc 1144 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1145 set myok 0 1146 set myerror [list $myloc [list punct]] 1147 # i:fail_return 1148 debug.pt/rdengine {[InstReturn]} 1149 return 1150 } 1151 set mycurrent [string index $mytoken $myloc] 1152 1153 set myok [string is punct -strict $mycurrent] 1154 if {!$myok} { 1155 set myerror [list $myloc [list punct]] 1156 incr myloc -1 1157 } else { 1158 set myerror {} 1159 } 1160 debug.pt/rdengine {[InstReturn]} 1161 return 1162 } 1163 1164 method si:next_space {} { 1165 debug.pt/rdengine {[Instruction si:next_space]} 1166 #Asm::Ins i_input_next space 1167 #Asm::Ins i:fail_return 1168 #Asm::Ins i_test_space 1169 1170 incr myloc 1171 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1172 set myok 0 1173 set myerror [list $myloc [list space]] 1174 # i:fail_return 1175 debug.pt/rdengine {[InstReturn]} 1176 return 1177 } 1178 set mycurrent [string index $mytoken $myloc] 1179 1180 set myok [string is space -strict $mycurrent] 1181 if {!$myok} { 1182 set myerror [list $myloc [list space]] 1183 incr myloc -1 1184 } else { 1185 set myerror {} 1186 } 1187 debug.pt/rdengine {[InstReturn]} 1188 return 1189 } 1190 1191 method si:next_upper {} { 1192 debug.pt/rdengine {[Instruction si:next_upper]} 1193 #Asm::Ins i_input_next upper 1194 #Asm::Ins i:fail_return 1195 #Asm::Ins i_test_upper 1196 1197 incr myloc 1198 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1199 set myok 0 1200 set myerror [list $myloc [list upper]] 1201 # i:fail_return 1202 debug.pt/rdengine {[InstReturn]} 1203 return 1204 } 1205 set mycurrent [string index $mytoken $myloc] 1206 1207 set myok [string is upper -strict $mycurrent] 1208 if {!$myok} { 1209 set myerror [list $myloc [list upper]] 1210 incr myloc -1 1211 } else { 1212 set myerror {} 1213 } 1214 debug.pt/rdengine {[InstReturn]} 1215 return 1216 } 1217 1218 method si:next_wordchar {} { 1219 debug.pt/rdengine {[Instruction si:next_wordchar]} 1220 #Asm::Ins i_input_next wordchar 1221 #Asm::Ins i:fail_return 1222 #Asm::Ins i_test_wordchar 1223 1224 incr myloc 1225 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1226 set myok 0 1227 set myerror [list $myloc [list wordchar]] 1228 # i:fail_return 1229 debug.pt/rdengine {[InstReturn]} 1230 return 1231 } 1232 set mycurrent [string index $mytoken $myloc] 1233 1234 set myok [string is wordchar -strict $mycurrent] 1235 if {!$myok} { 1236 set myerror [list $myloc [list wordchar]] 1237 incr myloc -1 1238 } else { 1239 set myerror {} 1240 } 1241 debug.pt/rdengine {[InstReturn]} 1242 return 1243 } 1244 1245 method si:next_xdigit {} { 1246 debug.pt/rdengine {[Instruction si:next_xdigit]} 1247 #Asm::Ins i_input_next xdigit 1248 #Asm::Ins i:fail_return 1249 #Asm::Ins i_test_xdigit 1250 1251 incr myloc 1252 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1253 set myok 0 1254 set myerror [list $myloc [list xdigit]] 1255 # i:fail_return 1256 debug.pt/rdengine {[InstReturn]} 1257 return 1258 } 1259 set mycurrent [string index $mytoken $myloc] 1260 1261 set myok [string is xdigit -strict $mycurrent] 1262 if {!$myok} { 1263 set myerror [list $myloc [list xdigit]] 1264 incr myloc -1 1265 } else { 1266 set myerror {} 1267 } 1268 debug.pt/rdengine {[InstReturn]} 1269 return 1270 } 1271 1272 # - -- --- ----- -------- ------------- --------------------- 1273 1274 method si:value_symbol_start {symbol} { 1275 debug.pt/rdengine {[Instruction si:value_symbol_start $symbol]} 1276 # if @runtime@ i_symbol_restore $symbol 1277 # i:found:ok_ast_value_push 1278 # i:found_return 1279 # i_loc_push 1280 # i_ast_push 1281 1282 set k [list $myloc $symbol] 1283 if {[info exists mysymbol($k)]} { 1284 lassign $mysymbol($k) myloc myok myerror mysvalue 1285 if {$myok} { 1286 $mystackast push $mysvalue 1287 } 1288 debug.pt/rdengine {[InstReturn]} 1289 return -code return 1290 } 1291 $mystackloc push $myloc 1292 $mystackmark push [$mystackast size] 1293 1294 debug.pt/rdengine {[InstReturn]} 1295 return 1296 } 1297 1298 method si:value_void_symbol_start {symbol} { 1299 debug.pt/rdengine {[Instruction si:value_void_symbol_start $symbol]} 1300 # if @runtime@ i_symbol_restore $symbol 1301 # i:found_return 1302 # i_loc_push 1303 # i_ast_push 1304 1305 set k [list $myloc $symbol] 1306 if {[info exists mysymbol($k)]} { 1307 lassign $mysymbol($k) myloc myok myerror mysvalue 1308 debug.pt/rdengine {[InstReturn]} 1309 return -code return 1310 } 1311 $mystackloc push $myloc 1312 $mystackmark push [$mystackast size] 1313 1314 debug.pt/rdengine {[InstReturn]} 1315 return 1316 } 1317 1318 method si:void_symbol_start {symbol} { 1319 debug.pt/rdengine {[Instruction si:void_symbol_start $symbol]} 1320 # if @runtime@ i_symbol_restore $symbol 1321 # i:found:ok_ast_value_push 1322 # i:found_return 1323 # i_loc_push 1324 1325 set k [list $myloc $symbol] 1326 if {[info exists mysymbol($k)]} { 1327 lassign $mysymbol($k) myloc myok myerror mysvalue 1328 if {$myok} { 1329 $mystackast push $mysvalue 1330 } 1331 debug.pt/rdengine {[InstReturn]} 1332 return -code return 1333 } 1334 $mystackloc push $myloc 1335 1336 debug.pt/rdengine {[InstReturn]} 1337 return 1338 } 1339 1340 method si:void_void_symbol_start {symbol} { 1341 debug.pt/rdengine {[Instruction si:void_void_symbol_start $symbol]} 1342 # if @runtime@ i_symbol_restore $symbol 1343 # i:found_return 1344 # i_loc_push 1345 1346 set k [list $myloc $symbol] 1347 if {[info exists mysymbol($k)]} { 1348 lassign $mysymbol($k) myloc myok myerror mysvalue 1349 debug.pt/rdengine {[InstReturn]} 1350 return -code return 1351 } 1352 $mystackloc push $myloc 1353 1354 debug.pt/rdengine {[InstReturn]} 1355 return 1356 } 1357 1358 method si:reduce_symbol_end {symbol} { 1359 debug.pt/rdengine {[Instruction si:reduce_symbol_end $symbol]} 1360 # i_value_clear/reduce $symbol 1361 # i_symbol_save $symbol 1362 # i_error_nonterminal $symbol 1363 # i_ast_pop_rewind 1364 # i_loc_pop_discard 1365 # i:ok_ast_value_push 1366 1367 set mysvalue {} 1368 set at [$mystackloc pop] 1369 1370 if {$myok} { 1371 set mark [$mystackmark peek];# Old size of stack before current nt pushed more. 1372 set newa [expr {[$mystackast size] - $mark}] 1373 set pos $at 1374 incr pos 1375 1376 if {!$newa} { 1377 set mysvalue {} 1378 } elseif {$newa == 1} { 1379 # peek 1 => single element comes back 1380 set mysvalue [list [$mystackast peek]] ; # SaveToMark 1381 } else { 1382 # peek n > 1 => list of elements comes back 1383 set mysvalue [$mystackast peekr $newa] ; # SaveToMark 1384 } 1385 1386 if {$at == $myloc} { 1387 # The symbol did not process any input. As this is 1388 # signaled to be ok (*) we create a node covering an 1389 # empty range. (Ad *): Can happen for a RHS using 1390 # toplevel operators * or ?. 1391 set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue] 1392 } else { 1393 set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol 1394 } 1395 } 1396 1397 set k [list $at $symbol] 1398 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1399 1400 # si:reduce_symbol_end / i_error_nonterminal -- inlined -- disabled 1401 if {0} {if {[llength $myerror]} { 1402 set pos $at 1403 incr pos 1404 lassign $myerror loc messages 1405 if {$loc == $pos} { 1406 set myerror [list $loc [list [list n $symbol]]] 1407 } 1408 }} 1409 1410 $mystackast trim* [$mystackmark pop] 1411 if {$myok} { 1412 $mystackast push $mysvalue 1413 } 1414 debug.pt/rdengine {[InstReturn]} 1415 return 1416 } 1417 1418 method si:void_leaf_symbol_end {symbol} { 1419 debug.pt/rdengine {[Instruction si:void_leaf_symbol_end $symbol]} 1420 # i_value_clear/leaf $symbol 1421 # i_symbol_save $symbol 1422 # i_error_nonterminal $symbol 1423 # i_loc_pop_discard 1424 # i:ok_ast_value_push 1425 1426 set mysvalue {} 1427 set at [$mystackloc pop] 1428 1429 if {$myok} { 1430 set pos $at 1431 incr pos 1432 if {$at == $myloc} { 1433 # The symbol did not process any input. As this is 1434 # signaled to be ok (*) we create a node covering an 1435 # empty range. (Ad *): Can happen for a RHS using 1436 # toplevel operators * or ?. 1437 set mysvalue [pt::ast new0 $symbol $pos] 1438 } else { 1439 set mysvalue [pt::ast new $symbol $pos $myloc] 1440 } 1441 } 1442 1443 set k [list $at $symbol] 1444 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1445 1446 # si:void_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled 1447 if {0} {if {[llength $myerror]} { 1448 set pos $at 1449 incr pos 1450 lassign $myerror loc messages 1451 if {$loc == $pos} { 1452 set myerror [list $loc [list [list n $symbol]]] 1453 } 1454 }} 1455 1456 if {$myok} { 1457 $mystackast push $mysvalue 1458 } 1459 1460 debug.pt/rdengine {[InstReturn]} 1461 return 1462 } 1463 1464 method si:value_leaf_symbol_end {symbol} { 1465 debug.pt/rdengine {[Instruction si:value_leaf_symbol_end $symbol]} 1466 # i_value_clear/leaf $symbol 1467 # i_symbol_save $symbol 1468 # i_error_nonterminal $symbol 1469 # i_loc_pop_discard 1470 # i_ast_pop_rewind 1471 # i:ok_ast_value_push 1472 1473 set mysvalue {} 1474 set at [$mystackloc pop] 1475 1476 if {$myok} { 1477 set pos $at 1478 incr pos 1479 if {$at == $myloc} { 1480 # The symbol did not process any input. As this is 1481 # signaled to be ok (*) we create a node covering an 1482 # empty range. (Ad *): Can happen for a RHS using 1483 # toplevel operators * or ?. 1484 set mysvalue [pt::ast new0 $symbol $pos] 1485 } else { 1486 set mysvalue [pt::ast new $symbol $pos $myloc] 1487 } 1488 } 1489 1490 set k [list $at $symbol] 1491 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1492 1493 # si:value_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled 1494 if {0} {if {[llength $myerror]} { 1495 set pos $at 1496 incr pos 1497 lassign $myerror loc messages 1498 if {$loc == $pos} { 1499 set myerror [list $loc [list [list n $symbol]]] 1500 } 1501 }} 1502 1503 $mystackast trim* [$mystackmark pop] 1504 if {$myok} { 1505 $mystackast push $mysvalue 1506 } 1507 1508 debug.pt/rdengine {[InstReturn]} 1509 return 1510 } 1511 1512 method si:value_clear_symbol_end {symbol} { 1513 debug.pt/rdengine {[Instruction si:value_clear_symbol_end $symbol]} 1514 # i_value_clear 1515 # i_symbol_save $symbol 1516 # i_error_nonterminal $symbol 1517 # i_loc_pop_discard 1518 # i_ast_pop_rewind 1519 1520 set mysvalue {} 1521 set at [$mystackloc pop] 1522 1523 set k [list $at $symbol] 1524 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1525 1526 # si:value_clear_symbol_end / i_error_nonterminal -- inlined -- disabled 1527 if {0} {if {[llength $myerror]} { 1528 set pos $at 1529 incr pos 1530 lassign $myerror loc messages 1531 if {$loc == $pos} { 1532 set myerror [list $loc [list [list n $symbol]]] 1533 } 1534 }} 1535 1536 $mystackast trim* [$mystackmark pop] 1537 debug.pt/rdengine {[InstReturn]} 1538 return 1539 } 1540 1541 method si:void_clear_symbol_end {symbol} { 1542 debug.pt/rdengine {[Instruction si:void_clear_symbol_end $symbol]} 1543 # i_value_clear 1544 # i_symbol_save $symbol 1545 # i_error_nonterminal $symbol 1546 # i_loc_pop_discard 1547 1548 set mysvalue {} 1549 set at [$mystackloc pop] 1550 1551 set k [list $at $symbol] 1552 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1553 1554 # si:void_clear_symbol_end / i_error_nonterminal -- inlined -- disabled 1555 if {0} {if {[llength $myerror]} { 1556 set pos $at 1557 incr pos 1558 lassign $myerror loc messages 1559 if {$loc == $pos} { 1560 set myerror [list $loc [list [list n $symbol]]] 1561 } 1562 }} 1563 debug.pt/rdengine {[InstReturn]} 1564 return 1565 } 1566 1567 # # ## ### ##### ######## ############# ##################### 1568 ## API - Instructions - Control flow 1569 1570 method i:ok_continue {} { 1571 debug.pt/rdengine {[Instruction i:ok_continue]} 1572 if {!$myok} return 1573 return -code continue 1574 } 1575 1576 method i:fail_continue {} { 1577 debug.pt/rdengine {[Instruction i:fail_continue]} 1578 if {$myok} return 1579 return -code continue 1580 } 1581 1582 method i:fail_return {} { 1583 debug.pt/rdengine {[Instruction i:fail_return]} 1584 if {$myok} return 1585 return -code return 1586 } 1587 1588 method i:ok_return {} { 1589 debug.pt/rdengine {[Instruction i:ok_return]} 1590 if {!$myok} return 1591 return -code return 1592 } 1593 1594 # # ## ### ##### ######## ############# ##################### 1595 ## API - Instructions - Unconditional matching. 1596 1597 method i_status_ok {} { 1598 debug.pt/rdengine {[Instruction i_status_ok]} 1599 set myok 1 1600 debug.pt/rdengine {[InstReturn]} 1601 return 1602 } 1603 1604 method i_status_fail {} { 1605 debug.pt/rdengine {[Instruction i_status_fail]} 1606 set myok 0 1607 debug.pt/rdengine {[InstReturn]} 1608 return 1609 } 1610 1611 method i_status_negate {} { 1612 debug.pt/rdengine {[Instruction i_status_negate]} 1613 set myok [expr {!$myok}] 1614 debug.pt/rdengine {[InstReturn]} 1615 return 1616 } 1617 1618 # # ## ### ##### ######## ############# ##################### 1619 ## API - Instructions - Error handling. 1620 1621 method i_error_clear {} { 1622 debug.pt/rdengine {[Instruction i_error_clear]} 1623 set myerror {} 1624 debug.pt/rdengine {[InstReturn]} 1625 return 1626 } 1627 1628 method i_error_push {} { 1629 debug.pt/rdengine {[Instruction i_error_push]} 1630 $mystackerr push $myerror 1631 debug.pt/rdengine {[InstReturn]} 1632 return 1633 } 1634 1635 method i_error_clear_push {} { 1636 debug.pt/rdengine {[Instruction i_error_clear_push]} 1637 set myerror {} 1638 $mystackerr push {} 1639 debug.pt/rdengine {[InstReturn]} 1640 return 1641 } 1642 1643 method i_error_pop_merge {} { 1644 debug.pt/rdengine {[Instruction i_error_pop_merge]} 1645 set olderror [$mystackerr pop] 1646 1647 # We have either old or new error data, keep it. 1648 1649 if {![llength $myerror]} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return } 1650 if {![llength $olderror]} { debug.pt/rdengine {[InstReturn]} ; return } 1651 1652 # If one of the errors is further on in the input choose that as 1653 # the information to propagate. 1654 1655 lassign $myerror loe msgse 1656 lassign $olderror lon msgsn 1657 1658 if {$lon > $loe} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return } 1659 if {$loe > $lon} { debug.pt/rdengine {[InstReturn]} ; return } 1660 1661 # Equal locations, merge the message lists. 1662 set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]] 1663 debug.pt/rdengine {[InstReturn]} 1664 return 1665 } 1666 1667 method i_error_nonterminal {symbol} { 1668 debug.pt/rdengine {[Instruction i_error_nonterminal $symbol]} 1669 # i_error_nonterminal -- Disabled. Generate only low-level 1670 # i_error_nonterminal -- errors until we have worked out how 1671 # i_error_nonterminal -- to integrate symbol information with 1672 # i_error_nonterminal -- them. Do not forget where this 1673 # i_error_nonterminal -- instruction is inlined. 1674 return 1675 1676 # Inlined: Errors, Expected. 1677 if {![llength $myerror]} { 1678 debug.pt/rdengine {no error} 1679 return 1680 } 1681 set pos [$mystackloc peek] 1682 incr pos 1683 lassign $myerror loc messages 1684 if {$loc != $pos} { 1685 debug.pt/rdengine {my $myerror != pos $pos} 1686 return 1687 } 1688 set myerror [list $loc [list [list n $symbol]]] 1689 1690 debug.pt/rdengine {::= ($myerror)} 1691 return 1692 } 1693 1694 # # ## ### ##### ######## ############# ##################### 1695 ## API - Instructions - Basic input handling and tracking 1696 1697 method i_loc_pop_rewind/discard {} { 1698 debug.pt/rdengine {[Instruction i_loc_pop_rewind/discard]} 1699 #$myparser i:fail_loc_pop_rewind 1700 #$myparser i:ok_loc_pop_discard 1701 #return 1702 set last [$mystackloc pop] 1703 if {!$myok} { 1704 set myloc $last 1705 } 1706 debug.pt/rdengine {[InstReturn]} 1707 return 1708 } 1709 1710 method i_loc_pop_discard {} { 1711 debug.pt/rdengine {[Instruction i_loc_pop_discard]} 1712 $mystackloc pop 1713 debug.pt/rdengine {[InstReturn]} 1714 return 1715 } 1716 1717 # i:ok_loc_pop_discard - all uses inlined 1718 1719 method i_loc_pop_rewind {} { 1720 debug.pt/rdengine {[Instruction i_loc_pop_rewind]} 1721 set myloc [$mystackloc pop] 1722 debug.pt/rdengine {[InstReturn]} 1723 return 1724 } 1725 1726 method i:fail_loc_pop_rewind {} { 1727 debug.pt/rdengine {[Instruction i:fail_loc_pop_rewind]} 1728 if {!$myok} { 1729 set myloc [$mystackloc pop] 1730 } 1731 debug.pt/rdengine {[InstReturn]} 1732 return 1733 } 1734 1735 method i_loc_push {} { 1736 debug.pt/rdengine {[Instruction i_loc_push]} 1737 $mystackloc push $myloc 1738 debug.pt/rdengine {[InstReturn]} 1739 return 1740 } 1741 1742 method i_loc_rewind {} { 1743 debug.pt/rdengine {[Instruction i_loc_rewind]} 1744 # i_loc_pop_rewind - set myloc [$mystackloc pop] 1745 # i_loc_push - $mystackloc push $myloc 1746 set myloc [$mystackloc peek] 1747 debug.pt/rdengine {[InstReturn]} 1748 return 1749 } 1750 1751 # # ## ### ##### ######## ############# ##################### 1752 ## API - Instructions - AST stack handling 1753 1754 method i_ast_pop_rewind/discard {} { 1755 debug.pt/rdengine {[Instruction i_ast_pop_rewind/discard]} 1756 #$myparser i:fail_ast_pop_rewind 1757 #$myparser i:ok_ast_pop_discard 1758 #return 1759 set mark [$mystackmark pop] 1760 if {!$myok} { 1761 $mystackast trim* $mark 1762 } 1763 1764 debug.pt/rdengine {[InstReturn]} 1765 return 1766 } 1767 1768 method i_ast_pop_discard/rewind {} { 1769 debug.pt/rdengine {[Instruction i_ast_pop_discard/rewind]} 1770 #$myparser i:ok_ast_pop_rewind 1771 #$myparser i:fail_ast_pop_discard 1772 #return 1773 set mark [$mystackmark pop] 1774 if {$myok} { 1775 $mystackast trim* $mark 1776 } 1777 1778 debug.pt/rdengine {[InstReturn]} 1779 return 1780 } 1781 1782 method i_ast_pop_discard {} { 1783 debug.pt/rdengine {[Instruction i_ast_pop_discard]} 1784 $mystackmark pop 1785 1786 debug.pt/rdengine {[InstReturn]} 1787 return 1788 } 1789 1790 # i:ok_ast_pop_discard - all uses inlined 1791 1792 method i_ast_pop_rewind {} { 1793 debug.pt/rdengine {[Instruction i_ast_pop_rewind]} 1794 $mystackast trim* [$mystackmark pop] 1795 1796 debug.pt/rdengine {[InstReturn]} 1797 return 1798 } 1799 1800 method i:fail_ast_pop_rewind {} { 1801 debug.pt/rdengine {[Instruction i:fail_ast_pop_rewind]} 1802 if {!$myok} { 1803 $mystackast trim* [$mystackmark pop] 1804 } 1805 1806 debug.pt/rdengine {[InstReturn]} 1807 return 1808 } 1809 1810 method i_ast_push {} { 1811 debug.pt/rdengine {[Instruction i_ast_push]} 1812 $mystackmark push [$mystackast size] 1813 1814 debug.pt/rdengine {[InstReturn]} 1815 return 1816 } 1817 1818 method i:ok_ast_value_push {} { 1819 debug.pt/rdengine {[Instruction i:ok_ast_value_push]} 1820 if {$myok} { 1821 $mystackast push $mysvalue 1822 } 1823 1824 debug.pt/rdengine {[InstReturn]} 1825 return 1826 } 1827 1828 # i_ast_rewind - all uses inlined 1829 1830 # # ## ### ##### ######## ############# ##################### 1831 ## API - Instructions - Nonterminal cache 1832 1833 method i_symbol_restore {symbol} { 1834 debug.pt/rdengine {[Instruction i_symbol_restore $symbol]} 1835 # Satisfy from cache if possible. 1836 set k [list $myloc $symbol] 1837 if {![info exists mysymbol($k)]} { 1838 debug.pt/rdengine {[InstReturn]} 1839 return 0 1840 } 1841 lassign $mysymbol($k) myloc myok myerror mysvalue 1842 # We go forward, as the nonterminal matches (or not). 1843 debug.pt/rdengine {[InstReturn]} 1844 return 1 1845 } 1846 1847 method i_symbol_save {symbol} { 1848 debug.pt/rdengine {[Instruction i_symbol_save $symbol]} 1849 # Store not only the value, but also how far 1850 # the match went (if it was a match). 1851 set at [$mystackloc peek] 1852 set k [list $at $symbol] 1853 set mysymbol($k) [list $myloc $myok $myerror $mysvalue] 1854 1855 debug.pt/rdengine {[InstReturn]} 1856 return 1857 } 1858 1859 # # ## ### ##### ######## ############# ##################### 1860 ## API - Instructions - Semantic values. 1861 1862 method i_value_clear {} { 1863 debug.pt/rdengine {[Instruction i_value_clear]} 1864 set mysvalue {} 1865 1866 debug.pt/rdengine {[InstReturn]} 1867 return 1868 } 1869 1870 method i_value_clear/leaf {symbol} { 1871 debug.pt/rdengine {[Instruction i_value_clear/leaf $symbol] :: ([expr {[$mystackloc peek]+1}])-@$myloc)} 1872 1873 # not quite value_lead (guarded, and clear on fail) 1874 # Inlined clear, reduce, and optimized. 1875 # Clear ; if {$ok} {Reduce $symbol} 1876 set mysvalue {} 1877 if {$myok} { 1878 set pos [$mystackloc peek] 1879 incr pos 1880 1881 if {($pos - 1) == $myloc} { 1882 # The symbol did not process any input. As this is 1883 # signaled to be ok (*) we create a node covering an 1884 # empty range. (Ad *): Can happen for a RHS using 1885 # toplevel operators * or ?. 1886 set mysvalue [pt::ast new0 $symbol $pos] 1887 } else { 1888 set mysvalue [pt::ast new $symbol $pos $myloc] 1889 } 1890 } 1891 1892 debug.pt/rdengine {[InstReturn]} 1893 return 1894 } 1895 1896 method i_value_clear/reduce {symbol} { 1897 debug.pt/rdengine {[Instruction i_value_clear/reduce $symbol]} 1898 set mysvalue {} 1899 if {$myok} { 1900 set mark [$mystackmark peek];# Old size of stack before current nt pushed more. 1901 set newa [expr {[$mystackast size] - $mark}] 1902 1903 set pos [$mystackloc peek] 1904 incr pos 1905 1906 if {!$newa} { 1907 set mysvalue {} 1908 } elseif {$newa == 1} { 1909 # peek 1 => single element comes back 1910 set mysvalue [list [$mystackast peek]] ; # SaveToMark 1911 } else { 1912 # peek n > 1 => list of elements comes back 1913 set mysvalue [$mystackast peekr $newa] ; # SaveToMark 1914 } 1915 1916 if {($pos - 1) == $myloc} { 1917 # The symbol did not process any input. As this is 1918 # signaled to be ok (*) we create a node covering an 1919 # empty range. (Ad *): Can happen for a RHS using 1920 # toplevel operators * or ?. 1921 set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue] 1922 } else { 1923 set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol 1924 } 1925 } 1926 1927 debug.pt/rdengine {[InstReturn]} 1928 return 1929 } 1930 1931 # # ## ### ##### ######## ############# ##################### 1932 ## API - Instructions - Terminal matching 1933 1934 method i_input_next {msg} { 1935 debug.pt/rdengine {[Instruction i_input_next $msg]} 1936 # Inlined: Getch, Expected, ClearErrors 1937 # Satisfy from input cache if possible. 1938 1939 incr myloc 1940 # May read from the input (ExtendTC), and remember the 1941 # information. Note: We are implicitly incrementing the 1942 # location! 1943 if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} { 1944 set myok 0 1945 set myerror [list $myloc [list $msg]] 1946 1947 debug.pt/rdengine {[InstReturn]} 1948 return 1949 } 1950 set mycurrent [string index $mytoken $myloc] 1951 1952 set myok 1 1953 set myerror {} 1954 1955 debug.pt/rdengine {[InstReturn]} 1956 return 1957 } 1958 1959 method i_test_char {tok} { 1960 debug.pt/rdengine {[Instruction i_test_char $tok] :: ok [expr {$tok eq $mycurrent}], [expr {$tok eq $mycurrent ? "@$myloc" : "back@[expr {$myloc-1}]"}]} 1961 set myok [expr {$tok eq $mycurrent}] 1962 my OkFailD {pt::pe terminal $tok} 1963 1964 debug.pt/rdengine {[InstReturn]} 1965 return 1966 } 1967 1968 method i_test_range {toks toke} { 1969 debug.pt/rdengine {[Instruction i_test_range $toks $toke]} 1970 set myok [expr { 1971 ([string compare $toks $mycurrent] <= 0) && 1972 ([string compare $mycurrent $toke] <= 0) 1973 }] ; # {} 1974 my OkFailD {pt::pe range $toks $toke} 1975 1976 debug.pt/rdengine {[InstReturn]} 1977 return 1978 } 1979 1980 method i_test_alnum {} { 1981 debug.pt/rdengine {[Instruction i_test_alnum]} 1982 set myok [string is alnum -strict $mycurrent] 1983 my OkFailD {pt::pe alnum} 1984 1985 debug.pt/rdengine {[InstReturn]} 1986 return 1987 } 1988 1989 method i_test_alpha {} { 1990 debug.pt/rdengine {[Instruction i_test_alpha]} 1991 set myok [string is alpha -strict $mycurrent] 1992 my OkFailD {pt::pe alpha} 1993 1994 debug.pt/rdengine {[InstReturn]} 1995 return 1996 } 1997 1998 method i_test_ascii {} { 1999 debug.pt/rdengine {[Instruction i_test_ascii]} 2000 set myok [string is ascii -strict $mycurrent] 2001 my OkFailD {pt::pe ascii} 2002 2003 debug.pt/rdengine {[InstReturn]} 2004 return 2005 } 2006 2007 method i_test_control {} { 2008 debug.pt/rdengine {[Instruction i_test_control]} 2009 set myok [string is control -strict $mycurrent] 2010 my OkFailD {pt::pe control} 2011 2012 debug.pt/rdengine {[InstReturn]} 2013 return 2014 } 2015 2016 method i_test_ddigit {} { 2017 debug.pt/rdengine {[Instruction i_test_ddigit]} 2018 set myok [string match {[0-9]} $mycurrent] 2019 my OkFailD {pt::pe ddigit} 2020 2021 debug.pt/rdengine {[InstReturn]} 2022 return 2023 } 2024 2025 method i_test_digit {} { 2026 debug.pt/rdengine {[Instruction i_test_digit]} 2027 set myok [string is digit -strict $mycurrent] 2028 my OkFailD {pt::pe digit} 2029 2030 debug.pt/rdengine {[InstReturn]} 2031 return 2032 } 2033 2034 method i_test_graph {} { 2035 debug.pt/rdengine {[Instruction i_test_graph]} 2036 set myok [string is graph -strict $mycurrent] 2037 my OkFailD {pt::pe graph} 2038 2039 debug.pt/rdengine {[InstReturn]} 2040 return 2041 } 2042 2043 method i_test_lower {} { 2044 debug.pt/rdengine {[Instruction i_test_lower]} 2045 set myok [string is lower -strict $mycurrent] 2046 my OkFailD {pt::pe lower} 2047 2048 debug.pt/rdengine {[InstReturn]} 2049 return 2050 } 2051 2052 method i_test_print {} { 2053 debug.pt/rdengine {[Instruction i_test_print]} 2054 set myok [string is print -strict $mycurrent] 2055 my OkFailD {pt::pe printable} 2056 2057 debug.pt/rdengine {[InstReturn]} 2058 return 2059 } 2060 2061 method i_test_punct {} { 2062 debug.pt/rdengine {[Instruction i_test_punct]} 2063 set myok [string is punct -strict $mycurrent] 2064 my OkFailD {pt::pe punct} 2065 2066 debug.pt/rdengine {[InstReturn]} 2067 return 2068 } 2069 2070 method i_test_space {} { 2071 debug.pt/rdengine {[Instruction i_test_space]} 2072 set myok [string is space -strict $mycurrent] 2073 my OkFailD {pt::pe space} 2074 2075 debug.pt/rdengine {[InstReturn]} 2076 return 2077 } 2078 2079 method i_test_upper {} { 2080 debug.pt/rdengine {[Instruction i_test_upper]} 2081 set myok [string is upper -strict $mycurrent] 2082 my OkFailD {pt::pe upper} 2083 2084 debug.pt/rdengine {[InstReturn]} 2085 return 2086 } 2087 2088 method i_test_wordchar {} { 2089 debug.pt/rdengine {[Instruction i_test_wordchar]} 2090 set myok [string is wordchar -strict $mycurrent] 2091 my OkFailD {pt::pe wordchar} 2092 2093 debug.pt/rdengine {[InstReturn]} 2094 return 2095 } 2096 2097 method i_test_xdigit {} { 2098 debug.pt/rdengine {[Instruction i_test_xdigit]} 2099 set myok [string is xdigit -strict $mycurrent] 2100 my OkFailD {pt::pe xdigit} 2101 2102 debug.pt/rdengine {[InstReturn]} 2103 return 2104 } 2105 2106 # # ## ### ##### ######## ############# ##################### 2107 ## Internals 2108 2109 method ExtendTC {} { 2110 if {($mychan eq {}) || 2111 [eof $mychan]} {return 0} 2112 2113 set ch [read $mychan 1] 2114 if {$ch eq {}} { 2115 return 0 2116 } 2117 2118 append mytoken $ch 2119 return 1 2120 } 2121 2122 method ExtendTCN {n} { 2123 if {($mychan eq {}) || 2124 [eof $mychan]} {return 0} 2125 2126 set str [read $mychan $n] 2127 set k [string length $str] 2128 2129 append mytoken $str 2130 if {$k < $n} { 2131 return 0 2132 } 2133 2134 return 1 2135 } 2136 2137 method OkFailD {msgcmd} { 2138 # Inlined: Expected, Unget, ClearErrors 2139 if {!$myok} { 2140 set myerror [list $myloc [list [uplevel 1 $msgcmd]]] 2141 incr myloc -1 2142 } else { 2143 set myerror {} 2144 } 2145 return 2146 } 2147 2148 # # ## ### ##### ######## ############# ##################### 2149 ## Data structures. 2150 ## Mainly the architectural state of the instance's PARAM. 2151 2152 variable \ 2153 mychan mycurrent myloc mystackloc \ 2154 myok mysvalue myerror mystackerr \ 2155 mytoken mysymbol mystackast mystackmark \ 2156 mytracecounter 2157 2158 # Parser Input (channel, location (line, column)) ........... 2159 # Token, current parsing location, stack of locations ....... 2160 # Match state . ........ ............. ..................... 2161 # Caches for tokens and nonterminals .. ..................... 2162 # Abstract syntax tree (AST) .......... ..................... 2163 2164 # # ## ### ##### ######## ############# ##################### 2165} 2166 2167# # ## ### ##### ######## ############# ##################### 2168## Ready 2169package provide pt::rde::oo 1.1 2170return 2171