blob: b3814a7c388957618aca4801e1dbd6eb4d7aa761 (
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
|
# -*- tcl -*-
#
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# Parser Generator / Frontend - Read serialized PEG container.
# ### ### ### ######### ######### #########
## Requisites
package require grammar::peg
namespace eval ::page::parse::pegser {}
# ### ### ### ######### ######### #########
## API
proc ::page::parse::pegser {serial t} {
::grammar::peg gr deserialize $serial
$t set root start [pegser::treeOf $t root [gr start] fixup]
array set definitions {}
foreach sym [gr nonterminals] {
set def [$t insert root end]
$t set $def users {}
$t set $def symbol $sym
$t set $def label $sym
$t set $def mode [gr nonterminal mode $sym]
pegser::treeOf $t $def [gr nonterminal rule $sym] fixup
set definitions($sym) $def
}
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 <Serialization>
return
}
# ### ### ### ######### ######### #########
## Internal. Helpers
proc ::page::parse::pegser::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::pegser {}
# ### ### ### ######### ######### #########
## Ready
package provide page::parse::pegser 0.1
|
