tests/proc.test

   1 # 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 # Copyright (c) 1998-1999 by Scriptics Corporation.
  13 #
  14 # See the file "license.terms" for information on usage and redistribution
  15 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16 #
  17 # RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $
  18
  19 source [file dirname [info script]]/testing.tcl
  20
  21 needs constraint jim
  22 needs cmd array
  23
  24 catch {rename t1 ""}
  25 catch {rename foo ""}
  26
  27 proc tproc {} {return a; return b}
  28 test proc-old-1.1 {simple procedure call and return} {tproc} a
  29 proc tproc x {
  30     set x [expr $x+1]
  31     return $x
  32 }
  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}
  36 } {tproc}
  37 test proc-old-1.4 {simple procedure call and return} {
  38     proc tproc {} {return}
  39     tproc
  40 } {}
  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]
  45 } {124 457}
  46 test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
  47     set x {}
  48     proc tproc {} {}   ;# body is shared with x
  49     list [tproc] [append x foo]
  50 } {{} foo}
  51
  52 test proc-old-2.1 {local and global variables} {
  53     proc tproc x {
  54         set x [expr $x+1]
  55         return $x
  56     }
  57     set x 42
  58     list [tproc 6] $x
  59 } {7 42}
  60 test proc-old-2.2 {local and global variables} {
  61     proc tproc x {
  62         set y [expr $x+1]
  63         return $y
  64     }
  65     set y 18
  66     list [tproc 6] $y
  67 } {7 18}
  68 test proc-old-2.3 {local and global variables} {
  69     proc tproc x {
  70         global y
  71         set y [expr $x+1]
  72         return $y
  73     }
  74     set y 189
  75     list [tproc 6] $y
  76 } {7 7}
  77 test proc-old-2.4 {local and global variables} {
  78     proc tproc x {
  79         global y
  80         return [expr $x+$y]
  81     }
  82     set y 189
  83     list [tproc 6] $y
  84 } {195 189}
  85 catch {unset _undefined_}
  86 test proc-old-2.5 {local and global variables} {
  87     proc tproc x {
  88         global _undefined_
  89         return $_undefined_
  90     }
  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} {
  94     set a 114
  95     set b 115
  96     global a b
  97     list $a $b
  98 } {114 115}
  99
 100 proc do {cmd} {eval $cmd}
 101 test proc-old-3.1 {local and global arrays} {
 102     catch {unset a}
 103     set a(0) 22
 104     list [catch {do {global a; set a(0)}} msg] $msg
 105 } {0 22}
 106 test proc-old-3.2 {local and global arrays} {
 107     catch {unset a}
 108     set a(x) 22
 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} {
 112     catch {unset a}
 113     set a(x) 22
 114     set a(y) 33
 115     list [catch {do {global a; unset a(y)}; array names a} msg] $msg
 116 } {0 x}
 117 test proc-old-3.4 {local and global arrays} {
 118     catch {unset a}
 119     set a(x) 22
 120     set a(y) 33
 121     list [catch {do {global a; unset a; info exists a}} msg] $msg \
 122             [info exists a]
 123 } {0 0 0}
 124 test proc-old-3.5 {local and global arrays} {
 125     catch {unset a}
 126     set a(x) 22
 127     set a(y) 33
 128     list [catch {do {global a; unset a(y); array names a}} msg] $msg
 129 } {0 x}
 130 catch {unset a}
 131 test proc-old-3.6 {local and global arrays} {
 132     catch {unset a}
 133     set a(x) 22
 134     set a(y) 33
 135     do {global a; do {global a; unset a}; set a(z) 22}
 136     list [catch {array names a} msg] $msg
 137 } {0 z}
 138 test proc-old-3.1 {arguments and defaults} {
 139     proc tproc {x y z} {
 140         return [list $x $y $z]
 141     }
 142     tproc 11 12 13
 143 } {11 12 13}
 144 test proc-old-3.2 {arguments and defaults} {
 145     proc tproc {x y z} {
 146         return [list $x $y $z]
 147     }
 148     list [catch {tproc 11 12} msg]
 149 } {1}
 150 test proc-old-3.3 {arguments and defaults} {
 151     proc tproc {x y z} {
 152         return [list $x $y $z]
 153     }
 154     list [catch {tproc 11 12 13 14} msg]
 155 } {1}
 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]
 159     }
 160     tproc 11 12 13
 161 } {11 12 13}
 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]
 165     }
 166     tproc 11 12
 167 } {11 12 z-default}
 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]
 171     }
 172     tproc 11
 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]
 177     }
 178     list [catch {tproc} msg]
 179 } {1}
 180 # Note: This requires new TIP #288 support
 181 test proc-old-3.8 {arguments and defaults} {
 182     list [catch {
 183         proc tproc {x {y y-default} z} {
 184             return [list $x $y $z]
 185         }
 186         tproc 2 3
 187     } msg] $msg
 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]
 192     }
 193     tproc 2 3 4 5
 194 } {2 3 {4 5}}
 195 test proc-old-3.10 {arguments and defaults} {
 196     proc tproc {x {y y-default} args} {
 197         return [list $x $y $args]
 198     }
 199     tproc 2 3
 200 } {2 3 {}}
 201 test proc-old-3.11 {arguments and defaults} {
 202     proc tproc {x {y y-default} args} {
 203         return [list $x $y $args]
 204     }
 205     tproc 2
 206 } {2 y-default {}}
 207 test proc-old-3.12 {arguments and defaults} {
 208     proc tproc {x {y y-default} args} {
 209         return [list $x $y $args]
 210     }
 211     list [catch {tproc} msg]
 212 } {1}
 213
 214 test proc-old-4.1 {variable numbers of arguments} {
 215     proc tproc args {return $args}
 216     tproc
 217 } {}
 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
 221 } {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}
 228     tproc 1 2 3 4 5 6 7
 229 } {3 4 5 6 7}
 230 test proc-old-4.5 {variable numbers of arguments} {
 231     proc tproc {x y args} {return $args}
 232     tproc 1 2
 233 } {}
 234 test proc-old-4.6 {variable numbers of arguments} {
 235     proc tproc {x missing args} {return $args}
 236     list [catch {tproc 1} msg]
 237 } {1}
 238
 239 test proc-old-5.1 {error conditions} {
 240     list [catch {proc} msg]
 241 } {1}
 242 test proc-old-5.2 {error conditions} {
 243     list [catch {proc tproc b} msg]
 244 } {1}
 245 test proc-old-5.3 {error conditions} {
 246     list [catch {proc tproc b c d e} msg]
 247 } {1}
 248
 249 test proc-5.4 {proc double args} -body {
 250     proc a {args args} {}
 251 } -returnCodes error -result {'args' specified more than once}
 252
 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} {
 260     catch {return}
 261 } 2
 262 test proc-old-5.9 {error conditions} {
 263     list [catch {global} msg] $msg
 264 } {1 {wrong # args: should be "global varName ?varName ...?"}}
 265 proc tproc {} {
 266     set a 22
 267     global a
 268 }
 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 {}}
 274     catch {
 275         proc tproc {x {} z} {return foo}
 276     }
 277     list [catch {tproc 1} msg] $msg
 278 } {1 {invalid command name "tproc"}}
 279 test proc-old-5.12 {error conditions} {
 280     proc tproc {} {
 281         set a 22
 282         error "error in procedure"
 283         return
 284     }
 285     list [catch tproc msg] $msg
 286 } {1 {error in procedure}}
 287
 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...
 290
 291 test proc-old-6.1 {procedure that redefines itself} {
 292     proc tproc {} {
 293         proc tproc {} {
 294             return 44
 295         }
 296         return 45
 297     }
 298     tproc
 299 } 45
 300 test proc-old-6.2 {procedure that deletes itself} {
 301     proc tproc {} {
 302         rename tproc {}
 303         return 45
 304     }
 305     tproc
 306 } 45
 307
 308 proc tproc code {
 309     return -code $code abc
 310 }
 311 test proc-old-7.1 {return with special completion code} {
 312     list [catch {tproc ok} msg] $msg
 313 } {0 abc}
 314 test proc-old-7.2 {return with special completion code} {
 315     list [catch {tproc error} msg] $msg
 316 } {1 abc}
 317 test proc-old-7.3 {return with special completion code} {
 318     list [catch {tproc return} msg] $msg
 319 } {2 abc}
 320 test proc-old-7.4 {return with special completion code} {
 321     list [catch {tproc break} msg] $msg
 322 } {3 abc}
 323 test proc-old-7.5 {return with special completion code} {
 324     list [catch {tproc continue} msg] $msg
 325 } {4 abc}
 326 test proc-old-7.6 {return with special completion code} {
 327     list [catch {tproc -14} msg] $msg
 328 } {-14 abc}
 329 test proc-old-7.7 {return with special completion code} {
 330     list [catch {tproc gorp} msg]
 331 } {1}
 332 test proc-old-7.8 {return with special completion code} {
 333     list [catch {tproc 10b} msg]
 334 } {1}
 335 test proc-old-7.9 {return with special completion code} {
 336     proc tproc2 {} {
 337         tproc return
 338     }
 339     list [catch tproc2 msg] $msg
 340 } {0 abc}
 341 test proc-old-7.10 {return with special completion code} {
 342     proc tproc2 {} {
 343         return -code error
 344     }
 345     list [catch tproc2 msg] $msg
 346 } {1 {}}
 347
 348 test proc-old-8.1 {unset and undefined local arrays} {
 349     proc t1 {} {
 350         foreach v {xxx, yyy} {
 351             catch {unset $v}
 352         }
 353         set yyy(foo) bar
 354     }
 355     t1
 356 } bar
 357
 358 test proc-old-9.1 {empty command name} {
 359     catch {rename {} ""}
 360     proc t1 {args} {
 361         return
 362     }
 363     set v [t1]
 364     catch {$v}
 365 } 1
 366
 367 test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
 368     proc t1 x {
 369         set y 20
 370         rename expr expr.old
 371         rename expr.old expr
 372         if $x then {t1 0} ;# recursive call after foo's code is invalidated
 373         return 20
 374     }
 375     t1 1
 376 } 20
 377
 378 # cleanup
 379 catch {rename t1 ""}
 380 catch {rename foo ""}
 381
 382 testreport