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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
# -*- tcl -*-
# ### ### ### ######### ######### #########
## This package provides a number of utility commands to
## transformations for common operations. It assumes a 'Normalized PE
## Grammar Tree' as input, possibly augmented with attributes coming
## from transformation not in conflict with the base definition.
# ### ### ### ######### ######### #########
## Requisites
package require page::util::quote
namespace eval ::page::util::peg {
namespace export \
symbolOf symbolNodeOf \
updateUndefinedDueRemoval \
flatten peOf printTclExpr \
getWarnings printWarnings
# Get the peg char de/encoder commands.
# (unquote, quote'tcl).
namespace import ::page::util::quote::*
}
# ### ### ### ######### ######### #########
## API
proc ::page::util::peg::symbolNodeOf {t n} {
# Given an arbitrary root it determines the node (itself or an
# ancestor) containing the name of the nonterminal symbol the node
# belongs to, and returns its id. The result is either the root of
# the tree (for the start expression), or a definition mode.
while {![$t keyexists $n symbol]} {
set n [$t parent $n]
}
return $n
}
proc ::page::util::peg::symbolOf {t n} {
# As above, but returns the symbol name.
return [$t get [symbolNodeOf $t $n] symbol]
}
proc ::page::util::peg::updateUndefinedDueRemoval {t} {
# The removal of nodes may have caused symbols to lose one or more
# users. Example: A used by B and C, B is reachable, C is not, so A
# now loses a node in the expression for C calling it, or rather
# not anymore.
foreach {sym def} [$t get root definitions] {
set res {}
foreach u [$t get $def users] {
if {![$t exists $u]} continue
lappend res $u
}
$t set $def users $res
}
# Update the knowledge of undefined nonterminals. To be used when
# a transformation can remove invokations of undefined symbols,
# and is not able to generate such invokations.
set res {}
foreach {sym invokers} [$t get root undefined] {
set sres {}
foreach n $invokers {
if {![$t exists $n]} continue
lappend sres $n
}
if {[llength $sres]} {
lappend res $sym $sres
}
}
$t set root undefined $res
return
}
proc ::page::util::peg::flatten {q t} {
# Flatten nested x-, or /-operators.
# See peg_normalize.tcl, peg::normalize::ExprFlatten
foreach op {x /} {
# Locate all x operators, whose parents are x oerators as
# well, then go back to the child operators and cut them out.
$q query \
tree withatt op $op \
parent unique withatt op $op \
children withatt op $op \
over n {
$t cut $n
}
}
return
}
proc ::page::util::peg::getWarnings {t} {
# Look at the attributes for problems with the grammar and issue
# warnings. They do not prevent us from writing the grammar, but
# still represent problems with it the user should be made aware
# of.
array set msg {}
array set undefined [$t get root undefined]
foreach sym [array names undefined] {
set msg($sym) {}
foreach ref $undefined($sym) {
lappend msg($sym) "Undefined symbol used by the definition of '[symbolOf $t $ref]'."
}
}
foreach {sym def} [$t get root definitions] {
if {[llength [$t get $def users]] == 0} {
set msg($sym) [list "This symbol has been defined, but is not used."]
}
}
return [array get msg]
}
proc ::page::util::peg::printWarnings {msg} {
if {![llength $msg]} return
set dict {}
set max -1
foreach {k v} $msg {
set l [string length [list $k]]
if {$l > $max} {set max $l}
lappend dict [list $k $v $l]
}
foreach e [lsort -dict -index 0 $dict] {
foreach {k msgs l} $e break
set off [string repeat " " [expr {$max - $l}]]
page_info "[list $k]$off : [lindex $msgs 0]"
if {[llength $msgs] > 1} {
set indent [string repeat " " [string length [list $k]]]
foreach m [lrange $msgs 1 end] {
puts stderr " $indent$off : $m"
}
}
}
return
}
proc ::page::util::peg::peOf {t eroot} {
set op [$t get $eroot op]
set pe [list $op]
set ch [$t children $eroot]
if {[llength $ch]} {
foreach c $ch {
lappend pe [peOf $t $c]
}
} elseif {$op eq "n"} {
lappend pe [$t get $eroot sym]
} elseif {$op eq "t"} {
lappend pe [unquote [$t get $eroot char]]
} elseif {$op eq ".."} {
lappend pe \
[unquote [$t get $eroot begin]] \
[unquote [$t get $eroot end]]
}
return $pe
}
proc ::page::util::peg::printTclExpr {pe} {
list [PrintExprSub $pe]
}
# ### ### ### ######### ######### #########
## Internal
proc ::page::util::peg::PrintExprSub {pe} {
set op [lindex $pe 0]
set args [lrange $pe 1 end]
#puts stderr "PE [llength $args] $op | $args"
if {$op eq "t"} {
set a [lindex $args 0]
return "$op [quote'tcl $a]"
} elseif {$op eq ".."} {
set a [lindex $args 0]
set b [lindex $args 1]
return "$op [quote'tcl $a] [quote'tcl $b]"
} elseif {$op eq "n"} {
return $pe
} else {
set res $op
foreach a $args {
lappend res [PrintExprSub $a]
}
return $res
}
}
# ### ### ### ######### ######### #########
## Ready
package provide page::util::peg 0.1
|
