summaryrefslogtreecommitdiffstats
path: root/tests/proc-old.test
blob: a802c6347fb8339cc493985ce9c10d35e40c69ea (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
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
# 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.4 1999/06/26 03:54:21 jenn Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
	namespace import ::tcltest::*
}

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}
} {}
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.7 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    set info {}
    do {global a; trace var a(1) w t1}
    set a(1) 44
    set info
} 1
test proc-old-3.8 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    trace var a(1) w t1
    set info {}
    do {global a; trace vdelete a(1) w t1}
    set a(1) 44
    set info
} {}
test proc-old-3.9 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    trace var a(1) w t1
    do {global a; trace vinfo a(1)}
} {{w t1}}
catch {unset a}

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] $msg
} {1 {no value given for parameter "z" to "tproc"}}
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] $msg
} {1 {called "tproc" with too many arguments}}
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] $msg
} {1 {no value given for parameter "x" to "tproc"}}
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
} {1 {no value given for parameter "z" to "tproc"}}
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] $msg
} {1 {no value given for parameter "x" to "tproc"}}

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] $msg
} {1 {no value given for parameter "missing" to "tproc"}}

test proc-old-5.1 {error conditions} {
    list [catch {proc} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-old-5.2 {error conditions} {
    list [catch {proc tproc b} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-old-5.3 {error conditions} {
    list [catch {proc tproc b c d e} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-old-5.4 {error conditions} {
    list [catch {proc tproc \{xyz {return foo}} msg] $msg
} {1 {unmatched open brace in list}}
test proc-old-5.5 {error conditions} {
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {procedure "tproc" has argument with no name}}
test proc-old-5.6 {error conditions} {
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {procedure "tproc" has 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}}
test proc-old-5.13 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    catch tproc msg
    set errorInfo
} {error in procedure
    while executing
"error "error in procedure""
    (procedure "tproc" line 3)
    invoked from within
"tproc"}
test proc-old-5.14 {error conditions} {
    proc tproc {} {
	set a 22
	break
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "break" outside of a loop
    while executing
"tproc"}
test proc-old-5.15 {error conditions} {
    proc tproc {} {
	set a 22
	continue
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "continue" outside of a loop
    while executing
"tproc"}
test proc-old-5.16 {error conditions} {
    proc foo args {
	global fooMsg
	set fooMsg "foo was called: $args"
    }
    proc tproc {} {
	set x 44
	trace var x u foo
	while {$x < 100} {
	    error "Nested error"
	}
    }
    set fooMsg "foo not called"
    list [catch tproc msg] $msg $errorInfo $fooMsg
} {1 {Nested error} {Nested error
    while executing
"error "Nested error""
    (procedure "tproc" line 5)
    invoked from within
"tproc"} {foo was called: x {} u}}

# 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 $errorInfo $errorCode
} {1 abc {abc
    while executing
"tproc error"} NONE}
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] $msg
} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
test proc-old-7.8 {return with special completion code} {
    list [catch {tproc 10b} msg] $msg
} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
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-7.11 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
    }
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.12 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorcode $errorCode $msg
    }
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.13 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo $msg
    }
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} none}
test proc-old-7.14 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error $msg
    }
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} none}
test proc-old-7.14 {return with special completion code} {
    list [catch {return -badOption foo message} msg] $msg
} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}

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 ""}
::tcltest::cleanupTests
return