1# -*- tcl -*- 2# 3# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 4# Parser Generator / Backend - Generate a grammar::mengine based parser. 5 6# This package assumes to be used from within a PAGE plugin. It uses 7# the API commands listed below. These are identical across the major 8# types of PAGE plugins, allowing this package to be used in reader, 9# transform, and writer plugins. It cannot be used in a configuration 10# plugin, and this makes no sense either. 11# 12# To ensure that our assumption is ok we require the relevant pseudo 13# package setup by the PAGE plugin management code. 14# 15# -----------------+-- 16# page_info | Reporting to the user. 17# page_warning | 18# page_error | 19# -----------------+-- 20# page_log_error | Reporting of internals. 21# page_log_warning | 22# page_log_info | 23# -----------------+-- 24 25# ### ### ### ######### ######### ######### 26## Dumping the input grammar. But not as Tcl or other code. In PEG 27## format again, pretty printing. 28 29# ### ### ### ######### ######### ######### 30## Requisites 31 32# @mdgen NODEP: page::plugin 33 34package require page::plugin ; # S.a. pseudo-package. 35 36package require textutil 37package require page::analysis::peg::emodes 38package require page::util::quote 39package require page::util::peg 40 41namespace eval ::page::gen::peg::me { 42 # Get the peg char de/encoder commands. 43 # (unquote, quote'tcl) 44 45 namespace import ::page::util::quote::* 46 namespace import ::page::util::peg::* 47} 48 49# ### ### ### ######### ######### ######### 50## API 51 52proc ::page::gen::peg::me::package {text} { 53 variable package $text 54 return 55} 56 57proc ::page::gen::peg::me::copyright {text} { 58 variable copyright $text 59 return 60} 61 62proc ::page::gen::peg::me {t chan} { 63 variable me::package 64 variable me::copyright 65 66 # Resolve the mode hints. Every gen(X) having a value of 'maybe' 67 # (or missing) is for the purposes of this code a 'yes'. 68 69 if {![page::analysis::peg::emodes::compute $t]} { 70 page_error " Unable to generate a ME parser without accept/generate properties" 71 return 72 } 73 74 foreach n [$t nodes] { 75 if {![$t keyexists $n gen] || ([$t get $n gen] eq "maybe")} { 76 $t set $n gen 1 77 } 78 if {![$t keyexists $n acc]} {$t set $n acc 1} 79 } 80 81 $t set root Pcount 0 82 83 $t set root package $package 84 $t set root copyright $copyright 85 86 # Synthesize all text fragments we need. 87 me::Synth $t 88 89 # And write the grammar text. 90 puts $chan [$t get root TEXT] 91 return 92} 93 94# ### ### ### ######### ######### ######### 95## Internal. Helpers 96 97proc ::page::gen::peg::me::Synth {t} { 98 # Phase 2: Bottom-up, synthesized attributes 99 # 100 # - Text blocks per node. 101 102 $t walk root -order post -type dfs n { 103 SynthNode $t $n 104 } 105 return 106} 107 108proc ::page::gen::peg::me::SynthNode {t n} { 109 if {$n eq "root"} { 110 set code Root 111 } elseif {[$t keyexists $n symbol]} { 112 set code Nonterminal 113 } elseif {[$t keyexists $n op]} { 114 set code [$t get $n op] 115 } else { 116 return -code error "PANIC. Bad node $n, cannot classify" 117 } 118 119 #puts stderr "SynthNode/$code $t $n" 120 121 SynthNode/$code $t $n 122 123 #SHOW [$t get $n TEXT] 1 0 124 #catch {puts stderr "\t.[$t get $n W]x[$t get $n H]"} 125 return 126} 127 128proc ::page::gen::peg::me::SynthNode/Root {t n} { 129 variable template 130 131 # Root is the grammar itself. 132 133 # Text blocks we have to combine: 134 # - Code for matching the start expression 135 # - Supporting code for the above. 136 # - Code per Nonterminal definition. 137 138 set gname [$t get root name] 139 set gstart [$t get root start] 140 set gpackage [$t get root package] 141 set gcopy [$t get root copyright] 142 143 if {$gcopy ne ""} { 144 set gcopyright "## (C) $gcopy\n" 145 } else { 146 set gcopyright "" 147 } 148 if {$gpackage eq ""} { 149 set gpackage $gname 150 } 151 152 page_info " Grammar: $gname" 153 page_info " Package: $gpackage" 154 if {$gcopy ne ""} { 155 page_info " Copyright: $gcopy" 156 } 157 158 if {$gstart ne ""} { 159 set match [textutil::indent \ 160 [$t get $gstart MATCH] \ 161 " "] 162 } else { 163 page_error " No start expression." 164 set match "" 165 } 166 167 set crules {} 168 set rules {} 169 set support [$t get [$t get root start] SUPPORT] 170 if {[string length $support]} { 171 lappend rules $support 172 lappend rules {} 173 } 174 175 lappend crules "# Grammar '$gname'" 176 lappend crules {#} 177 178 array set def [$t get root definitions] 179 foreach sym [lsort -dict [array names def]] { 180 lappend crules [Pfx "# " [$t get $def($sym) EXPR]] 181 lappend crules {#} 182 183 lappend rules [$t get $def($sym) TEXT] 184 lappend rules {} 185 } 186 set rules [join [lrange $rules 0 end-1] \n] 187 188 lappend crules {} 189 lappend crules $rules 190 191 set crules [join $crules \n] 192 193 # @PKG@ and @NAME@ are handled after the other expansions as their 194 # contents may insert additional instances of these placeholders. 195 196 $t set root TEXT \ 197 [string map \ 198 [list \ 199 @NAME@ $gname \ 200 @PKG@ $gpackage \ 201 @COPY@ $gcopyright] \ 202 [string map \ 203 [list \ 204 @MATCH@ $match \ 205 @RULES@ $crules \ 206 ] $template]] 207 return 208} 209 210proc ::page::gen::peg::me::SynthNode/Nonterminal {t n} { 211 # This is the root of a definition. 212 # 213 # The text is a procedure wrapping the match code of its 214 # expression into the required the nonterminal handling (caching 215 # and such), plus the support code for the expression matcher. 216 217 set sym [$t get $n symbol] 218 set label [$t get $n label] 219 set gen [$t get $n gen] 220 set mode [$t get $n mode] 221 222 set pe [lindex [$t children $n] 0] 223 set egen [$t get $pe gen] 224 set esupport [$t get $pe SUPPORT] 225 set ematch [$t get $pe MATCH] 226 set eexpr [$t get $pe EXPR] 227 228 # Combine the information. 229 230 set sexpr [Cat "$sym = " $eexpr] 231 232 set match {} 233 #lappend match "puts stderr \"$label << \[icl_get\]\"" 234 #lappend match {} 235 lappend match [Pfx "# " $sexpr] 236 lappend match {} 237 if {$gen} { 238 lappend match {variable ok} 239 lappend match "if \{\[inc_restore $label\]\} \{" 240 lappend match " if \{\$ok\} ias_push" 241 #lappend match " puts stderr \">> $label = \$ok (c) \[icl_get\]\"" 242 lappend match " return" 243 lappend match "\}" 244 } else { 245 set eop [$t get $pe op] 246 if { 247 ($eop eq "t") || ($eop eq "..") || 248 ($eop eq "alpha") || ($eop eq "alnum") 249 } { 250 # Required iff !dot 251 # Support for terminal expression 252 lappend match {variable ok} 253 } 254 255 #lappend match "variable ok" 256 lappend match "if \{\[inc_restore $label\]\} return" 257 #lappend match "if \{\[inc_restore $label\]\} \{" 258 #lappend match " puts stderr \">> $label = \$ok (c) \[icl_get\]\"" 259 #lappend match " return" 260 #lappend match "\}" 261 } 262 lappend match {} 263 lappend match {set pos [icl_get]} 264 if {$egen} { 265 # [*] Needed for removal of SV's from stack after handling by 266 # this symbol, only if expression actually generates an SV. 267 lappend match {set mrk [ias_mark]} 268 } 269 lappend match {} 270 lappend match $ematch 271 lappend match {} 272 273 switch -exact -- $mode { 274 value {lappend match "isv_nonterminal_reduce $label \$pos \$mrk"} 275 match {lappend match "isv_nonterminal_range $label \$pos"} 276 leaf {lappend match "isv_nonterminal_leaf $label \$pos"} 277 discard {lappend match "isv_clear"} 278 default {return -code error "Bad nonterminal mode \"$mode\""} 279 } 280 281 lappend match "inc_save $label \$pos" 282 if {$egen} { 283 # See [*], this is the removal spoken about before. 284 lappend match {ias_pop2mark $mrk} 285 } 286 if {$gen} { 287 lappend match {if {$ok} ias_push} 288 } 289 lappend match "ier_nonterminal \"Expected $label\" \$pos" 290 #lappend match "puts stderr \">> $label = \$ok \[icl_get\]\"" 291 lappend match return 292 293 # Final assembly 294 295 set pname [Call $sym] 296 set match [list [Proc $pname [join $match \n]]] 297 298 if {[string length $esupport]} { 299 lappend match {} 300 lappend match $esupport 301 } 302 303 $t set $n TEXT [join $match \n] 304 $t set $n EXPR $sexpr 305 return 306} 307 308proc ::page::gen::peg::me::SynthNode/? {t n} { 309 # The expression e? is equivalent to e/epsilon. 310 # And like this it is compiled. 311 312 set pe [lindex [$t children $n] 0] 313 set ematch [$t get $pe MATCH] 314 set esupport [$t get $pe SUPPORT] 315 set eexpr [$t get $pe EXPR] 316 set egen [$t get $pe gen] 317 set sexpr "[Cat "(? " $eexpr])" 318 319 set match {} 320 lappend match {} 321 lappend match [Pfx "# " $sexpr] 322 lappend match {} 323 lappend match {variable ok} 324 lappend match {} 325 lappend match {set pos [icl_get]} 326 lappend match {} 327 lappend match {set old [ier_get]} 328 lappend match $ematch 329 lappend match {ier_merge $old} 330 lappend match {} 331 lappend match {if {$ok} return} 332 lappend match {icl_rewind $pos} 333 lappend match {iok_ok} 334 lappend match {return} 335 336 # Final assembly 337 338 set pname [NextProc $t opt] 339 set match [list [Proc $pname [join $match \n]]] 340 if {[string length $esupport]} { 341 lappend match {} 342 lappend match $esupport 343 } 344 345 $t set $n EXPR $sexpr 346 $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]] 347 $t set $n SUPPORT [join $match \n] 348 return 349} 350 351proc ::page::gen::peg::me::SynthNode/* {t n} { 352 # Kleene star is like a repeated ? 353 354 # Note: Compilation as while loop, as done now 355 # means that the parser has no information about 356 # the intermediate structure of the input in his 357 # cache. 358 359 # Future: Create a helper symbol X and compile 360 # the expression e = e'* as: 361 # e = X; X <- (e' X)? 362 # with match data for X put into the cache. This 363 # is not exactly equivalent, the structure of the 364 # AST is different (right-nested tree instead of 365 # a list). This however can be handled with a 366 # special nonterminal mode to expand the current 367 # SV on the stack. 368 369 # Note 2: This is a transformation which can be 370 # done on the grammar itself, before the actual 371 # backend is let loose. This "strength reduction" 372 # allows us to keep this code here. 373 374 set pe [lindex [$t children $n] 0] 375 set ematch [$t get $pe MATCH] 376 set esupport [$t get $pe SUPPORT] 377 set eexpr [$t get $pe EXPR] 378 set egen [$t get $pe gen] 379 set sexpr "[Cat "(* " $eexpr])" 380 381 set match {} 382 lappend match {} 383 lappend match [Pfx "# " $sexpr] 384 lappend match {} 385 lappend match {variable ok} 386 lappend match {} 387 lappend match "while \{1\} \{" 388 lappend match { set pos [icl_get]} 389 lappend match {} 390 lappend match { set old [ier_get]} 391 lappend match [textutil::indent $ematch " "] 392 lappend match { ier_merge $old} 393 lappend match {} 394 lappend match { if {$ok} continue} 395 lappend match { break} 396 lappend match "\}" 397 lappend match {} 398 lappend match {icl_rewind $pos} 399 lappend match {iok_ok} 400 lappend match {return} 401 402 # Final assembly 403 404 set pname [NextProc $t kleene] 405 set match [list [Proc $pname [join $match \n]]] 406 if {[string length $esupport]} { 407 lappend match {} 408 lappend match $esupport 409 } 410 411 $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]] 412 $t set $n SUPPORT [join $match \n] 413 $t set $n EXPR $sexpr 414 return 415} 416 417proc ::page::gen::peg::me::SynthNode/+ {t n} { 418 # Positive Kleene star x+ is equivalent to x x* 419 # This is how it is compiled. See also the notes 420 # at the * above, they apply in essence here as 421 # well, except that the transformat scheme is 422 # slighty different: 423 # 424 # e = e'* ==> e = X; X <- e' X? 425 426 set pe [lindex [$t children $n] 0] 427 set ematch [$t get $pe MATCH] 428 set esupport [$t get $pe SUPPORT] 429 set eexpr [$t get $pe EXPR] 430 set egen [$t get $pe gen] 431 set sexpr "[Cat "(+ " $eexpr])" 432 433 set match {} 434 lappend match {} 435 lappend match [Pfx "# " $sexpr] 436 lappend match {} 437 lappend match {variable ok} 438 lappend match {} 439 lappend match {set pos [icl_get]} 440 lappend match {} 441 lappend match {set old [ier_get]} 442 lappend match $ematch 443 lappend match {ier_merge $old} 444 lappend match {} 445 lappend match "if \{!\$ok\} \{" 446 lappend match { icl_rewind $pos} 447 lappend match { return} 448 lappend match "\}" 449 lappend match {} 450 lappend match "while \{1\} \{" 451 lappend match { set pos [icl_get]} 452 lappend match {} 453 lappend match { set old [ier_get]} 454 lappend match [textutil::indent $ematch " "] 455 lappend match { ier_merge $old} 456 lappend match {} 457 lappend match { if {$ok} continue} 458 lappend match { break} 459 lappend match "\}" 460 lappend match {} 461 lappend match {icl_rewind $pos} 462 lappend match {iok_ok} 463 lappend match {return} 464 465 # Final assembly 466 467 set pname [NextProc $t pkleene] 468 set match [list [Proc $pname [join $match \n]]] 469 if {[string length $esupport]} { 470 lappend match {} 471 lappend match $esupport 472 } 473 474 $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]] 475 $t set $n SUPPORT [join $match \n] 476 $t set $n EXPR $sexpr 477 return 478} 479 480proc ::page::gen::peg::me::SynthNode// {t n} { 481 set args [$t children $n] 482 483 if {![llength $args]} { 484 error "PANIC. Empty choice." 485 486 } elseif {[llength $args] == 1} { 487 # A choice over one branch is no real choice. The code 488 # generated for the child applies here as well. 489 490 set pe [lindex $args 0] 491 $t set $n MATCH [$t get $pe MATCH] 492 $t set $n SUPPORT [$t get $pe SUPPORT] 493 return 494 } 495 496 # Choice over at least two branches. 497 498 set match {} 499 set support {} 500 set sexpr {} 501 502 lappend match {} 503 lappend match {} 504 lappend match {variable ok} 505 lappend match {} 506 lappend match {set pos [icl_get]} 507 foreach pe $args { 508 lappend match {} 509 510 set ematch [$t get $pe MATCH] 511 set esupport [$t get $pe SUPPORT] 512 set eexpr [$t get $pe EXPR] 513 set egen [$t get $pe gen] 514 515 # Note: We do not check for static match results. Doing so is 516 # an optimization we can do earlier, directly on the tree. 517 518 lappend sexpr $eexpr 519 520 if {[string length $esupport]} { 521 lappend support {} 522 lappend support $esupport 523 } 524 525 if {$egen} { 526 lappend match "set mrk \[ias_mark\]" 527 } 528 529 lappend match "set old \[ier_get\]" 530 lappend match $ematch 531 lappend match "ier_merge \$old" 532 lappend match {} 533 lappend match "if \{\$ok\} return" 534 535 if {$egen} { 536 lappend match "ias_pop2mark \$mrk" 537 } 538 lappend match "icl_rewind \$pos" 539 } 540 lappend match {} 541 lappend match return 542 543 # Final assembly 544 545 set sexpr "[Cat "(/ " [join $sexpr \n]])" 546 set match [linsert $match 1 [Pfx "# " $sexpr]] 547 548 set pname [NextProc $t bra] 549 set match [list [Proc $pname [join $match \n]]] 550 if {[llength $support]} { 551 lappend match {} 552 lappend match [join [lrange $support 1 end] \n] 553 } 554 555 $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]] 556 $t set $n SUPPORT [join $match \n] 557 $t set $n EXPR $sexpr 558 return 559} 560 561proc ::page::gen::peg::me::SynthNode/x {t n} { 562 set args [$t children $n] 563 564 if {![llength $args]} { 565 error "PANIC. Empty sequence." 566 567 } elseif {[llength $args] == 1} { 568 # A sequence of one element is no real sequence. The code 569 # generated for the child applies here as well. 570 571 set pe [lindex $args 0] 572 $t set $n MATCH [$t get $pe MATCH] 573 $t set $n SUPPORT [$t get $pe SUPPORT] 574 $t set $n EXPR [$t get $pe EXPRE] 575 return 576 } 577 578 # Sequence of at least two elements. 579 580 set match {} 581 set support {} 582 set sexpr {} 583 set gen 0 584 585 lappend match {} 586 lappend match {} 587 lappend match {variable ok} 588 lappend match {} 589 lappend match {set pos [icl_get]} 590 591 foreach pe $args { 592 lappend match {} 593 594 set ematch [$t get $pe MATCH] 595 set esupport [$t get $pe SUPPORT] 596 set eexpr [$t get $pe EXPR] 597 set egen [$t get $pe gen] 598 599 lappend sexpr $eexpr 600 601 if {[string length $esupport]} { 602 lappend support {} 603 lappend support $esupport 604 } 605 606 if {$egen && !$gen} { 607 # From here on out is the sequence 608 # able to generate semantic values 609 # which have to be canceled when 610 # backtracking. 611 612 lappend match "set mrk \[ias_mark\]" 613 lappend match {} 614 set gen 1 615 } 616 617 lappend match "set old \[ier_get\]" 618 lappend match $ematch 619 lappend match "ier_merge \$old" 620 lappend match {} 621 622 if {$gen} { 623 lappend match "if \{!\$ok\} \{" 624 lappend match " ias_pop2mark \$mrk" 625 lappend match " icl_rewind \$pos" 626 lappend match " return" 627 lappend match "\}" 628 } else { 629 lappend match "if \{!\$ok\} \{icl_rewind \$pos \; return\}" 630 } 631 } 632 lappend match {} 633 lappend match return 634 635 # Final assembly 636 637 set sexpr "[Cat "(x " [join $sexpr \n]])" 638 set match [linsert $match 1 [Pfx "# " $sexpr]] 639 640 set pname [NextProc $t seq] 641 set match [list [Proc $pname [join $match \n]]] 642 if {[llength $support]} { 643 lappend match {} 644 lappend match [join [lrange $support 1 end] \n] 645 } 646 647 $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]] 648 $t set $n SUPPORT [join $match \n] 649 $t set $n EXPR $sexpr 650 return 651} 652 653proc ::page::gen::peg::me::SynthNode/& {t n} { 654 SynthLookahead $t $n no 655 return 656} 657 658proc ::page::gen::peg::me::SynthNode/! {t n} { 659 SynthLookahead $t $n yes 660 return 661} 662 663proc ::page::gen::peg::me::SynthNode/dot {t n} { 664 SynthTerminal $t $n \ 665 "any character" {} 666 $t set $n EXPR "(dot)" 667 return 668} 669 670proc ::page::gen::peg::me::SynthNode/epsilon {t n} { 671 $t set $n MATCH iok_ok 672 $t set $n SUPPORT {} 673 $t set $n EXPR "(epsilon)" 674 return 675} 676 677proc ::page::gen::peg::me::SynthNode/alnum {t n} { 678 SynthClass $t $n alnum 679 return 680} 681 682proc ::page::gen::peg::me::SynthNode/alpha {t n} { 683 SynthClass $t $n alpha 684 return 685} 686 687proc ::page::gen::peg::me::SynthNode/.. {t n} { 688 # Range is [x-y] 689 690 set b [$t get $n begin] 691 set e [$t get $n end] 692 693 set tb [quote'tcl $b] 694 set te [quote'tcl $e] 695 696 set pb [quote'tclstr $b] 697 set pe [quote'tclstr $e] 698 699 set cb [quote'tclcom $b] 700 set ce [quote'tclcom $e] 701 702 SynthTerminal $t $n \ 703 "\\\[${pb}..${pe}\\\]" \ 704 "ict_match_tokrange $tb $te" 705 $t set $n EXPR "(.. $cb $ce)" 706 return 707} 708 709proc ::page::gen::peg::me::SynthNode/t {t n} { 710 # Terminal node. Primitive matching. 711 # Code is parameterized by gen(X) of this node X. 712 713 set ch [$t get $n char] 714 set tch [quote'tcl $ch] 715 set pch [quote'tclstr $ch] 716 set cch [quote'tclcom $ch] 717 718 SynthTerminal $t $n \ 719 $pch \ 720 "ict_match_token $tch" 721 $t set $n EXPR "(t $cch)" 722 return 723} 724 725proc ::page::gen::peg::me::SynthNode/n {t n} { 726 # Nonterminal node. Primitive matching. 727 # The code is parameterized by acc(X) of this node X, and gen(D) 728 # of the invoked nonterminal D. 729 730 set sym [$t get $n sym] 731 set def [$t get $n def] 732 733 if {$def eq ""} { 734 # Invokation of an undefined nonterminal. This will always fail. 735 set match "iok_fail ; # Match for undefined symbol '$sym'." 736 } else { 737 # Combinations 738 # Acc Gen Action 739 # --- --- ------ 740 # 0 0 Plain match 741 # 0 1 Match with canceling of the semantic value. 742 # 1 0 Plain match 743 # 1 1 Plain match 744 # --- --- ------ 745 746 if {[$t get $n acc] || ![$t get $def gen]} { 747 set match [Call $sym] 748 } else { 749 set match {} 750 lappend match "set p$sym \[ias_mark\]" 751 lappend match [Call $sym] 752 lappend match "ias_pop2mark \$p$sym" 753 set match [join $match \n] 754 } 755 } 756 757 set sexpr "(n $sym)" 758 $t set $n EXPR $sexpr 759 $t set $n MATCH "$match ; # $sexpr" 760 $t set $n SUPPORT {} 761 return 762} 763 764proc ::page::gen::peg::me::SynthLookahead {t n negated} { 765 # Note: Per the rules about expression modes (! is a lookahead 766 # ____| operator) this node has a mode of 'discard', and its child 767 # ____| has so as well. 768 769 # assert t get n mode == discard 770 # assert t get pe mode == discard 771 772 set op [$t get $n op] 773 set pe [lindex [$t children $n] 0] 774 set eop [$t get $pe op] 775 set ematch [$t get $pe MATCH] 776 set esupport [$t get $pe SUPPORT] 777 set eexpr [$t get $pe EXPR] 778 set pname [NextProc $t bang] 779 780 set match {} 781 782 if { 783 ($eop eq "t") || ($eop eq "..") || 784 ($eop eq "alpha") || ($eop eq "alnum") 785 } { 786 # Required iff !dot 787 # Support for terminal expression 788 lappend match {variable ok} 789 lappend match {} 790 } 791 792 lappend match {set pos [icl_get]} 793 lappend match {} 794 lappend match $ematch 795 lappend match {} 796 lappend match {icl_rewind $pos} 797 798 if {$negated} { 799 lappend match {iok_negate} 800 } 801 802 lappend match return 803 804 set match [list [Proc $pname [join $match \n]]] 805 if {[string length $esupport]} { 806 lappend match {} 807 lappend match $esupport 808 } 809 810 $t set $n MATCH $pname 811 $t set $n SUPPORT [join $match \n] 812 $t set $n EXPR "($op $eexpr)" 813 return 814} 815 816proc ::page::gen::peg::me::SynthClass {t n op} { 817 SynthTerminal $t $n \ 818 <$op> \ 819 "ict_match_tokclass $op" 820 $t set $n EXPR ($op) 821 return 822} 823 824proc ::page::gen::peg::me::SynthTerminal {t n msg cmd} { 825 set match {} 826 lappend match "ict_advance \"Expected $msg (got EOF)\"" 827 828 if {$cmd ne ""} { 829 lappend match "if \{\$ok\} \{$cmd \"Expected $msg\"\}" 830 } 831 if {[$t get $n gen]} { 832 lappend match "if \{\$ok\} isv_terminal" 833 } 834 835 $t set $n MATCH [join $match \n] 836 $t set $n SUPPORT {} 837 return 838} 839 840proc ::page::gen::peg::me::Call {sym} { 841 # Generator for proc names (nonterminal symbols). 842 return matchSymbol_$sym 843} 844 845proc ::page::gen::peg::me::NextProc {t {mark {}}} { 846 set count [$t get root Pcount] 847 incr count 848 $t set root Pcount $count 849 return e$mark$count 850} 851 852proc ::page::gen::peg::me::Proc {name body} { 853 set script {} 854 lappend script "proc ::@PKG@::$name \{\} \{" 855 lappend script [::textutil::indent $body " "] 856 lappend script "\}" 857 return [join $script \n] 858} 859 860proc ::page::gen::peg::me::Cat {prefix suffix} { 861 return "$prefix[textutil::indent $suffix [textutil::blank [string length $prefix]] 1]" 862} 863 864proc ::page::gen::peg::me::Pfx {prefix suffix} { 865 return [textutil::indent $suffix $prefix] 866} 867 868# ### ### ### ######### ######### ######### 869## Internal. Strings. 870 871namespace eval ::page::gen::peg::me { 872 873 variable here [file dirname [info script]] 874 variable template_file [file join $here gen_peg_me.template] 875 876 variable ch 877 variable template \ 878 [string trimright [read [set ch [open $template_file r]]][close $ch]] 879 unset ch 880 881 variable package "" 882 variable copyright "" 883} 884 885# ### ### ### ######### ######### ######### 886## Ready 887 888package provide page::gen::peg::me 0.1 889