1# -*- tcl -*-
2#
3# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
4# Parser Generator / Frontend - Read halfbaked PEG container.
5
6# ### ### ### ######### ######### #########
7## Requisites
8
9namespace eval ::page::parse::peghb {
10    variable fixup {}
11    variable definitions
12}
13
14# ### ### ### ######### ######### #########
15## API
16
17proc ::page::parse::peghb {halfbaked t} {
18    variable peghb::fixup
19    variable peghb::definitions
20    array set definitions {}
21
22    set fixup {}
23
24    interp create -safe sb
25    # Should remove everything.
26    interp alias  sb Start  {} ::page::parse::peghb::Start  $t
27    interp alias  sb Define {} ::page::parse::peghb::Define $t
28    interp eval   sb $halfbaked
29    interp delete sb
30
31    array set undefined {}
32    array set users     {}
33    foreach {n sym} $fixup {
34	if {[info exists definitions($sym)]} {
35	    set def $definitions($sym)
36	    $t set $n def $def
37	    lappend users($def) $n
38	} else {
39	    lappend undefined($sym) $n
40	}
41    }
42
43    foreach def [array names users] {
44	$t set $def users $users($def)
45    }
46
47    $t set root definitions [array get definitions]
48    $t set root undefined   [array get undefined]
49    $t set root symbol <StartExpression>
50    $t set root name   <HalfBaked>
51
52    return
53}
54
55# ### ### ### ######### ######### #########
56## Internal. Helpers
57
58proc ::page::parse::peghb::Start {t pe} {
59    variable fixup
60    $t set root start [treeOf $t root $pe fixup]
61    return
62}
63
64proc ::page::parse::peghb::Define {t mode sym pe} {
65    variable fixup
66    variable definitions
67
68    set def [$t insert root end]
69
70    $t set $def users  {}
71    $t set $def symbol $sym
72    $t set $def label  $sym
73    $t set $def mode   $mode
74
75    treeOf $t $def $pe fixup
76
77    set definitions($sym) $def
78    return
79}
80
81proc ::page::parse::peghb::treeOf {t root pe fv} {
82    upvar 1 $fv fixup
83
84    set n  [$t insert $root end]
85    set op [lindex $pe 0]
86    $t set $n op $op
87
88    if {$op eq "t"} {
89	$t set $n char [lindex $pe 1]
90
91    } elseif {$op eq ".."} {
92	$t set $n begin [lindex $pe 1]
93	$t set $n end   [lindex $pe 2]
94
95    } elseif {$op eq "n"} {
96
97	set sym [lindex $pe 1]
98	$t set $n sym $sym
99	$t set $n def ""
100
101	lappend fixup $n $sym
102    } else {
103	foreach sub [lrange $pe 1 end] {
104	    treeOf $t $n $sub fixup
105	}
106    }
107    return $n
108}
109
110# ### ### ### ######### ######### #########
111## Internal. Strings.
112
113namespace eval ::page::parse::peghb {}
114
115# ### ### ### ######### ######### #########
116## Ready
117
118package provide page::parse::peghb 0.1
119