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