Tcl Library Source Code

Changes On Branch pt-container-ssoberni
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki
Hide Diff Patch Unified Diff

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch pt-container-ssoberni Excluding Merge-Ins

This is equivalent to a diff from 623801c583 to d907079d5b

2018-07-09
21:17
Tkt [351b8b2f55]. Work branch integrated. check-in: 3720e40747 user: andreask tags: trunk
21:08
More tests: syntax, drop unreachable. More comments. Noted untested ops. pt::peg::op <B> - Version bump to 1.0.2 Closed-Leaf check-in: d907079d5b user: andreask tags: pt-container-ssoberni
19:49
Some fixes to the new pe transform testing. check-in: 8436048fee user: andreask tags: pt-container-ssoberni
17:14
docstrip - Moved manpage changes from generated file into the actual package sources. No version change check-in: 180c2ac3c8 user: andreask tags: trunk
2018-06-27
17:16
Update peg container transform work to latest trunk, including peg ffp fixes. check-in: 63282d761b user: aku tags: pt-container-ssoberni
17:07
Merged FFP work by Stefan Sobernig. check-in: 623801c583 user: aku tags: trunk
2018-06-25
23:00
Fixes for the FFP tests - Change test grammar to enforce consummation of all input - Fix error in ok grammar example copied from the fail example. - Fix mis-count in the FFP result for the fail example, and missing closing brace Closed-Leaf check-in: d58dafb114 user: aku tags: ssoberni-ffp-3ed39a451f
2018-06-20
05:46
doctools doctoc - html formatting - anchors based on section titles and file labels. bump to 1.1.7 docidx - html formatting - anchors based on keywords, ignore non-alphanumeric characters. bump to 1.0.8 dtplite - See doc_auto below. Bump to 1.3.1. Further, factored generator blocks into separate procedures. sak / doc_auto - Ignore leading non-alphanumeric characters for sorting. dicttool <D> Typo fix - dicttool.man Regenerated embedded and other documentation. check-in: fe060af06b user: aku tags: trunk

Changes to modules/pt/pkgIndex.tcl.

︙︙
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

package ifneeded pt::pe        1.0.2 [list source [file join $dir pt_pexpression.tcl]]
package ifneeded pt::pe::op    1.0.1 [list source [file join $dir pt_pexpr_op.tcl]]

# Parsing Expression Grammar support.
package ifneeded pt::peg                1 [list source [file join $dir pt_pegrammar.tcl]]
package ifneeded pt::peg::container     1 [list source [file join $dir pt_peg_container.tcl]]
package ifneeded pt::peg::interp    1.0.1 [list source [file join $dir pt_peg_interp.tcl]]
package ifneeded pt::peg::op        1.0.1 [list source [file join $dir pt_peg_op.tcl]]
package ifneeded pt::parse::peg     1.0.1 [list source [file join $dir pt_parse_peg.tcl]]


# Export/import managers. Assumes an untrusted environment.
package ifneeded pt::peg::export            1 [list source [file join $dir pt_peg_export.tcl]]
package ifneeded pt::peg::import            1 [list source [file join $dir pt_peg_import.tcl]]









|








17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

package ifneeded pt::pe        1.0.2 [list source [file join $dir pt_pexpression.tcl]]
package ifneeded pt::pe::op    1.0.1 [list source [file join $dir pt_pexpr_op.tcl]]

# Parsing Expression Grammar support.
package ifneeded pt::peg                1 [list source [file join $dir pt_pegrammar.tcl]]
package ifneeded pt::peg::container     1 [list source [file join $dir pt_peg_container.tcl]]
package ifneeded pt::peg::interp    1.0.1 [list source [file join $dir pt_peg_interp.tcl]]
package ifneeded pt::peg::op        1.0.2 [list source [file join $dir pt_peg_op.tcl]]
package ifneeded pt::parse::peg     1.0.1 [list source [file join $dir pt_parse_peg.tcl]]


