1# peg_to_param.tcl -- 2# 3# Conversion of PEG to Tcl/C PARAM, customizable text blocks. 4# 5# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net> 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: pt_peg_to_tclparam.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $ 11 12# This package takes the canonical serialization of a parsing 13# expression grammar and produces text in PARAM assembler, i.e. 14# readable machine code for the PARAM virtual machine. 15 16## NOTE: Should have cheat sheet of PARAM instructions (which parts of 17## the arch state they touch, and secondly, bigger effects). 18 19# ### ### ### ######### ######### ######### 20## Requisites 21 22package require Tcl 8.5 23package require pt::peg ; # Verification that the input 24 # is proper. 25package require pt::pe ; # Walking an expression. 26package require pt::pe::op ; # String/Class fusing 27package require text::write ; # Text generation support 28package require char 29 30# ### ### ### ######### ######### ######### 31## 32 33namespace eval ::pt::peg::to::tclparam { 34 namespace export \ 35 reset configure convert 36 37 namespace ensemble create 38} 39 40# ### ### ### ######### ######### ######### 41## API. 42 43proc ::pt::peg::to::tclparam::reset {} { 44 variable template @code@ 45 variable name a_pe_grammar 46 variable file unknown 47 variable user unknown 48 variable self {} 49 variable ns :: 50 variable runtime {} 51 variable def proc 52 variable main __main 53 variable indent 0 54 variable prelude {} 55 return 56} 57 58proc ::pt::peg::to::tclparam::configure {args} { 59 variable template 60 variable name 61 variable file 62 variable user 63 variable self 64 variable ns 65 variable runtime 66 variable def 67 variable main 68 variable omap 69 variable indent 70 variable prelude 71 72 if {[llength $args] == 0} { 73 return [list \ 74 -indent $indent \ 75 -runtime-command $runtime \ 76 -self-command $self \ 77 -proc-command $def \ 78 -namespace $ns \ 79 -main $main \ 80 -file $file \ 81 -name $name \ 82 -template $template \ 83 -user $user] 84 } elseif {[llength $args] == 1} { 85 lassign $args option 86 set variable [string range $option 1 end] 87 if {[info exists omap($variable)]} { 88 return [set $omap($variable)] 89 } else { 90 return -code error "Expected one of -indent, -runtime-command, -proc-command, -self-command, -namespace, -main, -file, -name, -template, or -user, got \"$option\"" 91 } 92 } elseif {[llength $args] % 2 == 0} { 93 foreach {option value} $args { 94 set variable [string range $option 1 end] 95 if {![info exists omap($variable)]} { 96 return -code error "Expected one of -indent, -runtime-command, -proc-command, -self-command, -namespace, -main, -file, -name, -template, or -user, got \"$option\"" 97 } 98 } 99 foreach {option value} $args { 100 set variable $omap([string range $option 1 end]) 101 switch -exact -- $variable { 102 template { 103 if {$value eq {}} { 104 return -code error "Expected template, got the empty string" 105 } 106 } 107 indent { 108 if {![string is integer -strict $value] || ($value < 0)} { 109 return -code error "Expected int > 0, got \"$value\"" 110 } 111 } 112 runtime - 113 self - 114 def - 115 ns - 116 main - 117 name - 118 file - 119 user { } 120 } 121 set $variable $value 122 } 123 } else { 124 return -code error {wrong#args, expected option value ...} 125 } 126} 127 128proc ::pt::peg::to::tclparam::convert {serial} { 129 variable template 130 variable name 131 variable file 132 variable user 133 variable self 134 variable ns 135 variable runtime 136 variable def 137 variable main 138 variable indent 139 variable prelude 140 141 Op::Asm::Setup 142 143 ::pt::peg verify-as-canonical $serial 144 145 # Unpack the serialization, known as canonical 146 array set peg $serial 147 array set peg $peg(pt::grammar::peg) 148 unset peg(pt::grammar::peg) 149 150 set modes {} 151 foreach {symbol symdef} $peg(rules) { 152 lassign $symdef _ is _ mode 153 lappend modes $symbol $mode 154 } 155 156 text::write reset 157 set blocks {} 158 159 # Translate all expressions/symbols, results are stored in 160 # text::write blocks, command results are the block ids. 161 162 set start [pt::pe::op flatten \ 163 [pt::pe::op fusechars \ 164 [pt::pe::op flatten \ 165 $peg(start)]]] 166 167 lappend blocks [set start [Expression $start $modes]] 168 169 foreach {symbol symdef} $peg(rules) { 170 lassign $symdef _ is _ mode 171 set is [pt::pe::op flatten \ 172 [pt::pe::op fusechars \ 173 [pt::pe::op flatten \ 174 $is]]] 175 lappend blocks [Symbol $symbol $mode $is $modes] 176 } 177 178 # Assemble the output from the stored blocks. 179 text::write clear 180 Op::Asm::Header {Grammar Start Expression} 181 Op::Asm::FunStart @main@ 182 Op::Asm::Call $start 0 183 Op::Asm::Tcl return 184 Op::Asm::FunClose 185 186 foreach b $blocks { 187 Op::Asm::Use $b 188 text::write /line 189 } 190 191 # At last retrieve the fully assembled result and integrate with 192 # the chosen template. 193 194 set code [text::write get] 195 if {$indent} { 196 set code [Indent $code $indent] 197 } 198 199 set pre $prelude ; if {$pre ne {}} { set pre " $pre" } 200 set run $runtime ; if {$run ne {}} { append run { } } 201 set slf $self ; if {$slf ne {}} { append slf { } } 202 203 set code [string map \ 204 [list \ 205 @user@ $user \ 206 @format@ Tcl/PARAM \ 207 @file@ $file \ 208 @name@ $name \ 209 @code@ $code] $template] 210 set code [string map \ 211 [list \ 212 {@runtime@ } $run \ 213 { @prelude@} $pre \ 214 {@self@ } $slf \ 215 @def@ $def \ 216 @ns@ $ns \ 217 @main@ $main] $code] 218 219 return $code 220 # ### ### ### ######### ######### ######### 221} 222 223# ### ### ### ######### ######### ######### 224## Internals 225 226proc ::pt::peg::to::tclparam::Indent {text n} { 227 set b [string repeat { } $n] 228 return $b[join [split $text \n] \n$b] 229} 230 231proc ::pt::peg::to::tclparam::Expression {expression modes} { 232 # We first flatten for a maximum amount of adjacent terminals and 233 # ranges, then fuse these into strings and classes, then flatten 234 # again, eliminating all sequences and choices fully subsumed by 235 # the new elements. 236 237 return [pt::pe bottomup \ 238 [list [namespace current]::Op $modes] \ 239 $expression] 240} 241 242proc ::pt::peg::to::tclparam::Symbol {symbol mode rhs modes} { 243 244 set expression [Expression $rhs $modes] 245 246 text::write clear 247 Op::Asm::Header "$mode Symbol '$symbol'" 248 text::write store FUN_HEADER 249 250 Op::Asm::Start 251 Op::Asm::ReExpression $symbol 252 Op::Asm::GenAST $expression 253 Op::Asm::PE $rhs 254 255 set gen [dict get $result gen] 256 257 Op::Asm::Function sym_$symbol { 258 259 # We have six possibilites for the combination of AST node 260 # generation by the rhs and AST generation by the symbol. Two 261 # of these (leaf/0, value/0 coincide, leaving 5). This 262 # controls the use of AS/ARS instructions. 263 264 switch -exact -- $mode/$gen { 265 value/1 { 266 # Generate value for symbol, rhs may have generated 267 # AST nodes as well, keep rhs 268 269 #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{ 270 #Op::Asm::>>> 4 271 #Op::Asm::Ins i_loc_push 272 #Op::Asm::Ins i_ast_push 273 274 Op::Asm::Ins si:value_symbol_start $symbol 275 Op::Asm::Call $expression 276 Op::Asm::Ins si:reduce_symbol_end $symbol 277 278 #Op::Asm::Ins i_value_clear/reduce $symbol 279 #Op::Asm::Ins i_symbol_save $symbol 280 #Op::Asm::Ins i_error_nonterminal $symbol 281 #Op::Asm::Ins i_ast_pop_rewind 282 #Op::Asm::Ins i_loc_pop_discard 283 #Op::Asm::<<< 4 284 #Op::Asm::Tcl \} 285 #Op::Asm::Ins i:ok_ast_value_push 286 } 287 leaf/0 - 288 value/0 { 289 # Generate value for symbol, rhs cannot generate its 290 # own AST nodes => leaf/0. 291 292 #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{ 293 #Op::Asm::>>> 4 294 #Op::Asm::Ins i_loc_push 295 296 Op::Asm::Ins si:void_symbol_start $symbol 297 Op::Asm::Call $expression 298 Op::Asm::Ins si:void_leaf_symbol_end $symbol 299 300 #Op::Asm::Ins i_value_clear/leaf $symbol 301 #Op::Asm::Ins i_symbol_save $symbol 302 #Op::Asm::Ins i_error_nonterminal $symbol 303 #Op::Asm::Ins i_loc_pop_discard 304 #Op::Asm::<<< 4 305 #Op::Asm::Tcl \} 306 #Op::Asm::Ins i:ok_ast_value_push 307 } 308 leaf/1 { 309 # Generate value for symbol, rhs may have generated 310 # AST nodes as well, discard rhs. 311 312 #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{ 313 #Op::Asm::>>> 4 314 #Op::Asm::Ins i_loc_push 315 #Op::Asm::Ins i_ast_push 316 317 Op::Asm::Ins si:value_symbol_start $symbol 318 Op::Asm::Call $expression 319 Op::Asm::Ins si:value_leaf_symbol_end $symbol 320 321 #Op::Asm::Ins i_value_clear/leaf $symbol 322 #Op::Asm::Ins i_symbol_save $symbol 323 #Op::Asm::Ins i_error_nonterminal $symbol 324 #Op::Asm::Ins i_ast_pop_rewind 325 #Op::Asm::Ins i_loc_pop_discard 326 #Op::Asm::<<< 4 327 #Op::Asm::Tcl \} 328 #Op::Asm::Ins i:ok_ast_value_push 329 } 330 void/1 { 331 # Generate no value for symbol, rhs may have generated 332 # AST nodes as well, discard rhs. 333 # // test case missing // 334 335 #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{ 336 #Op::Asm::>>> 4 337 #Op::Asm::Ins i_loc_push 338 #Op::Asm::Ins i_ast_push 339 340 Op::Asm::Ins si:value_void_symbol_start $symbol 341 Op::Asm::Call $expression 342 Op::Asm::Ins si:value_clear_symbol_end $symbol 343 344 #Op::Asm::Ins i_value_clear 345 #Op::Asm::Ins i_symbol_save $symbol 346 #Op::Asm::Ins i_error_nonterminal $symbol 347 #Op::Asm::Ins i_ast_pop_rewind 348 #Op::Asm::Ins i_loc_pop_discard 349 #Op::Asm::<<< 4 350 #Op::Asm::Tcl \} 351 } 352 void/0 { 353 # Generate no value for symbol, rhs cannot generate 354 # its own AST nodes. Nothing to save nor discard. 355 356 #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{ 357 #Op::Asm::>>> 4 358 #Op::Asm::Ins i_loc_push 359 360 Op::Asm::Ins si:void_void_symbol_start $symbol 361 Op::Asm::Call $expression 362 Op::Asm::Ins si:void_clear_symbol_end $symbol 363 364 #Op::Asm::Ins i_value_clear 365 #Op::Asm::Ins i_symbol_save $symbol 366 #Op::Asm::Ins i_error_nonterminal $symbol 367 #Op::Asm::Ins i_loc_pop_discard 368 #Op::Asm::<<< 4 369 #Op::Asm::Tcl \} 370 } 371 } 372 } $expression 373 Op::Asm::Done 374} 375 376namespace eval ::pt::peg::to::tclparam::Op { 377 namespace export \ 378 alpha alnum ascii digit graph lower print \ 379 punct space upper wordchar xdigit ddigit \ 380 dot epsilon t .. n ? * + & ! x / str cl 381} 382 383proc ::pt::peg::to::tclparam::Op {modes pe op arguments} { 384 return [namespace eval Op [list $op $modes {*}$arguments]] 385} 386 387proc ::pt::peg::to::tclparam::Op::epsilon {modes} { 388 Asm::Start 389 Asm::ReExpression epsilon 390 Asm::Direct { 391 Asm::Ins i_status_ok 392 } 393 Asm::Done 394} 395 396proc ::pt::peg::to::tclparam::Op::dot {modes} { 397 Asm::Start 398 Asm::ReExpression dot 399 Asm::Direct { 400 Asm::Ins i_input_next dot 401 } 402 Asm::Done 403} 404 405foreach test { 406 alpha alnum ascii digit graph lower print 407 punct space upper wordchar xdigit ddigit 408} { 409 proc ::pt::peg::to::tclparam::Op::$test {modes} \ 410 [string map [list @ $test] { 411 Asm::Start 412 Asm::ReExpression @ 413 Asm::Direct { 414 #Asm::Ins i_input_next @ 415 #Asm::Ins i:fail_return 416 #Asm::Ins i_test_@ 417 418 Asm::Ins si:next_@ 419 } 420 Asm::Done 421 }] 422} 423 424proc ::pt::peg::to::tclparam::Op::t {modes char} { 425 Asm::Start 426 Asm::ReTerminal t $char 427 Asm::Direct { 428 set c [char quote tcl $char] 429 430 #Asm::Ins i_input_next "\{t $c\}" 431 #Asm::Ins i:fail_return 432 #Asm::Ins i_test_char $c 433 434 Asm::Ins si:next_char $c 435 } 436 Asm::Done 437} 438 439proc ::pt::peg::to::tclparam::Op::.. {modes chstart chend} { 440 Asm::Start 441 Asm::ReTerminal .. $chstart $chend 442 Asm::Direct { 443 set s [char quote tcl $chstart] 444 set e [char quote tcl $chend] 445 446 #Asm::Ins i_input_next "\{.. $s $e\}" 447 #Asm::Ins i:fail_return 448 #Asm::Ins i_test_range $s $e 449 450 Asm::Ins si:next_range $s $e 451 } 452 Asm::Done 453} 454 455proc ::pt::peg::to::tclparam::Op::str {modes args} { 456 Asm::Start 457 Asm::ReTerminal str {*}$args 458 Asm::Direct { 459 set str [join [struct::list map $args {char quote tcl}] {}] 460 461 # Without fusing this would be rendered as a sequence of 462 # characters, with associated stack churn for each character/part 463 # (See Op::x, void/all). 464 465 Asm::Ins si:next_str $str 466 } 467 Asm::Done 468} 469 470proc ::pt::peg::to::tclparam::Op::cl {modes args} { 471 # rorc = Range-OR-Char-List 472 Asm::Start 473 Asm::ReTerminal cl {*}$args 474 Asm::Direct { 475 # Without fusing this would be rendered as a choice of 476 # characters, with associated stack churn for each 477 # character/branch (See Op::/, void/all). 478 479 set cl [join [struct::list map $args [namespace current]::Range] {}] 480 481 Asm::Ins si:next_class $cl 482 } 483 Asm::Done 484} 485 486proc ::pt::peg::to::tclparam::Op::Range {rorc} { 487 # See also pt::peg::to::peg 488 489 # We use string ops here to distinguish terminals and ranges. The 490 # input can be a single char, not a list, and further the char may 491 # not be a proper list. Example: double-apostroph. 492 if {[string length $rorc] > 1} { 493 lassign $rorc s e 494 495 # The whole range is expanded into its full set of characters. 496 # Beware, this may blow the process if the range tries to 497 # match a substantial part of the unicode character set. We 498 # should see if there is a way to keep it encoded as range 499 # without giving up on the fast matching. 500 501 set s [scan $s %c] 502 set e [scan $e %c] 503 504 set res {} 505 for {set i $s} {$i <= $e} {incr i} { 506 append res [format %c $i] 507 } 508 return $res 509 } else { 510 return [char quote tcl $rorc] 511 } 512} 513 514proc ::pt::peg::to::tclparam::Op::n {modes symbol} { 515 # symbol mode determines AST generation 516 # void => non-generative, 517 # leaf/value => generative. 518 519 Asm::Start 520 Asm::ReTerminal n $symbol 521 522 if {![dict exists $modes $symbol]} { 523 # Incomplete grammar. The symbol has no definition. 524 Asm::Direct { 525 Asm::Ins i_status_fail "; # Undefined symbol '$symbol'" 526 } 527 } else { 528 Asm::GenAST [list gen [expr { [dict get $modes $symbol] ne "void" }]] 529 Asm::Direct { 530 Asm::Self sym_$symbol 531 } 532 } 533 Asm::Done 534} 535 536proc ::pt::peg::to::tclparam::Op::& {modes expression} { 537 # Note: This operation could be inlined, as it has no special 538 # control flow. Not done to make the higher-level ops are 539 # similar in construction and use = consistent and simple. 540 541 Asm::Start 542 Asm::ReExpression & $expression 543 Asm::GenAST $expression 544 545 Asm::Function [Asm::NewBlock ahead] { 546 Asm::Ins i_loc_push 547 Asm::Call $expression 548 Asm::Ins i_loc_pop_rewind 549 } $expression 550 Asm::Done 551} 552 553proc ::pt::peg::to::tclparam::Op::! {modes expression} { 554 # Note: This operation could be inlined, as it has no special 555 # control flow. Not done to make the higher-level ops are 556 # similar in construction and use = consistent and simple. 557 558 Asm::Start 559 Asm::ReExpression ! $expression 560 if {[dict get $expression gen]} { 561 Asm::Function [Asm::NewBlock notahead] { 562 # The sub-expression may generate AST elements. We must 563 # not pass them through. 564 565 #Asm::Ins i_loc_push 566 #Asm::Ins i_ast_push 567 568 Asm::Ins si:value_notahead_start 569 570 Asm::Call $expression 571 572 #Asm::Ins i_ast_pop_discard/rewind 573 #Asm::Ins i_loc_pop_rewind 574 #Asm::Ins i_status_negate 575 576 Asm::Ins si:void_notahead_exit 577 } $expression 578 } else { 579 Asm::Function [Asm::NewBlock notahead] { 580 # The sub-expression cannot generate AST elements. We can 581 # ignore AS/ARS, simplifying the code. 582 583 Asm::Ins i_loc_push 584 585 Asm::Call $expression 586 587 #Asm::Ins i_loc_pop_rewind 588 #Asm::Ins i_status_negate 589 590 Asm::Ins si:void_notahead_exit 591 } $expression 592 } 593 Asm::Done 594} 595 596proc ::pt::peg::to::tclparam::Op::? {modes expression} { 597 # Note: This operation could be inlined, as it has no special 598 # control flow. Not done to make the higher-level ops are 599 # similar in construction and use => consistent and simple. 600 601 Asm::Start 602 Asm::ReExpression ? $expression 603 Asm::GenAST $expression 604 605 Asm::Function [Asm::NewBlock optional] { 606 #Asm::Ins i_loc_push 607 #Asm::Ins i_error_push 608 609 Asm::Ins si:void2_state_push 610 611 Asm::Call $expression 612 613 #Asm::Ins i_error_pop_merge 614 #Asm::Ins i_loc_pop_rewind/discard 615 #Asm::Ins i_status_ok 616 617 Asm::Ins si:void_state_merge_ok 618 } $expression 619 Asm::Done 620} 621 622proc ::pt::peg::to::tclparam::Op::* {modes expression} { 623 Asm::Start 624 Asm::ReExpression * $expression 625 Asm::GenAST $expression 626 627 Asm::Function [Asm::NewBlock kleene] { 628 Asm::Tcl while \{1\} \{ 629 Asm::>>> 4 630 #Asm::Ins i_loc_push 631 #Asm::Ins i_error_push 632 633 Asm::Ins si:void2_state_push 634 635 Asm::Call $expression 636 637 #Asm::Ins i_error_pop_merge 638 #Asm::Ins i_loc_pop_rewind/discard 639 #Asm::Ins i:fail_status_ok 640 #Asm::Tcl i:fail_return 641 642 Asm::Ins si:kleene_close 643 Asm::<<< 4 644 Asm::Tcl \} 645 # FAILED, clean up and return OK. 646 } $expression 647 Asm::Done 648} 649 650proc ::pt::peg::to::tclparam::Op::+ {modes expression} { 651 Asm::Start 652 Asm::ReExpression + $expression 653 Asm::GenAST $expression 654 655 Asm::Function [Asm::NewBlock poskleene] { 656 Asm::Ins i_loc_push 657 658 Asm::Call $expression 659 660 #Asm::Ins i_loc_pop_rewind/discard 661 #Asm::Ins i:fail_return 662 663 Asm::Ins si:kleene_abort 664 665 Asm::Tcl while \{1\} \{ 666 Asm::>>> 4 667 #Asm::Ins i_loc_push 668 #Asm::Ins i_error_push 669 670 Asm::Ins si:void2_state_push 671 672 Asm::Call $expression 673 674 #Asm::Ins i_error_pop_merge 675 #Asm::Ins i_loc_pop_rewind/discard 676 #Asm::Ins i:ok_continue 677 #Asm::Tcl break 678 679 Asm::Ins si:kleene_close 680 Asm::<<< 4 681 Asm::Tcl \} 682 # FAILED, clean up and return OK. 683 #Asm::Ins i_status_ok 684 685 } $expression 686 Asm::Done 687} 688 689proc ::pt::peg::to::tclparam::Op::x {modes args} { 690 if {[llength $args] == 1} { 691 return [lindex $args 0] 692 } 693 694 Asm::Start 695 Asm::ReExpression x {*}$args 696 set gens [Asm::GenAST {*}$args] 697 698 # We have three possibilities regarding AST node generation, each 699 # requiring a slightly different instruction sequence. 700 701 # i. gen == 0 <=> No node generation at all. 702 # ii. gens[0] == 1 <=> We may have nodes from the beginning. 703 # iii. <=> Node generation starts in the middle. 704 705 if {![dict get $result gen]} { 706 set mode none 707 } elseif {[lindex $gens 0]} { 708 set mode all 709 } else { 710 set mode some 711 } 712 713 Asm::Function [Asm::NewBlock sequence] { 714 switch -exact -- $mode { 715 none { 716 # (Ad i) No AST node generation at all. 717 718 Asm::xinit0 719 720 # Note: This loop runs at code generation time. At 721 # runtime the entire construction is essentially a 722 # fully unrolled loop, with each iteration having its 723 # own block of instructions. 724 725 foreach expression [lrange $args 0 end-1] { 726 Asm::Call $expression 727 Asm::xinter00 728 } 729 Asm::Call [lindex $args end] 730 Asm::xexit0 731 } 732 all { 733 # (Ad ii) AST node generation from start to end. 734 735 Asm::xinit1 736 737 # Note: This loop runs at code generation time. At 738 # runtime the entire construction is essentially a 739 # fully unrolled loop, with each iteration having its 740 # own block of instructions. 741 742 foreach expression [lrange $args 0 end-1] { 743 Asm::Call $expression 744 Asm::xinter11 745 } 746 Asm::Call [lindex $args end] 747 Asm::xexit1 748 } 749 some { 750 # (Ad iii). Start without AST nodes, later parts do 751 # AST nodes. 752 753 Asm::xinit0 754 755 # Note: This loop runs at code generation time. At 756 # runtime the entire construction is essentially a 757 # fully unrolled loop, with each iteration having its 758 # own block of instructions. 759 760 set pushed 0 761 foreach expression [lrange $args 0 end-1] xgen [lrange $gens 1 end] { 762 Asm::Call $expression 763 if {!$pushed && $xgen} { 764 Asm::xinter01 765 set pushed 1 766 continue 767 } 768 if {$pushed} { 769 Asm::xinter11 770 } else { 771 Asm::xinter00 772 } 773 } 774 Asm::Call [lindex $args end] 775 Asm::xexit1 776 } 777 } 778 } {*}$args 779 Asm::Done 780} 781 782proc ::pt::peg::to::tclparam::Op::/ {modes args} { 783 if {[llength $args] == 1} { 784 return [lindex $args 0] 785 } 786 787 Asm::Start 788 Asm::ReExpression / {*}$args 789 set gens [Asm::GenAST {*}$args] 790 791 # Optimized AST handling: Handle each branch separately, based on 792 # its ability to generate AST nodes. 793 794 Asm::Function [Asm::NewBlock choice] { 795 set xgen [lindex $gens 0] 796 Asm::/init$xgen 797 798 # Note: This loop runs at code generation time. At runtime the 799 # entire construction is essentially a fully unrolled loop, 800 # with each iteration having its own block of instructions. 801 802 foreach expression [lrange $args 0 end-1] nxgen [lrange $gens 1 end] { 803 Asm::Call $expression 804 Asm::/inter$xgen$nxgen 805 set xgen $nxgen 806 } 807 808 Asm::Call [lindex $args end] 809 Asm::/exit$nxgen 810 811 } {*}$args 812 Asm::Done 813} 814 815# ### ### ### ######### ######### ######### 816## Assembler commands 817 818namespace eval ::pt::peg::to::tclparam::Op::Asm {} 819 820# ### ### ### ######### ######### ######### 821## The various part of a sequence compilation. 822 823proc ::pt::peg::to::tclparam::Op::Asm::xinit0 {} { 824 #Ins i_loc_push 825 #Ins i_error_clear_push 826 827 Ins si:void_state_push 828 return 829} 830 831proc ::pt::peg::to::tclparam::Op::Asm::xinit1 {} { 832 #Ins i_ast_push 833 #Ins i_loc_push 834 #Ins i_error_clear_push 835 836 Ins si:value_state_push 837 return 838} 839 840proc ::pt::peg::to::tclparam::Op::Asm::xinter00 {} { 841 #Ins i_error_pop_merge 842 # Stop the sequence on element failure, and 843 # restore state to before we tried the sequence. 844 #Ins i:fail_loc_pop_rewind 845 #Ins i:fail_return 846 #Ins i_error_push 847 848 Ins si:voidvoid_part 849 return 850} 851 852proc ::pt::peg::to::tclparam::Op::Asm::xinter01 {} { 853 #Ins i_error_pop_merge 854 # Stop the sequence on element failure, and 855 # restore state to before we tried the sequence. 856 #Ins i:fail_loc_pop_rewind 857 #Ins i:fail_return 858 #Ins i_ast_push 859 #Ins i_error_push 860 861 Ins si:voidvalue_part 862 return 863} 864 865proc ::pt::peg::to::tclparam::Op::Asm::xinter11 {} { 866 #Ins i_error_pop_merge 867 # Stop the sequence on element failure, and 868 # restore state to before we tried the sequence. 869 #Ins i:fail_ast_pop_rewind 870 #Ins i:fail_loc_pop_rewind 871 #Ins i:fail_return 872 #Ins i_error_push 873 874 Ins si:valuevalue_part 875 return 876} 877 878proc ::pt::peg::to::tclparam::Op::Asm::xexit0 {} { 879 #Ins i_error_pop_merge 880 #Ins i_loc_pop_rewind/discard 881 #Ins i:fail_return 882 883 Ins si:void_state_merge 884 return 885} 886 887proc ::pt::peg::to::tclparam::Op::Asm::xexit1 {} { 888 #Ins i_error_pop_merge 889 #Ins i_ast_pop_rewind/discard 890 #Ins i_loc_pop_rewind/discard 891 #Ins i:fail_return 892 893 Ins si:value_state_merge 894 return 895} 896 897# ### ### ### ######### ######### ######### 898## The various part of a choice compilation. 899 900proc ::pt::peg::to::tclparam::Op::Asm::/init0 {} { 901 #Ins i_loc_push 902 #Ins i_error_clear_push 903 904 Ins si:void_state_push 905 return 906} 907 908proc ::pt::peg::to::tclparam::Op::Asm::/init1 {} { 909 #Ins i_ast_push 910 #Ins i_loc_push 911 #Ins i_error_clear_push 912 913 Ins si:value_state_push 914 return 915} 916 917proc ::pt::peg::to::tclparam::Op::Asm::/inter00 {} { 918 #Ins i_error_pop_merge 919 # A branch was successful, squash the backtracking state 920 #Ins i:ok_loc_pop_discard 921 #Ins i:ok_return 922 #Ins i_loc_rewind 923 #Ins i_error_push 924 925 Ins si:voidvoid_branch 926 return 927} 928 929proc ::pt::peg::to::tclparam::Op::Asm::/inter01 {} { 930 #Ins i_error_pop_merge 931 # A branch was successful, squash the backtracking state 932 #Ins i:ok_loc_pop_discard 933 #Ins i:ok_return 934 #Ins i_ast_push 935 #Ins i_loc_rewind 936 #Ins i_error_push 937 938 Ins si:voidvalue_branch 939 return 940} 941 942proc ::pt::peg::to::tclparam::Op::Asm::/inter10 {} { 943 #Ins i_error_pop_merge 944 #Ins i_ast_pop_rewind/discard 945 # A branch was successful, squash the backtracking state 946 #Ins i:ok_loc_pop_discard 947 #Ins i:ok_return 948 #Ins i_loc_rewind 949 #Ins i_error_push 950 951 Ins si:valuevoid_branch 952 return 953} 954 955proc ::pt::peg::to::tclparam::Op::Asm::/inter11 {} { 956 #Ins i_error_pop_merge 957 # A branch was successful, squash the backtracking state 958 #Ins i:ok_ast_pop_discard 959 #Ins i:ok_loc_pop_discard 960 #Ins i:ok_return 961 #Ins i_ast_rewind 962 #Ins i_loc_rewind 963 #Ins i_error_push 964 965 Ins si:valuevalue_branch 966 return 967} 968 969proc ::pt::peg::to::tclparam::Op::Asm::/exit0 {} { 970 #Ins i_error_pop_merge 971 #Ins i_loc_pop_rewind/discard 972 973 Ins si:void_state_merge 974 975 # Note: on ok we return, on fail, we .. set to fail ... The last 976 # is unnecessary. Which then makes the conditional return also 977 # irrelevant. 978 979 # A branch was successful, squash the backtracking state 980 #Ins i:ok_return 981 982 # All branches FAILED 983 #text::write /line 984 #Ins i_status_fail 985 return 986} 987 988proc ::pt::peg::to::tclparam::Op::Asm::/exit1 {} { 989 #Ins i_error_pop_merge 990 #Ins i_ast_pop_rewind/discard 991 #Ins i_loc_pop_rewind/discard 992 993 Ins si:value_state_merge 994 995 # Note: on ok we return, on fail, we .. set to fail ... The last 996 # is unnecessary. Which then makes the conditional return also 997 # irrelevant. 998 999 # A branch was successful, squash the backtracking state 1000 #Ins i:ok_return 1001 1002 # All branches FAILED 1003 #text::write /line 1004 #Ins i_status_fail 1005 return 1006} 1007 1008# ### ### ### ######### ######### ######### 1009## Allocate a text block / internal symbol / function 1010 1011proc ::pt::peg::to::tclparam::Op::Asm::Start {} { 1012 upvar 1 result result 1013 set result {def {} use {} gen 0 pe {}} 1014 return 1015} 1016 1017proc ::pt::peg::to::tclparam::Op::Asm::Done {} { 1018 upvar 1 result result 1019 return -code return $result 1020 return 1021} 1022 1023proc ::pt::peg::to::tclparam::Op::Asm::ReExpression {op args} { 1024 upvar 1 result result 1025 1026 set pe $op 1027 foreach a $args { 1028 lappend pe [dict get $a pe] 1029 } 1030 1031 dict set result pe $pe 1032 PE $pe 1033 return 1034} 1035 1036proc ::pt::peg::to::tclparam::Op::Asm::ReTerminal {op args} { 1037 upvar 1 result result 1038 1039 set pe [linsert $args 0 $op] 1040 dict set result pe $pe 1041 PE $pe 1042 return 1043} 1044 1045proc ::pt::peg::to::tclparam::Op::Asm::GenAST {args} { 1046 upvar 1 result result 1047 1048 foreach a $args { 1049 lappend flags [dict get $a gen] 1050 } 1051 1052 dict set result gen [tcl::mathfunc::max {*}$flags] 1053 dict set result genmin [tcl::mathfunc::min {*}$flags] 1054 return $flags 1055} 1056 1057proc ::pt::peg::to::tclparam::Op::Asm::NewBlock {type} { 1058 variable counter 1059 variable lastid ${type}_[incr counter] 1060 return $lastid 1061} 1062 1063proc ::pt::peg::to::tclparam::Op::Asm::Function {name def args} { 1064 upvar 1 result result 1065 variable cache 1066 1067 set k [list [dict get $result gen] [dict get $result pe]] 1068 1069 # Hardcoded 'compact == 1', compare "pt_peg_to_param.tcl" 1070 if {[info exists cache($k)]} { 1071 dict set result def {} 1072 dict set result use $cache($k) 1073 return 1074 } 1075 1076 text::write clear 1077 if {[text::write exists FUN_HEADER]} { 1078 text::write recall FUN_HEADER 1079 text::write undef FUN_HEADER 1080 } 1081 1082 FunStart $name 1083 1084 text::write recall PE ; # Generated in Asm::ReExpression, printed 1085 text::write undef PE ; # representation of the expression, to 1086 # make the generated code more readable. 1087 uplevel 1 $def 1088 Tcl return 1089 1090 FunClose 1091 1092 if {[llength $args]} { 1093 Use {*}$args 1094 } 1095 1096 text::write store $name 1097 1098 set useb [NewBlock anon] 1099 text::write clear 1100 Self $name 1101 text::write store $useb 1102 1103 dict set result def $name 1104 dict set result use $useb 1105 1106 set cache($k) $useb 1107 return 1108} 1109 1110proc ::pt::peg::to::tclparam::Op::Asm::Direct {use} { 1111 upvar 1 result result 1112 1113 set useb [NewBlock anon] 1114 text::write clear 1115 uplevel 1 $use 1116 text::write store $useb 1117 1118 dict set result def {} 1119 dict set result use $useb 1120 return 1121} 1122 1123proc ::pt::peg::to::tclparam::Op::Asm::Call {expr {distance 1}} { 1124 #if {$distance} { text::write /line } 1125 1126 text::write recall [dict get $expr use] 1127 1128 #if {$distance} { text::write /line } 1129 return 1130} 1131 1132proc ::pt::peg::to::tclparam::Op::Asm::Use {args} { 1133 foreach item $args { 1134 set def [dict get $item def] 1135 if {$def eq {}} continue 1136 text::write recall $def 1137 text::write undef $def 1138 } 1139 return 1140} 1141 1142proc ::pt::peg::to::tclparam::Op::Asm::FunStart {name} { 1143 text::write /line 1144 text::write field @def@ @ns@$name \{\} \{ @prelude@ 1145 text::write /line 1146 return 1147} 1148 1149proc ::pt::peg::to::tclparam::Op::Asm::FunClose {} { 1150 text::write field \} 1151 text::write /line 1152 return 1153} 1154 1155proc ::pt::peg::to::tclparam::Op::Asm::Ins {args} { 1156 Tcl @runtime@ {*}$args 1157 return 1158} 1159 1160proc ::pt::peg::to::tclparam::Op::Asm::Self {args} { 1161 Tcl @self@ {*}$args 1162 return 1163} 1164 1165proc ::pt::peg::to::tclparam::Op::Asm::>>> {n} { 1166 variable field 1167 incr field $n 1168 return 1169} 1170 1171proc ::pt::peg::to::tclparam::Op::Asm::<<< {n} { 1172 variable field 1173 incr field -$n 1174 return 1175} 1176 1177proc ::pt::peg::to::tclparam::Op::Asm::Tcl {args} { 1178 variable field 1179 text::write fieldl $field {} 1180 text::write field {*}$args 1181 text::write /line 1182 return 1183} 1184 1185proc ::pt::peg::to::tclparam::Op::Asm::Header {text} { 1186 text::write field "#" 1187 text::write /line 1188 text::write field "# $text" 1189 text::write /line 1190 text::write field "#" 1191 text::write /line 1192 #text::write /line 1193 return 1194} 1195 1196proc ::pt::peg::to::tclparam::Op::Asm::PE {pe} { 1197 text::write clear 1198 text::write field [pt::pe print $pe] 1199 text::write /line 1200 text::write prefix " # " 1201 text::write /line 1202 text::write store PE 1203 return 1204} 1205 1206proc ::pt::peg::to::tclparam::Op::Asm::Setup {} { 1207 variable counter 0 1208 variable field 3 1209 variable cache 1210 array unset cache * 1211 return 1212} 1213 1214# ### ### ### ######### ######### ######### 1215## Configuration 1216 1217namespace eval ::pt::peg::to::tclparam { 1218 namespace eval ::pt::peg::to::tclparam::Op::Asm { 1219 variable counter 0 1220 variable fieldlen {17 5 5} 1221 variable field 3 1222 variable cache 1223 array set cache {} 1224 } 1225 1226 variable omap ; array set omap { 1227 runtime-command runtime 1228 self-command self 1229 proc-command def 1230 namespace ns 1231 main main 1232 file file 1233 name name 1234 template template 1235 user user 1236 indent indent 1237 prelude prelude 1238 } 1239 1240 variable self {} 1241 variable ns :: 1242 variable runtime {} 1243 variable def proc 1244 variable main __main 1245 variable indent 0 1246 variable prelude {} 1247 1248 variable template @code@ ; # A string. Specifies how to 1249 # embed the generated code into a 1250 # larger frame- work (the 1251 # template). 1252 variable name a_pe_grammar ; # String. Name of the grammar. 1253 variable file unknown ; # String. Name of the file or 1254 # other entity the grammar came 1255 # from. 1256 variable user unknown ; # String. Name of the user on 1257 # which behalf the conversion has 1258 # been invoked. 1259} 1260 1261# ### ### ### ######### ######### ######### 1262## Ready 1263 1264package provide pt::peg::to::tclparam 1 1265return 1266