1 # Commands covered: proc, return, global
3 # This file, proc-old.test, includes the original set of tests for Tcl's
4 # proc, return, and global commands. There is now a new file proc.test
5 # that contains tests for the tclProc.c source file.
7 # Sourcing this file into Tcl runs the tests and generates output for
8 # errors. No output means no errors were found.
10 # Copyright (c) 1991-1993 The Regents of the University of California.
11 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
12 # Copyright (c) 1998-1999 by Scriptics Corporation.
14 # See the file "license.terms" for information on usage and redistribution
15 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17 # RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $
19 source [file dirname [info script]]/testing.tcl
27 proc tproc {} {return a; return b}
28 test proc-old-1.1 {simple procedure call and return} {tproc} a
33 test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
34 test proc-old-1.3 {simple procedure call and return} {
35 proc tproc {} {return foo}
37 test proc-old-1.4 {simple procedure call and return} {
38 proc tproc {} {return}
41 proc tproc1 {a} {incr a; return $a}
42 proc tproc2 {a b} {incr a; return $a}
43 test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
44 list [tproc1 123] [tproc2 456 789]
46 test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
48 proc tproc {} {} ;# body is shared with x
49 list [tproc] [append x foo]
52 test proc-old-2.1 {local and global variables} {
60 test proc-old-2.2 {local and global variables} {
68 test proc-old-2.3 {local and global variables} {
77 test proc-old-2.4 {local and global variables} {
85 catch {unset _undefined_}
86 test proc-old-2.5 {local and global variables} {
91 list [catch {tproc xxx} msg] $msg
92 } {1 {can't read "_undefined_": no such variable}}
93 test proc-old-2.6 {local and global variables} {
100 proc do {cmd} {eval $cmd}
101 test proc-old-3.1 {local and global arrays} {
104 list [catch {do {global a; set a(0)}} msg] $msg
106 test proc-old-3.2 {local and global arrays} {
109 list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
110 } {0 newValue newValue}
111 test proc-old-3.3 {local and global arrays} {
115 list [catch {do {global a; unset a(y)}; array names a} msg] $msg
117 test proc-old-3.4 {local and global arrays} {
121 list [catch {do {global a; unset a; info exists a}} msg] $msg \
124 test proc-old-3.5 {local and global arrays} {
128 list [catch {do {global a; unset a(y); array names a}} msg] $msg
131 test proc-old-3.6 {local and global arrays} {
135 do {global a; do {global a; unset a}; set a(z) 22}
136 list [catch {array names a} msg] $msg
138 test proc-old-3.1 {arguments and defaults} {
140 return [list $x $y $z]
144 test proc-old-3.2 {arguments and defaults} {
146 return [list $x $y $z]
148 list [catch {tproc 11 12} msg]
150 test proc-old-3.3 {arguments and defaults} {
152 return [list $x $y $z]
154 list [catch {tproc 11 12 13 14} msg]
156 test proc-old-3.4 {arguments and defaults} {
157 proc tproc {x {y y-default} {z z-default}} {
158 return [list $x $y $z]
162 test proc-old-3.5 {arguments and defaults} {
163 proc tproc {x {y y-default} {z z-default}} {
164 return [list $x $y $z]
168 test proc-old-3.6 {arguments and defaults} {
169 proc tproc {x {y y-default} {z z-default}} {
170 return [list $x $y $z]
173 } {11 y-default z-default}
174 test proc-old-3.7 {arguments and defaults} {
175 proc tproc {x {y y-default} {z z-default}} {
176 return [list $x $y $z]
178 list [catch {tproc} msg]
180 # Note: This requires new TIP #288 support
181 test proc-old-3.8 {arguments and defaults} {
183 proc tproc {x {y y-default} z} {
184 return [list $x $y $z]
188 } {0 {2 y-default 3}}
189 test proc-old-3.9 {arguments and defaults} {
190 proc tproc {x {y y-default} args} {
191 return [list $x $y $args]
195 test proc-old-3.10 {arguments and defaults} {
196 proc tproc {x {y y-default} args} {
197 return [list $x $y $args]
201 test proc-old-3.11 {arguments and defaults} {
202 proc tproc {x {y y-default} args} {
203 return [list $x $y $args]
207 test proc-old-3.12 {arguments and defaults} {
208 proc tproc {x {y y-default} args} {
209 return [list $x $y $args]
211 list [catch {tproc} msg]
214 test proc-old-4.1 {variable numbers of arguments} {
215 proc tproc args {return $args}
218 test proc-old-4.2 {variable numbers of arguments} {
219 proc tproc args {return $args}
220 tproc 1 2 3 4 5 6 7 8
222 test proc-old-4.3 {variable numbers of arguments} {
223 proc tproc args {return $args}
224 tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
225 } {1 {2 3} {4 {5 6} {{{7}}}} 8}
226 test proc-old-4.4 {variable numbers of arguments} {
227 proc tproc {x y args} {return $args}
230 test proc-old-4.5 {variable numbers of arguments} {
231 proc tproc {x y args} {return $args}
234 test proc-old-4.6 {variable numbers of arguments} {
235 proc tproc {x missing args} {return $args}
236 list [catch {tproc 1} msg]
239 test proc-old-5.1 {error conditions} {
240 list [catch {proc} msg]
242 test proc-old-5.2 {error conditions} {
243 list [catch {proc tproc b} msg]
245 test proc-old-5.3 {error conditions} {
246 list [catch {proc tproc b c d e} msg]
249 test proc-5.4 {proc double args} -body {
250 proc a {args args} {}
251 } -returnCodes error -result {'args' specified more than once}
253 test proc-old-5.6 {error conditions} {
254 list [catch {proc tproc {{} y} {return foo}} msg] $msg
255 } {1 {argument with no name}}
256 test proc-old-5.7 {error conditions} {
257 list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
258 } {1 {too many fields in argument specifier "x 1 2"}}
259 test proc-old-5.8 {error conditions} {
262 test proc-old-5.9 {error conditions} {
263 list [catch {global} msg] $msg
264 } {1 {wrong # args: should be "global varName ?varName ...?"}}
269 test proc-old-5.10 {error conditions} {
270 list [catch {tproc} msg] $msg
271 } {1 {variable "a" already exists}}
272 test proc-old-5.11 {error conditions} {
273 catch {rename tproc {}}
275 proc tproc {x {} z} {return foo}
277 list [catch {tproc 1} msg] $msg
278 } {1 {invalid command name "tproc"}}
279 test proc-old-5.12 {error conditions} {
282 error "error in procedure"
285 list [catch tproc msg] $msg
286 } {1 {error in procedure}}
288 # The tests below will really only be useful when run under Purify or
289 # some other system that can detect accesses to freed memory...
291 test proc-old-6.1 {procedure that redefines itself} {
300 test proc-old-6.2 {procedure that deletes itself} {
309 return -code $code abc
311 test proc-old-7.1 {return with special completion code} {
312 list [catch {tproc ok} msg] $msg
314 test proc-old-7.2 {return with special completion code} {
315 list [catch {tproc error} msg] $msg
317 test proc-old-7.3 {return with special completion code} {
318 list [catch {tproc return} msg] $msg
320 test proc-old-7.4 {return with special completion code} {
321 list [catch {tproc break} msg] $msg
323 test proc-old-7.5 {return with special completion code} {
324 list [catch {tproc continue} msg] $msg
326 test proc-old-7.6 {return with special completion code} {
327 list [catch {tproc -14} msg] $msg
329 test proc-old-7.7 {return with special completion code} {
330 list [catch {tproc gorp} msg]
332 test proc-old-7.8 {return with special completion code} {
333 list [catch {tproc 10b} msg]
335 test proc-old-7.9 {return with special completion code} {
339 list [catch tproc2 msg] $msg
341 test proc-old-7.10 {return with special completion code} {
345 list [catch tproc2 msg] $msg
348 test proc-old-8.1 {unset and undefined local arrays} {
350 foreach v {xxx, yyy} {
358 test proc-old-9.1 {empty command name} {
367 test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
372 if $x then {t1 0} ;# recursive call after foo's code is invalidated
380 catch {rename foo ""}