aboutsummaryrefslogtreecommitdiff
path: root/tests/proc.test
blob: 462b71372d7d044188c85031a03637414de89890 (plain)
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
245
246
247
248
249
250
251
252
253
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
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
# Commands covered:  proc, return, global
#
# This file, proc-old.test, includes the original set of tests for Tcl's
# proc, return, and global commands. There is now a new file proc.test
# that contains tests for the tclProc.c source file.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $

source [file dirname [info script]]/testing.tcl

needs constraint jim
needs cmd array

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}
test proc-old-1.1 {simple procedure call and return} {tproc} a
proc tproc x {
    set x [expr $x+1]
    return $x
}
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
test proc-old-1.3 {simple procedure call and return} {
    proc tproc {} {return foo}
} {tproc}
test proc-old-1.4 {simple procedure call and return} {
    proc tproc {} {return}
    tproc
} {}
proc tproc1 {a}   {incr a; return $a}
proc tproc2 {a b} {incr a; return $a}
test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
    list [tproc1 123] [tproc2 456 789]
} {124 457}
test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
    set x {}
    proc tproc {} {}   ;# body is shared with x
    list [tproc] [append x foo]
} {{} foo}

test proc-old-2.1 {local and global variables} {
    proc tproc x {
	set x [expr $x+1]
	return $x
    }
    set x 42
    list [tproc 6] $x
} {7 42}
test proc-old-2.2 {local and global variables} {
    proc tproc x {
	set y [expr $x+1]
	return $y
    }
    set y 18
    list [tproc 6] $y
} {7 18}
test proc-old-2.3 {local and global variables} {
    proc tproc x {
	global y
	set y [expr $x+1]
	return $y
    }
    set y 189
    list [tproc 6] $y
} {7 7}
test proc-old-2.4 {local and global variables} {
    proc tproc x {
	global y
	return [expr $x+$y]
    }
    set y 189
    list [tproc 6] $y
} {195 189}
catch {unset _undefined_}
test proc-old-2.5 {local and global variables} {
    proc tproc x {
	global _undefined_
	return $_undefined_
    }
    list [catch {tproc xxx} msg] $msg
} {1 {can't read "_undefined_": no such variable}}
test proc-old-2.6 {local and global variables} {
    set a 114
    set b 115
    global a b
    list $a $b
} {114 115}

proc do {cmd} {eval $cmd}
test proc-old-3.1 {local and global arrays} {
    catch {unset a}
    set a(0) 22
    list [catch {do {global a; set a(0)}} msg] $msg
} {0 22}
test proc-old-3.2 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
} {0 newValue newValue}
test proc-old-3.3 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a(y)}; array names a} msg] $msg
} {0 x}
test proc-old-3.4 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a; info exists a}} msg] $msg \
	    [info exists a]
} {0 0 0}
test proc-old-3.5 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a(y); array names a}} msg] $msg
} {0 x}
catch {unset a}
test proc-old-3.6 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    do {global a; do {global a; unset a}; set a(z) 22}
    list [catch {array names a} msg] $msg
} {0 z}
test proc-old-3.1 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    tproc 11 12 13
} {11 12 13}
test proc-old-3.2 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    list [catch {tproc 11 12} msg]
} {1}
test proc-old-3.3 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    list [catch {tproc 11 12 13 14} msg]
} {1}
test proc-old-3.4 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11 12 13
} {11 12 13}
test proc-old-3.5 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11 12
} {11 12 z-default}
test proc-old-3.6 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11
} {11 y-default z-default}
test proc-old-3.7 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    list [catch {tproc} msg]
} {1}
# Note: This requires new TIP #288 support
test proc-old-3.8 {arguments and defaults} {
    list [catch {
	proc tproc {x {y y-default} z} {
	    return [list $x $y $z]
	}
	tproc 2 3
    } msg] $msg
} {0 {2 y-default 3}}
test proc-old-3.9 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3 4 5
} {2 3 {4 5}}
test proc-old-3.10 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3
} {2 3 {}}
test proc-old-3.11 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2
} {2 y-default {}}
test proc-old-3.12 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    list [catch {tproc} msg]
} {1}

