Tcl Library Source Code

Check-in [3720e40747]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

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

Overview
Comment:Tkt [351b8b2f55]. Work branch integrated.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256:3720e407471cdfcd149ef97b32046faa48804d87ddcc6b58c429d3f34f5beb7e
User & Date: andreask 2018-07-09 21:17:38
References
2018-07-09
21:29 Closed ticket [351b8b2f55]: Bug fixes on PT/PEG transformation operations plus 6 other changes artifact: 73e3142bf8 user: aku
Context
2018-07-09
21:27
pt::peg::op `drop unrealizable` more conservative, ignore unreachable symbols as realizable. Tests pass. check-in: 4bbe140a79 user: andreask tags: trunk
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:17
math::numtheory - <B,T> Bugfix in `primeFactors`. Handle case of the search loop for factors running over the end of the list of known primes. Added test cases. Version bumped to 1.1.1 check-in: f1ef76f20c user: andreask tags: trunk
Changes
Hide Diffs Unified Diffs 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.

135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
...
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
369
370
371
372
373
374
375
376
377
    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")} {
................................................................................
    }
}

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

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} {
................................................................................
	    # 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} {

................................................................................
## State / Configuration :: n/a

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

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

package provide pt::peg::op 1.0.1
return







|







|







 







<

>

|







 







|






|
|







 







|

135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
...
186
187
188
189
190
191
192

193
194
195
196
197
198
199
200
201
202
203
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
369
370
371
372
373
374
375
376
377
    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")} {
................................................................................
    }
}

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

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} {
................................................................................
	    # 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} {

................................................................................
## 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 <stefan.sobernig@wu.ac.at>
# 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 {}