Tcl Library Source Code

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

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

Overview
Comment:char - Modified internals to accept strings and varargs strings as arguments, not just single char. Drops the need for externa split/join combos to handle strings. Extended the testsuite to match. Further refactored the argument handling into a single helper command.
Timelines: family | ancestors | descendants | both | pt-work
Files: files | file ages | folders
SHA1: 570945bf847af8b22432f804aac157a7709fa22f
User & Date: aku 2014-06-28 05:04:33
Context
2014-06-28
05:05
Modified support command "make-parser" to be able to save generated code into a file for post-run inspection. check-in: e6cc443afb user: aku tags: pt-work
05:04
char - Modified internals to accept strings and varargs strings as arguments, not just single char. Drops the need for externa split/join combos to handle strings. Extended the testsuite to match. Further refactored the argument handling into a single helper command. check-in: 570945bf84 user: aku tags: pt-work
2014-06-27
06:04
pt::pgen test cases for error handling updated and tweaked. Pass for all Tcl backends. Fail for the generated C backend. To be fixed. check-in: cbd7732a08 user: aku tags: pt-work
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/pt/char.tcl.

︙︙
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73


    return $ch
}

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

proc ::char::quote::tcl {ch args} {
    if {![llength $args]} { return [Tcl $ch] }
    lappend res [Tcl $ch]
    foreach ch $args { lappend res [Tcl $ch] }
    return $res
}

proc ::char::quote::Tcl {ch} {
    # Input:  A single character
    # Output: A string representing the input.
    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).








<
|
<
<








56
57
58
59
60
61
62

63


64
65
66
67
68
69
70


    return $ch
}

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

proc ::char::quote::tcl {ch args} {

    Arg Tcl $ch {*}$args


}

proc ::char::quote::Tcl {ch} {
    # Input:  A single character
    # Output: A string representing the input.
    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).
︙︙
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124

    # Regular character: Is its own representation.
    return $ch
}

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

proc ::char::quote::string {ch args} {
    if {![llength $args]} { return [String $ch] }
    lappend res [String $ch]
    foreach ch $args { lappend res [String $ch] }
    return $res
}

proc ::char::quote::String {ch} {
    # Input:  A single character
    # Output: A string representing the input
    # Properties of the output
    # (1) Human-readable, for use in error messages, or comments.








<
|
<
<








104
105
106
107
108
109
110

111


112
113
114
115
116
117
118

    # Regular character: Is its own representation.
    return $ch
}

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

proc ::char::quote::string {ch args} {

    Arg String $ch {*}$args


}

proc ::char::quote::String {ch} {
    # Input:  A single character
    # Output: A string representing the input
    # Properties of the output
    # (1) Human-readable, for use in error messages, or comments.
︙︙
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

	7 <BEL> 15 <SI>   23 <ETB> 31 <US>
    }
}

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

proc ::char::quote::cstring {ch args} {
    if {![llength $args]} { return [CString $ch] }
    lappend res [CString $ch]
    foreach ch $args { lappend res [CString $ch] }
    return $res
}

proc ::char::quote::CString {ch} {
    # Input:  A single character
    # Output: A string representing the input.
    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).
    # (2) When embedded in a ""-quoted C string in a piece of
    #     C code the C parser will regenerate the input character
    #     in UTF-8 encoding.

    # Special characters (named).
    switch -exact -- $ch {
	"\n" {return "\\n"}
	"\r" {return "\\r"}
	"\t" {return "\\t"}
	"\"" - "\\" {
	    return \\$ch
	}










    }

    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\[format %o $chcode]








<
|
<
<



















>
>
>
>
>
>
>
>
>
>








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

	7 <BEL> 15 <SI>   23 <ETB> 31 <US>
    }
}

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

proc ::char::quote::cstring {ch args} {

    Arg CString $ch {*}$args


}

proc ::char::quote::CString {ch} {
    # Input:  A single character
    # Output: A string representing the input.
    # Properties of the output:
    # (1) Contains only ASCII characters (7bit Unicode subset).
    # (2) When embedded in a ""-quoted C string in a piece of
    #     C code the C parser will regenerate the input character
    #     in UTF-8 encoding.

    # Special characters (named).
    switch -exact -- $ch {
	"\n" {return "\\n"}
	"\r" {return "\\r"}
	"\t" {return "\\t"}
	"\"" - "\\" {
	    return \\$ch
	}
	"\{" - "\}" {
	    # The generated C code containing the result of this
	    # transform may be embedded in Tcl code (Brace-quoted),
	    # i.e. like for a critcl-based package. To avoid tripping
	    # the Tcl parser with unbalanced braces we sacrifice
	    # readability of the generated code a bit and insert
	    # braces in their octal form.
	    scan $ch %c chcode
	    return \\[format %o $chcode]
	}
    }

    scan $ch %c chcode

    # Control characters: Octal
    if {[::string is control -strict $ch]} {
	return \\[format %o $chcode]
︙︙
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231


    return $ch
}

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

proc ::char::quote::comment {ch args} {
    if {![llength $args]} { return [Comment $ch] }
    lappend res [Comment $ch]
    foreach ch $args { lappend res [Comment $ch] }
    return $res
}

proc ::char::quote::Comment {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser when used within a Tcl
    # comment.









<
|
<
<








215
216
217
218
219
220
221

222


223
224
225
226
227
228
229


    return $ch
}

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

proc ::char::quote::comment {ch args} {

    Arg Comment $ch {*}$args


}

proc ::char::quote::Comment {ch} {
    # Converts a Tcl character (internal representation) into a string
    # which is accepted by the Tcl parser when used within a Tcl
    # comment.
︙︙
256
257
258
259
260
261
262
























263
264
265
266
267

	return \\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}

























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

package provide char 1.0.1








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






254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289

	return \\u[format %04x $chcode]
    }

    # Regular character: Is its own representation.

    return $ch
}

