383 lines
9.8 KiB
Plaintext
383 lines
9.8 KiB
Plaintext
# 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
|