diff options
Diffstat (limited to 'tcl8.6/tests/proc-old.test')
| -rw-r--r-- | tcl8.6/tests/proc-old.test | 517 |
1 files changed, 0 insertions, 517 deletions
diff --git a/tcl8.6/tests/proc-old.test b/tcl8.6/tests/proc-old.test deleted file mode 100644 index e45cf5c..0000000 --- a/tcl8.6/tests/proc-old.test +++ /dev/null @@ -1,517 +0,0 @@ -# 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. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::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-30.1 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - tproc 11 12 13 -} {11 12 13} -test proc-old-30.2 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - list [catch {tproc 11 12} msg] $msg -} {1 {wrong # args: should be "tproc x y z"}} -test proc-old-30.3 {arguments and defaults} { - proc tproc {x y z} { - return [list $x $y $z] - } - list [catch {tproc 11 12 13 14} msg] $msg -} {1 {wrong # args: should be "tproc x y z"}} -test proc-old-30.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-30.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-30.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-30.7 {arguments and defaults} { - proc tproc {x {y y-default} {z z-default}} { - return [list $x $y $z] - } - list [catch {tproc} msg] $msg -} {1 {wrong # args: should be "tproc x ?y? ?z?"}} -test proc-old-30.8 {arguments and defaults} { - list [catch { - proc tproc {x {y y-default} z} { - return [list $x $y $z] - } - tproc 2 3 - } msg] $msg -} {1 {wrong # args: should be "tproc x ?y? z"}} -test proc-old-30.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-30.10 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - tproc 2 3 -} {2 3 {}} -test proc-old-30.11 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - tproc 2 -} {2 y-default {}} -test proc-old-30.12 {arguments and defaults} { - proc tproc {x {y y-default} args} { - return [list $x $y $args] - } - list [catch {tproc} msg] $msg -} {1 {wrong # args: should be "tproc x ?y? ?arg ...?"}} - -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 {wrong # args: should be "tproc x missing ?arg ...?"}} - -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 {argument with no name}} -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 -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 - (procedure "tproc" line 1) - invoked from within -"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 - (procedure "tproc" line 1) - invoked from within -"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} -body { - tproc err -} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer} -test proc-old-7.8 {return with special completion code} -body { - tproc 10b -} -returnCodes error -match glob -result {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 - } - set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] - regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg - normalizeMsg $msg -} {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 - } - set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] - regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg - normalizeMsg $msg -} {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 - } - set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] - regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg - normalizeMsg $msg -} {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 - } - set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] - regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg - normalizeMsg $msg -} {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.15 {return with special completion code} { - list [catch {return -badOption foo message} msg] $msg -} {2 message} - -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 |