# Export/import managers. Assumes an untrusted environment.
package ifneeded pt::peg::export            1 [list source [file join $dir pt_peg_export.tcl]]
package ifneeded pt::peg::import            1 [list source [file join $dir pt_peg_import.tcl]]
︙︙

Changes to modules/pt/pt_peg_op.man. 

1

2
3
4
5
6
7
8
9
10
11
12

[comment {-*- text -*- doctools manpage}]

[manpage_begin pt_peg_op i 1.0.1]
[include include/module.inc]
[titledesc {Parser Tools PE Grammar Utility Operations}]
[require pt::peg::op 1.0.1]
[description]
[include include/ref_intro.inc]

This package provides a number of utility commands manipulating a PE
grammar (container) in various ways.

[section API]


>
|


|








1
2
3
4
5
6
7
8
9
10
11
12
13

[comment {-*- text -*- doctools manpage}]
[vset VERSION 1.0.2]
[manpage_begin pt_peg_op i [vset VERSION]]
[include include/module.inc]
[titledesc {Parser Tools PE Grammar Utility Operations}]
[require pt::peg::op [opt [vset VERSION]]]
[description]
[include include/ref_intro.inc]

This package provides a number of utility commands manipulating a PE
grammar (container) in various ways.

[section API]
︙︙

Changes to modules/pt/pt_peg_op.tcl.

︙︙
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

    set mode() value

    # calls  = array (x -> called-by-x)
    # caller = array (x -> users-of-x)

    set changed [$container nonterminals]
    while {[llength $changed]} {
puts <$changed>
	set scan $changed
	set changed {}

	foreach sym $scan {
	    # Rule 1
	    if {![llength $calls($sym)] &&
		($mode($sym) eq "value")} {
puts (1)$sym
		set mode($sym) leaf
	    }

	    # Rule 2
	    set callmode [CallMode $caller($sym) mode]
	    if {($callmode eq "void") &&
		($mode($sym) ne "void")} {








|







|








135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

    set mode() value

    # calls  = array (x -> called-by-x)
    # caller = array (x -> users-of-x)

    set changed [$container nonterminals]
    while {[llength $changed]} {
	#puts <$changed>
	set scan $changed
	set changed {}

	foreach sym $scan {
	    # Rule 1
	    if {![llength $calls($sym)] &&
		($mode($sym) eq "value")} {
		#puts (1)$sym
		set mode($sym) leaf
	    }

	    # Rule 2
	    set callmode [CallMode $caller($sym) mode]
	    if {($callmode eq "void") &&
		($mode($sym) ne "void")} {
︙︙
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203

    }
}

# # ## ### ##### ######## #############

proc ::pt::peg::op::minimize {container} {
    flatten           $container
    drop unreachable  $container
    drop unrealizable $container

    flatten           $container
    optmodes          $container
    dechain           $container
    return
}

# # ## ### ##### ######## #############

proc ::pt::peg::op::reachable {container} {








<

>

|








186
187
188
189
190
191
192

193
194
195
196
197
198
199
200
201
202
203

    }
}

# # ## ### ##### ######## #############

proc ::pt::peg::op::minimize {container} {
    flatten           $container

    drop unrealizable $container
    drop unreachable  $container
    flatten           $container
    modeopt           $container
    dechain           $container
    return
}

# # ## ### ##### ######## #############

proc ::pt::peg::op::reachable {container} {
︙︙
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322

	    # Choice is realizable if we have at least one realizable
	    # branch. This is also the place where we have to remove
	    # unrealizable children when we drop unrealizable symbols
	    # from a grammar.

	    return [tcl::mathfunc::max {*}$arguments]
	}
	x - * - + - ? - & - ! {
	    # All other operators are realizable if and only if all
	    # its children are realizable.

	    return [tcl::mathfunc::min {*}$arguments]
	}
	default {
	    # The terminals and special forms are realizable by
	    # definition.
	    return 1
	}
    }
}

proc ::pt::peg::op::drop::unrealizable {container} {









|






|
|








300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322

	    # Choice is realizable if we have at least one realizable
	    # branch. This is also the place where we have to remove
	    # unrealizable children when we drop unrealizable symbols
	    # from a grammar.

	    return [tcl::mathfunc::max {*}$arguments]
	}
	x - + - & - ! {
	    # All other operators are realizable if and only if all
	    # its children are realizable.

	    return [tcl::mathfunc::min {*}$arguments]
	}
	default {
	    # Terminals, special forms, Kleene closure (*), and
	    # optionals (?) are realizable by definition.
	    return 1
	}
    }
}