test proc-old-4.1 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc
} {}
test proc-old-4.2 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc 1 2 3 4 5 6 7 8
} {1 2 3 4 5 6 7 8}
test proc-old-4.3 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
test proc-old-4.4 {variable numbers of arguments} {
    proc tproc {x y args} {return $args}
    tproc 1 2 3 4 5 6 7
} {3 4 5 6 7}
test proc-old-4.5 {variable numbers of arguments} {
    proc tproc {x y args} {return $args}
    tproc 1 2
} {}
test proc-old-4.6 {variable numbers of arguments} {
    proc tproc {x missing args} {return $args}
    list [catch {tproc 1} msg]
} {1}

test proc-old-5.1 {error conditions} {
    list [catch {proc} msg]
} {1}
test proc-old-5.2 {error conditions} {
    list [catch {proc tproc b} msg]
} {1}
test proc-old-5.3 {error conditions} {
    list [catch {proc tproc b c d e} msg]
} {1}

test proc-5.4 {proc double args} -body {
    proc a {args args} {}
} -returnCodes error -result {'args' specified more than once}

test proc-old-5.6 {error conditions} {
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {argument with no name}}
test proc-old-5.7 {error conditions} {
    list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
} {1 {too many fields in argument specifier "x 1 2"}}
test proc-old-5.8 {error conditions} {
    catch {return}
} 2
test proc-old-5.9 {error conditions} {
    list [catch {global} msg] $msg
} {1 {wrong # args: should be "global varName ?varName ...?"}}
proc tproc {} {
    set a 22
    global a
}
test proc-old-5.10 {error conditions} {
    list [catch {tproc} msg] $msg
} {1 {variable "a" already exists}}
test proc-old-5.11 {error conditions} {
    catch {rename tproc {}}
    catch {
	proc tproc {x {} z} {return foo}
    }
    list [catch {tproc 1} msg] $msg
} {1 {invalid command name "tproc"}}
test proc-old-5.12 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    list [catch tproc msg] $msg
} {1 {error in procedure}}

# The tests below will really only be useful when run under Purify or
# some other system that can detect accesses to freed memory...

test proc-old-6.1 {procedure that redefines itself} {
    proc tproc {} {
	proc tproc {} {
	    return 44
	}
	return 45
    }
    tproc
} 45
test proc-old-6.2 {procedure that deletes itself} {
    proc tproc {} {
	rename tproc {}
	return 45
    }
    tproc
} 45

proc tproc code {
    return -code $code abc
}
test proc-old-7.1 {return with special completion code} {
    list [catch {tproc ok} msg] $msg
} {0 abc}
test proc-old-7.2 {return with special completion code} {
    list [catch {tproc error} msg] $msg
} {1 abc}
test proc-old-7.3 {return with special completion code} {
    list [catch {tproc return} msg] $msg
} {2 abc}
test proc-old-7.4 {return with special completion code} {
    list [catch {tproc break} msg] $msg
} {3 abc}
test proc-old-7.5 {return with special completion code} {
    list [catch {tproc continue} msg] $msg
} {4 abc}
test proc-old-7.6 {return with special completion code} {
    list [catch {tproc -14} msg] $msg
} {-14 abc}
test proc-old-7.7 {return with special completion code} {
    list [catch {tproc gorp} msg]
} {1}
test proc-old-7.8 {return with special completion code} {
    list [catch {tproc 10b} msg]
} {1}
test proc-old-7.9 {return with special completion code} {
    proc tproc2 {} {
	tproc return
    }
    list [catch tproc2 msg] $msg
} {0 abc}
test proc-old-7.10 {return with special completion code} {
    proc tproc2 {} {
	return -code error
    }
    list [catch tproc2 msg] $msg
} {1 {}}

test proc-old-8.1 {unset and undefined local arrays} {
    proc t1 {} {
        foreach v {xxx, yyy} {
            catch {unset $v}
        }
        set yyy(foo) bar
    }
    t1
} bar

test proc-old-9.1 {empty command name} {
    catch {rename {} ""}
    proc t1 {args} {
        return
    }
    set v [t1]
    catch {$v}
} 1

test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
    proc t1 x {
        set y 20
        rename expr expr.old
        rename expr.old expr
        if $x then {t1 0} ;# recursive call after foo's code is invalidated
        return 20
    }
    t1 1
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}

testreport