source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/page/gen_peg_me.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 22.1 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.