OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [tags/] [start/] [insight/] [tcl/] [tests/] [proc-old.test] - Blame information for rev 1780

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# Commands covered:  proc, return, global
2 
#
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.
6 
#
7 
# Sourcing this file into Tcl runs the tests and generates output for
8 
# errors.  No output means no errors were found.
9 
#
10 
# Copyright (c) 1991-1993 The Regents of the University of California.
11 
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
12 
#
13 
# See the file "license.terms" for information on usage and redistribution
14 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 
#
16 
# RCS: @(#) $Id: proc-old.test,v 1.1.1.1 2002-01-16 10:25:36 markom Exp $
17 
 
18 
if {[string compare test [info procs test]] == 1} then {source defs}
19 
 
20 
catch {rename t1 ""}
21 
catch {rename foo ""}
22 
 
23 
proc tproc {} {return a; return b}
24 
test proc-old-1.1 {simple procedure call and return} {tproc} a
25 
proc tproc x {
26 
    set x [expr $x+1]
27 
    return $x
28 
}
29 
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
30 
test proc-old-1.3 {simple procedure call and return} {
31 
    proc tproc {} {return foo}
32 
} {}
33 
test proc-old-1.4 {simple procedure call and return} {
34 
    proc tproc {} {return}
35 
    tproc
36 
} {}
37 
proc tproc1 {a}   {incr a; return $a}
38 
proc tproc2 {a b} {incr a; return $a}
39 
test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
40 
    list [tproc1 123] [tproc2 456 789]
41 
} {124 457}
42 
test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
43 
    set x {}
44 
    proc tproc {} {}   ;# body is shared with x
45 
    list [tproc] [append x foo]
46 
} {{} foo}
47 
 
