Tcl Library Source Code

Check-in [d907079d5b]
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki

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

Overview
Comment:More tests: syntax, drop unreachable. More comments. Noted untested ops. pt::peg::op <B> - Version bump to 1.0.2
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | pt-container-ssoberni
Files: files | file ages | folders
SHA3-256: d907079d5babfcea8569c47311e631d5a3abeec5aecdbae11400b42981169761
User & Date: andreask 2018-07-09 21:08:38.209
References
2018-07-09
21:17 • Ticket [351b8b2f55] Bug fixes on PT/PEG transformation operations status still Open with 3 other changes artifact: 849ae8d19c user: aku
Context
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
Changes
Unified Diff Ignore Whitespace Patch
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.
︙︙
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
Changes to 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

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

test pt-peg-op-set:${setimpl}-0.0 {op 'flatten', wrong#args} -body {

    pt::peg::op flatten

} -returnCodes error -result {wrong # args: should be "pt::peg::op flatten container"}









test pt-peg-op-set:${setimpl}-0.1 {op 'drop unrealizable', wrong#args} -body {









    pt::peg::op drop unrealizable


} -returnCodes error -result {wrong # args: should be "pt::peg::op drop unrealizable container"}


test pt-peg-op-set:${setimpl}-0.2 {op 'minimize', wrong#args} -body {
    pt::peg::op minimize 
} -returnCodes error -result {wrong # args: should be "pt::peg::op minimize container"}





proc sl {v} {

    regsub -all -line {^\s*#.*$} $v {}
}






proc TestTransformation {op data setImpl} {

    set debug 0

    append bodyScript [list {*}::pt::peg::op::$op ::In] \;
    if {$debug} {
	append bodyScript "puts stderr \[::In serialize\]" \;
	append bodyScript "puts stderr \[::Expected serialize\]" \;
    }


    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 \
		[list pt::grammar::peg [list rules $inRulesSet start $inStart]]
	    pt::peg::container ::Expected deserialize \
		[list pt::grammar::peg [list rules $outRulesSet start $outStart]]
	} -body $bodyScript -result 1 -cleanup {
	    ::In destroy
	    ::Expected destroy
	}
	incr n
    }
}

# -------------------------------------------------------------------------
# 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: sequence
    {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}
    }



























} $setimpl

# -------------------------------------------------------------------------
# drop realizable

TestTransformation "drop unrealizable" {
    # (1) stays as-is
    epsilon {}
    epsilon {}
    # (2) S <-- X; X <-- X; => epsilon
    {n S} {




|
>
|
>
|
>
>
>
>
>
>

>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
|
|

|
|
|
|

>
>
>

>



>
>
>
>
>

>

>


|


>
>



|




|
<
|
<

|







|














|








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



|








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

# -*- 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} {
︙︙
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






	X {is {n X} mode value}
    }
    {n S} {
	S {is {/ {t y}} mode value}
    }
} $setimpl



























# -------------------------------------------------------------------------
# minimize

TestTransformation minimize {
    # --- stays as-is
    epsilon {}
    epsilon {}
    # --- minimize away

    {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}
    }
    # --- realizable *before* reachable

    {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













>
>

>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|





|
>






|
<







|
>
|
<








>
>
>
>
>

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

	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.016s by Fossil 2.27 [a6d506ecc4] 2025-07-09 13:52:53