# ### ### ### ######### ######### #########
## Internal. Argument processing helper

proc ::char::quote::Arg {cmdpfx str args} {
    # single argument => treat as string,
    # process all characters separately.
    # return transformed string.
    if {![llength $args]} {
	set r {}
	foreach c [split $str {}] {
	    append r [uplevel 1 [linsert $cmdpfx end $c]]
	}
	return $r
    }

    # multiple arguments => process each like a single argument, and
    # return list of transform results.
    set args [linsert $args 0 $str]
    foreach str $args {
	lappend res [uplevel 1 [list Arg $cmdpfx $str]]
    }
    return $res
}

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

package provide char 1.0.1

Changes to modules/pt/tests/char.tests.

︙︙
47
48
49
50
51
52
53
54














55
56
57
58
59
60
61
62

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-2.3.$n "char tcl, map $label" -body {
	char quote tcl $input
    } -result $expected
}














unset -nocomplain n label input expected

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

test char-3.0 {char string, wrong#args} -body {
    char quote string
} -returnCodes error -result {wrong # args: should be "char quote string ch ..."}









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








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

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-2.3.$n "char tcl, map $label" -body {
	char quote tcl $input
    } -result $expected

    # collect table columns for string and multi-arg tests.
    lappend ll $label
    lappend li $input
    lappend le $expected
}

test char-2.4 "char tcl, map string" -body {
    char quote tcl [join $li {}]
} -result [join $le {}]

test char-2.5 "char tcl, map multiple" -body {
    char quote tcl {*}$li
} -result $le

unset -nocomplain n label input expected ll li le

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

test char-3.0 {char string, wrong#args} -body {
    char quote string
} -returnCodes error -result {wrong # args: should be "char quote string ch ..."}
︙︙
79
80
81
82
83
84
85
86














87
88
89
90
91
92
93
94

    7 A         A      A
    8 del       \177   <DEL>
    9 circast   \u229b \u229b
} {
    test char-3.3.$n "char string, map $label" -body {
	char quote string $input
    } -result $expected
}














unset -nocomplain n label input expected

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

test char-4.0 {char cstring, wrong#args} -body {
    char quote cstring
} -returnCodes error -result {wrong # args: should be "char quote cstring ch ..."}









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








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

    7 A         A      A
    8 del       \177   <DEL>
    9 circast   \u229b \u229b
} {
    test char-3.3.$n "char string, map $label" -body {
	char quote string $input
    } -result $expected

    # collect table columns for string and multi-arg tests.
    lappend ll $label
    lappend li $input
    lappend le $expected
}

test char-3.4 "char string, map string" -body {
    char quote string [join $li {}]
} -result [join $le {}]

test char-3.5 "char string, map multiple" -body {
    char quote string {*}$li
} -result $le

unset -nocomplain n label input expected ll li le

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

test char-4.0 {char cstring, wrong#args} -body {
    char quote cstring
} -returnCodes error -result {wrong # args: should be "char quote cstring ch ..."}
︙︙
111
112
113
114
115
116
117
118














119
120
121
122
123
124
125
126

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\342\\212\\233
} {
    test char-4.3.$n "char cstring, map $label" -body {
	char quote cstring $input
    } -result $expected
}














unset -nocomplain n label input expected

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

test char-5.0 {char comment, wrong#args} -body {
    char quote comment
} -returnCodes error -result {wrong # args: should be "char quote comment ch ..."}









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








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

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\342\\212\\233
} {
    test char-4.3.$n "char cstring, map $label" -body {
	char quote cstring $input
    } -result $expected

    # collect table columns for string and multi-arg tests.
    lappend ll $label
    lappend li $input
    lappend le $expected
}

test char-4.4 "char cstring, map string" -body {
    char quote cstring [join $li {}]
} -result [join $le {}]

test char-4.5 "char cstring, map multiple" -body {
    char quote cstring {*}$li
} -result $le

unset -nocomplain n label input expected ll li le

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

test char-5.0 {char comment, wrong#args} -body {
    char quote comment
} -returnCodes error -result {wrong # args: should be "char quote comment ch ..."}
︙︙
143
144
145
146
147
148
149
150














151
152
153
154

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-5.3.$n "char comment, map $label" -body {
	char quote comment $input
    } -result $expected
}














unset -nocomplain n label input expected

#----------------------------------------------------------------------
return








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




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

    7 A         A      A
    8 del       \177   \\177
    9 circast   \u229b \\u229b
} {
    test char-5.3.$n "char comment, map $label" -body {
	char quote comment $input
    } -result $expected

    # collect table columns for string and multi-arg tests.
    lappend ll $label
    lappend li $input
    lappend le $expected
}

test char-5.4 "char comment, map string" -body {
    char quote comment [join $li {}]
} -result [join $le {}]

test char-5.5 "char comment, map multiple" -body {
    char quote comment {*}$li
} -result $le

unset -nocomplain n label input expected ll li le

#----------------------------------------------------------------------
return

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