48 
test proc-old-2.1 {local and global variables} {
49 
    proc tproc x {
50 
        set x [expr $x+1]
51 
        return $x
52 
    }
53 
    set x 42
54 
    list [tproc 6] $x
55 
} {7 42}
56 
test proc-old-2.2 {local and global variables} {
57 
    proc tproc x {
58 
        set y [expr $x+1]
59 
        return $y
60 
    }
61 
    set y 18
62 
    list [tproc 6] $y
63 
} {7 18}
64 
test proc-old-2.3 {local and global variables} {
65 
    proc tproc x {
66 
        global y
67 
        set y [expr $x+1]
68 
        return $y
69 
    }
70 
    set y 189
71 
    list [tproc 6] $y
72 
} {7 7}
73 
test proc-old-2.4 {local and global variables} {
74 
    proc tproc x {
75 
        global y
76 
        return [expr $x+$y]
77 
    }
78 
    set y 189
79 
    list [tproc 6] $y
80 
} {195 189}
81 
catch {unset _undefined_}
82 
test proc-old-2.5 {local and global variables} {
83 
    proc tproc x {
84 
        global _undefined_
85 
        return $_undefined_
86 
    }
87 
    list [catch {tproc xxx} msg] $msg
88 
} {1 {can't read "_undefined_": no such variable}}
89 
test proc-old-2.6 {local and global variables} {
90 
    set a 114
91 
    set b 115
92 
    global a b
93 
    list $a $b
94 
} {114 115}
95 
 
96 
proc do {cmd} {eval $cmd}
97 
test proc-old-3.1 {local and global arrays} {
98 
    catch {unset a}
99 
    set a(0) 22
100 
    list [catch {do {global a; set a(0)}} msg] $msg
101 
} {0 22}
102 
test proc-old-3.2 {local and global arrays} {
103 
    catch {unset a}
104 
    set a(x) 22
105 
    list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
106 
} {0 newValue newValue}
107 
test proc-old-3.3 {local and global arrays} {
108 
    catch {unset a}
109 
    set a(x) 22
110 
    set a(y) 33
111 
    list [catch {do {global a; unset a(y)}; array names a} msg] $msg
112 
} {0 x}
113 
test proc-old-3.4 {local and global arrays} {
114 
    catch {unset a}
115 
    set a(x) 22
116 
    set a(y) 33
117 
    list [catch {do {global a; unset a; info exists a}} msg] $msg \
118 
            [info exists a]
119 
} {0 0 0}
120 
test proc-old-3.5 {local and global arrays} {
121 
    catch {unset a}
122 
    set a(x) 22
123 
    set a(y) 33
124 
    list [catch {do {global a; unset a(y); array names a}} msg] $msg
125 
} {0 x}
126 
catch {unset a}
127 
test proc-old-3.6 {local and global arrays} {
128 
    catch {unset a}
129 
    set a(x) 22
130 
    set a(y) 33
131 
    do {global a; do {global a; unset a}; set a(z) 22}
132 
    list [catch {array names a} msg] $msg
133 
} {0 z}
134 
test proc-old-3.7 {local and global arrays} {
135 
    proc t1 {args} {global info; set info 1}
136 
    catch {unset a}
137 
    set info {}
138 
    do {global a; trace var a(1) w t1}
139 
    set a(1) 44
140 
    set info
141 
} 1
142 
test proc-old-3.8 {local and global arrays} {
143 
    proc t1 {args} {global info; set info 1}
144 
    catch {unset a}
145 
    trace var a(1) w t1
146 
    set info {}
147 
    do {global a; trace vdelete a(1) w t1}
148 
    set a(1) 44
149 
    set info
150 
} {}
151 
test proc-old-3.9 {local and global arrays} {
152 
    proc t1 {args} {global info; set info 1}
153 
    catch {unset a}
154 
    trace var a(1) w t1
155 
    do {global a; trace vinfo a(1)}
156 
} {{w t1}}
157 
catch {unset a}
158 
 
159 
test proc-old-3.1 {arguments and defaults} {
160 
    proc tproc {x y z} {
161 
        return [list $x $y $z]
162 
    }
163 
    tproc 11 12 13
164 
} {11 12 13}
165 
test proc-old-3.2 {arguments and defaults} {
166 
    proc tproc {x y z} {
167 
        return [list $x $y $z]
168 
    }
169 
    list [catch {tproc 11 12} msg] $msg
170 
} {1 {no value given for parameter "z" to "tproc"}}
171 
test proc-old-3.3 {arguments and defaults} {
172 
    proc tproc {x y z} {
173 
        return [list $x $y $z]
174 
    }
175 
    list [catch {tproc 11 12 13 14} msg] $msg
176 
} {1 {called "tproc" with too many arguments}}
177 
test proc-old-3.4 {arguments and defaults} {
178 
    proc tproc {x {y y-default} {z z-default}} {
179 
        return [list $x $y $z]
180 
    }
181 
    tproc 11 12 13
182 
} {11 12 13}
183 
test proc-old-3.5 {arguments and defaults} {
184 
    proc tproc {x {y y-default} {z z-default}} {
185 
        return [list $x $y $z]
186 
    }
187 
    tproc 11 12
188 
} {11 12 z-default}
189 
test proc-old-3.6 {arguments and defaults} {
190 
    proc tproc {x {y y-default} {z z-default}} {
191 
        return [list $x $y $z]
192 
    }
193 
    tproc 11
194 
} {11 y-default z-default}
195 
test proc-old-3.7 {arguments and defaults} {
196 
    proc tproc {x {y y-default} {z z-default}} {
197 
        return [list $x $y $z]
198 
    }
199 
    list [catch {tproc} msg] $msg
200 
} {1 {no value given for parameter "x" to "tproc"}}
201 
test proc-old-3.8 {arguments and defaults} {
202 
    list [catch {
203 
        proc tproc {x {y y-default} z} {
204 
            return [list $x $y $z]
205 
        }
206 
        tproc 2 3
207 
    } msg] $msg
208 
} {1 {no value given for parameter "z" to "tproc"}}
209 
test proc-old-3.9 {arguments and defaults} {
210 
    proc tproc {x {y y-default} args} {
211 
        return [list $x $y $args]
212 
    }
213 
    tproc 2 3 4 5
214 
} {2 3 {4 5}}
215 
test proc-old-3.10 {arguments and defaults} {
216 
    proc tproc {x {y y-default} args} {
217 
        return [list $x $y $args]
218 
    }
219 
    tproc 2 3
220 
} {2 3 {}}
221 
test proc-old-3.11 {arguments and defaults} {
222 
    proc tproc {x {y y-default} args} {
223 
        return [list $x $y $args]
224 
    }
225 
    tproc 2
226 
} {2 y-default {}}
227 
test proc-old-3.12 {arguments and defaults} {
228 
    proc tproc {x {y y-default} args} {
229 
        return [list $x $y $args]
230 
    }
231 
    list [catch {tproc} msg] $msg
232 
} {1 {no value given for parameter "x" to "tproc"}}
233 
 
234 
test proc-old-4.1 {variable numbers of arguments} {
235 
    proc tproc args {return $args}
236 
    tproc
237 
} {}
238 
test proc-old-4.2 {variable numbers of arguments} {
239 
    proc tproc args {return $args}
240 
    tproc 1 2 3 4 5 6 7 8
241 
} {1 2 3 4 5 6 7 8}
242 
test proc-old-4.3 {variable numbers of arguments} {
243 
    proc tproc args {return $args}
244 
    tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
245 
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
246 
test proc-old-4.4 {variable numbers of arguments} {
247 
    proc tproc {x y args} {return $args}
248 
    tproc 1 2 3 4 5 6 7
249 
} {3 4 5 6 7}
250 
test proc-old-4.5 {variable numbers of arguments} {
251 
    proc tproc {x y args} {return $args}
252 
    tproc 1 2
253 
} {}
254 
test proc-old-4.6 {variable numbers of arguments} {
255 
    proc tproc {x missing args} {return $args}
256 
    list [catch {tproc 1} msg] $msg
257 
} {1 {no value given for parameter "missing" to "tproc"}}
258 
 
259 
test proc-old-5.1 {error conditions} {
260 
    list [catch {proc} msg] $msg
261 
} {1 {wrong # args: should be "proc name args body"}}
262 
test proc-old-5.2 {error conditions} {
263 
    list [catch {proc tproc b} msg] $msg
264 
} {1 {wrong # args: should be "proc name args body"}}
265 
test proc-old-5.3 {error conditions} {
266 
    list [catch {proc tproc b c d e} msg] $msg
267 
} {1 {wrong # args: should be "proc name args body"}}
268 
test proc-old-5.4 {error conditions} {
269 
    list [catch {proc tproc \{xyz {return foo}} msg] $msg
270 
} {1 {unmatched open brace in list}}
271 
test proc-old-5.5 {error conditions} {
272 
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
273 
} {1 {procedure "tproc" has argument with no name}}
274 
test proc-old-5.6 {error conditions} {
275 
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
276 
} {1 {procedure "tproc" has argument with no name}}
277 
test proc-old-5.7 {error conditions} {
278 
    list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
279 
} {1 {too many fields in argument specifier "x 1 2"}}
280 
test proc-old-5.8 {error conditions} {
281 
    catch {return}
282 
} 2
283 
test proc-old-5.9 {error conditions} {
284 
    list [catch {global} msg] $msg
285 
} {1 {wrong # args: should be "global varName ?varName ...?"}}
286 
proc tproc {} {
287 
    set a 22
288 
    global a
289 
}
290 
test proc-old-5.10 {error conditions} {
291 
    list [catch {tproc} msg] $msg
292 
} {1 {variable "a" already exists}}
293 
test proc-old-5.11 {error conditions} {
294 
    catch {rename tproc {}}
295 
    catch {
296 
        proc tproc {x {} z} {return foo}
297 
    }
298 
    list [catch {tproc 1} msg] $msg
299 
} {1 {invalid command name "tproc"}}
300 
test proc-old-5.12 {error conditions} {
301 
    proc tproc {} {
302 
        set a 22
303 
        error "error in procedure"
304 
        return
305 
    }
306 
    list [catch tproc msg] $msg
307 
} {1 {error in procedure}}
308 
test proc-old-5.13 {error conditions} {
309 
    proc tproc {} {
310 
        set a 22
311 
        error "error in procedure"
312 
        return
313 
    }
314 
    catch tproc msg
315 
    set errorInfo
316 
} {error in procedure
317 
    while executing
318 
"error "error in procedure""
319 
    (procedure "tproc" line 3)
320 
    invoked from within
321 
"tproc"}
322 
test proc-old-5.14 {error conditions} {
323 
    proc tproc {} {
324 
        set a 22
325 
        break
326 
        return
327 
    }
328 
    catch tproc msg
329 
    set errorInfo
330 
} {invoked "break" outside of a loop
331 
    while executing
332 
"tproc"}
333 
test proc-old-5.15 {error conditions} {
334 
    proc tproc {} {
335 
        set a 22
336 
        continue
337 
        return
338 
    }
339 
    catch tproc msg
340 
    set errorInfo
341 
} {invoked "continue" outside of a loop
342 
    while executing
343 
"tproc"}
344 
test proc-old-5.16 {error conditions} {
345 
    proc foo args {
346 
        global fooMsg
347 
        set fooMsg "foo was called: $args"
348 
    }
349 
    proc tproc {} {
350 
        set x 44
351 
        trace var x u foo
352 
        while {$x < 100} {
353 
            error "Nested error"
354 
        }
355 
    }
356 
    set fooMsg "foo not called"
357 
    list [catch tproc msg] $msg $errorInfo $fooMsg
358 
} {1 {Nested error} {Nested error
359 
    while executing
360 
"error "Nested error""
361 
    (procedure "tproc" line 5)
362 
    invoked from within
363 
"tproc"} {foo was called: x {} u}}
364 
 
365 
# The tests below will really only be useful when run under Purify or
366 
# some other system that can detect accesses to freed memory...
367 
 
368 
test proc-old-6.1 {procedure that redefines itself} {
369 
    proc tproc {} {
370 
        proc tproc {} {
371 
            return 44
372 
        }
373 
        return 45
374 
    }
375 
    tproc
376 
} 45
377 
test proc-old-6.2 {procedure that deletes itself} {
378 
    proc tproc {} {
379 
        rename tproc {}
380 
        return 45
381 
    }
382 
    tproc
383 
} 45
384 
 
385 
proc tproc code {
386 
    return -code $code abc
387 
}
388 
test proc-old-7.1 {return with special completion code} {
389 
    list [catch {tproc ok} msg] $msg
390 
} {0 abc}
391 
test proc-old-7.2 {return with special completion code} {
392 
    list [catch {tproc error} msg] $msg $errorInfo $errorCode
393 
} {1 abc {abc
394 
    while executing
395 
"tproc error"} NONE}
396 
test proc-old-7.3 {return with special completion code} {
397 
    list [catch {tproc return} msg] $msg
398 
} {2 abc}
399 
test proc-old-7.4 {return with special completion code} {
400 
    list [catch {tproc break} msg] $msg
401 
} {3 abc}
402 
test proc-old-7.5 {return with special completion code} {
403 
    list [catch {tproc continue} msg] $msg
404 
} {4 abc}
405 
test proc-old-7.6 {return with special completion code} {
406 
    list [catch {tproc -14} msg] $msg
407 
} {-14 abc}
408 
test proc-old-7.7 {return with special completion code} {
409 
    list [catch {tproc gorp} msg] $msg
410 
} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
411 
test proc-old-7.8 {return with special completion code} {
412 
    list [catch {tproc 10b} msg] $msg
413 
} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
414 
test proc-old-7.9 {return with special completion code} {
415 
    proc tproc2 {} {
416 
        tproc return
417 
    }
418 
    list [catch tproc2 msg] $msg
419 
} {0 abc}
420 
test proc-old-7.10 {return with special completion code} {
421 
    proc tproc2 {} {
422 
        return -code error
423 
    }
424 
    list [catch tproc2 msg] $msg
425 
} {1 {}}
426 
test proc-old-7.11 {return with special completion code} {
427 
    proc tproc2 {} {
428 
        global errorCode errorInfo
429 
        catch {open _bad_file_name r} msg
430 
        return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
431 
    }
432 
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
433 
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
434 
    while executing
435 
"open _bad_file_name r"
436 
    invoked from within
437 
"tproc2"} {posix enoent {no such file or directory}}}
438 
test proc-old-7.12 {return with special completion code} {
439 
    proc tproc2 {} {
440 
        global errorCode errorInfo
441 
        catch {open _bad_file_name r} msg
442 
        return -code error -errorcode $errorCode $msg
443 
    }
444 
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
445 
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
446 
    while executing
447 
"tproc2"} {posix enoent {no such file or directory}}}
448 
test proc-old-7.13 {return with special completion code} {
449 
    proc tproc2 {} {
450 
        global errorCode errorInfo
451 
        catch {open _bad_file_name r} msg
452 
        return -code error -errorinfo $errorInfo $msg
453 
    }
454 
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
455 
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
456 
    while executing
457 
"open _bad_file_name r"
458 
    invoked from within
459 
"tproc2"} none}
460 
test proc-old-7.14 {return with special completion code} {
461 
    proc tproc2 {} {
462 
        global errorCode errorInfo
463 
        catch {open _bad_file_name r} msg
464 
        return -code error $msg
465 
    }
466 
    normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
467 
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
468 
    while executing
469 
"tproc2"} none}
470 
test proc-old-7.14 {return with special completion code} {
471 
    list [catch {return -badOption foo message} msg] $msg
472 
} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
473 
 
474 
test proc-old-8.1 {unset and undefined local arrays} {
475 
    proc t1 {} {
476 
        foreach v {xxx, yyy} {
477 
            catch {unset $v}
478 
        }
479 
        set yyy(foo) bar
480 
    }
481 
    t1
482 
} bar
483 
 
484 
test proc-old-9.1 {empty command name} {
485 
    catch {rename {} ""}
486 
    proc t1 {args} {
487 
        return
488 
    }
489 
    set v [t1]
490 
    catch {$v}
491 
} 1
492 
 
493 
test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
494 
    proc t1 x {
495 
        set y 20
496 
        rename expr expr.old
497 
        rename expr.old expr
498 
        if $x then {t1 0} ;# recursive call after foo's code is invalidated
499 
        return 20
500 
    }
501 
    t1 1
502 
} 20
503 
 
504 
catch {rename t1 ""}
505 
catch {rename foo ""}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.