proc ::pt::peg::op::drop::unrealizable {container} {
︙︙
369
370
371
372
373
374
375
376
377

## State / Configuration :: n/a

namespace eval ::pt::peg::op {}

# # ## ### ##### ######## ############# #####################
## Ready

package provide pt::peg::op 1.0.1
return








|


369
370
371
372
373
374
375
376
377

## State / Configuration :: n/a

namespace eval ::pt::peg::op {}

# # ## ### ##### ######## ############# #####################
## Ready

package provide pt::peg::op 1.0.2
return

Added modules/pt/pt_peg_op.test. 





































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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

# -*- tcl -*-
# pe_peg_op.test:  tests for the pt::peg::op package.
#
# Copyright (c) 2018 by Stefan Sobernig <[email protected]>
# All rights reserved.
#

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5
testsNeedTcltest 2.0

support {
    useAccel [useTcllibC] struct/sets.tcl struct::set
    TestAccelInit                         struct::set

    use fileutil/fileutil.tcl  fileutil ; # For tests/common
    use snit/snit.tcl          snit

    use pt/pt_pegrammar.tcl     pt::peg
    use pt/pt_peg_container.tcl pt::peg::container
    use pt/pt_pexpr_op.tcl      pt::pe::op

    source [localPath tests/common]
}
testing {
    useLocal pt_peg_op.tcl pt::peg::op
}

# -------------------------------------------------------------------------

set mytestdir tests/data

# -------------------------------------------------------------------------

TestAccelDo struct::set setimpl {
    source [localPath tests/pt_peg_op.tests]
}

#----------------------------------------------------------------------

unset mytestdir
TestAccelExit struct::set
testsuiteCleanup
return

Changes to modules/pt/pt_pexpr_op.tcl.

︙︙
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

# # ## ### ##### ######## #############
## Internals

proc ::pt::pe::op::Drop {dropset pe op arguments} {
    if {$op eq "n"} {
	lassign $arguments symbol
	if {[struct::set contains $dropset $symbol]} {
	    return @@
	} else {
	    return $pe
	}
    }

    switch -exact -- $op {
	/ - x - * - + - ? - & - ! {
	    set newarg {}
	    foreach a $arguments {
		if {$a eq "@@"} continue
		lappend newarg $a
	    }

	    if {![llength $newarg]} {
		# Nothing remained, drop the whole expression
		return [pt::pe epsilon]
	    } elseif {[llength $newarg] < [llength $argument]} {
		# Some removed, construct a new expression

		set pe [list $op {*}$newarg]
	    } ; # None removed, no change.
	}

    }


    return $pe
}

proc ::pt::pe::op::Rename {nt ntnew pe op arguments} {
    #puts R($op)/$arguments/
    if {($op eq "n") && ([lindex $arguments 0] eq $nt)} {
	return [pt::pe nonterminal $ntnew]








<
|
<

<
|
<
<
|
|
|
|
|
<
|
|
|
|
|
>

<
|
>
|
>
|








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

# # ## ### ##### ######## #############
## Internals

proc ::pt::pe::op::Drop {dropset pe op arguments} {
    if {$op eq "n"} {
	lassign $arguments symbol
	if {[struct::set contains $dropset $symbol]} {

	    set pe @@

	}

    } elseif {$op in {/ x * + ? & !}} {


	set newarg {}
	foreach a $arguments {
	    if {$a eq "@@"} continue
	    lappend newarg $a
	}

	if {![llength $newarg]} {
	    # Nothing remained, drop the whole expression
	    set pe [pt::pe epsilon]
	} elseif {[llength $newarg] < [llength $arguments]} {
	    # Some removed, construct a new expression
	    if {$op eq "/"} {
		set pe [list $op {*}$newarg]

	    } else {
		set pe @@
	    }
	} ; # None removed, no change.
    }
    return $pe
}

proc ::pt::pe::op::Rename {nt ntnew pe op arguments} {
    #puts R($op)/$arguments/
    if {($op eq "n") && ([lindex $arguments 0] eq $nt)} {
	return [pt::pe nonterminal $ntnew]
︙︙

Added modules/pt/tests/pt_peg_op.tests. 











































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

# -*- tcl -*-
# Testsuite for pt::peg::op.

# [ok] drop unreachable
# [ok] drop unrealizable
# [ok] flatten
# [ok] minimize

# TODO
# [..] called
# [..] dechain
# [..] modeopt
# [..] reachable
# [..] realizable

# -------------------------------------------------------------------------
# Basic syntax

foreach op {
    called
    dechain
    flatten
    minimize
    modeopt
    reachable
    realizable
    {drop unreachable}
    {drop unrealizable}
} {
    test pt-peg-op-set:${setimpl}-${op}-0.0 "$op, wrong#args, not enough" -body {
	pt::peg::op {*}$op
    } -returnCodes error -result "wrong # args: should be \"pt::peg::op $op container\""

    test pt-peg-op-set:${setimpl}-${op}-0.1 "$op, wrong#args, too many" -body {
	pt::peg::op {*}$op Container X
    } -returnCodes error -result "wrong # args: should be \"pt::peg::op $op container\""
}

# -------------------------------------------------------------------------
# General support for testing transforms

proc sl {v} {
    # Remove comment lines
    regsub -all -line {^\s*#.*$} $v {}
}

proc g {s r} {
    # quick constructor of a grammar value
    return [list pt::grammar::peg [list rules $r start $s]]
}

proc TestTransformation {op data setImpl} {
    # Convert operation and data table into series of test cases
    set debug 0
    # Note, the `op` changes the container (here ::In) in-place.
    append bodyScript [list {*}::pt::peg::op::$op ::In] \;
    if {$debug} {
	append bodyScript "puts stderr \[::In       serialize\]" \;
	append bodyScript "puts stderr \[::Expected serialize\]" \;
    }
    # After the op, when all is well, the content of ::In should be
    # the same as ::Expected.
    append bodyScript "pt::peg equal \[::In serialize\] \[::Expected serialize\]" \;
    set n 1
    foreach {inStart inRulesSet outStart outRulesSet} [sl $data] {
	set testLabel "pt-peg-op-set:${setImpl}-[join $op -]-$n"
	if {$debug} {
	    puts stderr >>>>$testLabel<<<<
	}
	test $testLabel "OP '$op' vs. expected" -setup {
	    pt::peg::container ::In       deserialize [g $inStart  $inRulesSet]
	    pt::peg::container ::Expected deserialize [g $outStart $outRulesSet]
	} -body $bodyScript -result 1 -cleanup {
	    ::In       destroy
	    ::Expected destroy
	}
	incr n
    }
}

# -------------------------------------------------------------------------
# op: flatten

TestTransformation flatten {
    # --- stays as-is #1
    epsilon {}
    epsilon {}
    # --- stays as-is #2
    {n S} {
	S {is {n A} mode value}
	A {is {t a} mode value}
    }
    {n S} {
	S {is {n A} mode value}
	A {is {t a} mode value}
    }
    # --- flatten start expr and rules: single-element sequences
    {x {n S}} {
	S {is {x {n A}} mode value}
	A {is {n A} mode value}
    }
    {n S} {
	S {is {n A} mode value}
	A {is {n A} mode value}
    }
    # --- flatten start expr and rules: single-element choices
    {/ {n S}} {
	S {is {/ {n A}} mode value}
	A {is {n A} mode value}
    }
    {n S} {
	S {is {n A} mode value}
	A {is {n A} mode value}
    }
    # --- flatten start expr and rules: nested sequences
    {x {n S}} {
	S {is {x {n A} {x {n A} {n A}}} mode value}
	A {is {n A} mode value}
    }
    {n S} {
	S {is {x {n A} {n A} {n A}} mode value}
	A {is {n A} mode value}
    }
    # --- flatten start expr and rules: nested choices
    {x {n S}} {
	S {is {/ {n A} {/ {n A} {n A}}} mode value}
	A {is {n A} mode value}
    }
    {n S} {
	S {is {/ {n A} {n A} {n A}} mode value}
	A {is {n A} mode value}
    }
} $setimpl

# -------------------------------------------------------------------------
# op: drop unrealizable

TestTransformation "drop unrealizable" {
    # (1) stays as-is
    epsilon {}
    epsilon {}
    # (2) S <-- X; X <-- X; => epsilon
    {n S} {
	S {is {n X} mode value}
	X {is {n X} mode value}
    }
    epsilon {}
    # (3) S <-- X?; X <-- X; => S <-- epsilon
    {n S} {
	S {is {? {n X}} mode value}
	X {is {n X} mode value}
    }
    {n S} {
	S {is epsilon mode value}
    }
    # (4) S <-- X*; X <-- X; => S <-- epsilon
    {n S} {
	S {is {* {n X}} mode value}
	X {is {n X} mode value}
    }
    {n S} {
	S {is epsilon mode value}
    }
    # (5) S <-- X 'y'; X <-- X; => epsilon
    {n S} {
	S {is {x {n X} {t y}} mode value}
	X {is {n X} mode value}
    }
    epsilon {}
    # (6) S <-- X / 'y'; X <-- X; => S <-- 'y' (unflattened!)
    {n S} {
	S {is {/ {n X} {t y}} mode value}
	X {is {n X} mode value}
    }
    {n S} {
	S {is {/ {t y}} mode value}
    }
} $setimpl

# -------------------------------------------------------------------------
# op: drop unrealizable

TestTransformation "drop unreachable" {
    # (1) stays as-is
    epsilon {}
    epsilon {}
    # S <-- a; A <-- a ==> S <-- a (A not reachable, dropped)
    {n S} {
     	S {is {t a} mode leaf}
     	A {is {t a} mode void}
    }
    {n S} {
     	S {is {t a} mode leaf}
    }
    # S <-- a; A <-- B; B <-- a ==> A, B unreachable, dropped
    {n S} {
     	S {is {t a} mode leaf}
     	A {is {n B} mode void}
     	B {is {t a} mode void}
    }
    {n S} {
     	S {is {t a} mode leaf}
    }
} $setimpl

# -------------------------------------------------------------------------
# op: minimize

TestTransformation minimize {
    # --- stays as-is
    epsilon {}
    epsilon {}
    # --- minimize away (unrealizable)
    # S <-- A; A <-- A
    {n S} {
	S {is {n A} mode value}
	A {is {n A} mode value}
    }
    epsilon {}
    # --- already minimal
    {n S} {
     	S {is {n A} mode leaf}
     	A {is {t a} mode void}
    }
    {n S} {
	S {is {n A} mode leaf}
     	A {is {t a} mode void}
    }
    # --- drop unrealizable *before* unreachable
    # S <-- AB / a; A <-- aA; B <-- a
    {n S} {
     	S {is {/ {x {n A} {n B}} {t a}} mode value}
     	A {is {x {t a} {n A}} mode value}
	B {is {t a} mode leaf}
    }
    {n S} {
	S {is {t a} mode leaf}
    }
} $setimpl

# -------------------------------------------------------------------------
rename sl {}
rename g {}
rename TestTransformation {}

This page was generated in about 0.065s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19