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