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
 250
 251 test proc-old-5.6 {error conditions} {
 252     list [catch {proc tproc {{} y} {return foo}} msg] $msg
 253 } {1 {argument with no name}}
 254 test proc-old-5.7 {error conditions} {
 255     list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
 256 } {1 {too many fields in argument specifier "x 1 2"}}
 257 test proc-old-5.8 {error conditions} {
 258     catch {return}
 259 } 2
 260 test proc-old-5.9 {error conditions} {
 261     list [catch {global} msg] $msg
 262 } {1 {wrong # args: should be "global varName ?varName ...?"}}
 263 proc tproc {} {
 264     set a 22
 265     global a
 266 }
 267 test proc-old-5.10 {error conditions} {
 268     list [catch {tproc} msg] $msg
 269 } {1 {variable "a" already exists}}
 270 test proc-old-5.11 {error conditions} {
 271     catch {rename tproc {}}
 272     catch {
 273         proc tproc {x {} z} {return foo}
 274     }
 275     list [catch {tproc 1} msg] $msg
 276 } {1 {invalid command name "tproc"}}
 277 test proc-old-5.12 {error conditions} {
 278     proc tproc {} {
 279         set a 22
 280         error "error in procedure"
 281         return
 282     }
 283     list [catch tproc msg] $msg
 284 } {1 {error in procedure}}
 285
 286 # The tests below will really only be useful when run under Purify or
 287 # some other system that can detect accesses to freed memory...
 288
 289 test proc-old-6.1 {procedure that redefines itself} {
 290     proc tproc {} {
 291         proc tproc {} {
 292             return 44
 293         }
 294         return 45
 295     }
 296     tproc
 297 } 45
 298 test proc-old-6.2 {procedure that deletes itself} {
 299     proc tproc {} {
 300         rename tproc {}
 301         return 45
 302     }
 303     tproc
 304 } 45
 305
 306 proc tproc code {
 307     return -code $code abc
 308 }
 309 test proc-old-7.1 {return with special completion code} {
 310     list [catch {tproc ok} msg] $msg
 311 } {0 abc}
 312 test proc-old-7.2 {return with special completion code} {
 313     list [catch {tproc error} msg] $msg
 314 } {1 abc}
 315 test proc-old-7.3 {return with special completion code} {
 316     list [catch {tproc return} msg] $msg
 317 } {2 abc}
 318 test proc-old-7.4 {return with special completion code} {
 319     list [catch {tproc break} msg] $msg
 320 } {3 abc}
 321 test proc-old-7.5 {return with special completion code} {
 322     list [catch {tproc continue} msg] $msg
 323 } {4 abc}
 324 test proc-old-7.6 {return with special completion code} {
 325     list [catch {tproc -14} msg] $msg
 326 } {-14 abc}
 327 test proc-old-7.7 {return with special completion code} {
 328     list [catch {tproc gorp} msg]
 329 } {1}
 330 test proc-old-7.8 {return with special completion code} {
 331     list [catch {tproc 10b} msg]
 332 } {1}
 333 test proc-old-7.9 {return with special completion code} {
 334     proc tproc2 {} {
 335         tproc return
 336     }
 337     list [catch tproc2 msg] $msg
 338 } {0 abc}
 339 test proc-old-7.10 {return with special completion code} {
 340     proc tproc2 {} {
 341         return -code error
 342     }
 343     list [catch tproc2 msg] $msg
 344 } {1 {}}
 345
 346 test proc-old-8.1 {unset and undefined local arrays} {
 347     proc t1 {} {
 348         foreach v {xxx, yyy} {
 349             catch {unset $v}
 350         }
 351         set yyy(foo) bar
 352     }
 353     t1
 354 } bar
 355
 356 test proc-old-9.1 {empty command name} {
 357     catch {rename {} ""}
 358     proc t1 {args} {
 359         return
 360     }
 361     set v [t1]
 362     catch {$v}
 363 } 1
 364
 365 test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
 366     proc t1 x {
 367         set y 20
 368         rename expr expr.old
 369         rename expr.old expr
 370         if $x then {t1 0} ;# recursive call after foo's code is invalidated
 371         return 20
 372     }
 373     t1 1
 374 } 20
 375
 376 # cleanup
 377 catch {rename t1 ""}
 378 catch {rename foo ""}
 379
 380 testreport