aboutsummaryrefslogtreecommitdiff
path: root/tests/proc.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/proc.test')
-rw-r--r--tests/proc.test379
1 files changed, 379 insertions, 0 deletions
diff --git a/tests/proc.test b/tests/proc.test
new file mode 100644
index 0000000..2e65c35
--- /dev/null
+++ b/tests/proc.test
@@ -0,0 +1,379 @@
+# 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 testing.tcl
+
+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.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}
+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]
+} {1}
+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-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}}
+
+# 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
generated by cgit v1.1 at 2024-10-11 00:19:51 +0000