home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tests / proc.test < prev    next >
Encoding:
Text File  |  1994-12-18  |  12.9 KB  |  462 lines
  1. # Commands covered:  proc, return, global
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1991-1993 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # @(#) proc.test 1.18 94/12/17 16:20:19
  14.  
  15. if {[string compare test [info procs test]] == 1} then {source defs}
  16.  
  17. proc tproc {} {return a; return b}
  18. test proc-1.1 {simple procedure call and return} {tproc} a
  19. proc tproc x {
  20.     set x [expr $x+1]
  21.     return $x
  22. }
  23. test proc-1.2 {simple procedure call and return} {tproc 2} 3
  24. test proc-1.3 {simple procedure call and return} {
  25.     proc tproc {} {return foo}
  26. } {}
  27. test proc-1.4 {simple procedure call and return} {
  28.     proc tproc {} {return}
  29.     tproc
  30. } {}
  31.  
  32. test proc-2.1 {local and global variables} {
  33.     proc tproc x {
  34.     set x [expr $x+1]
  35.     return $x
  36.     }
  37.     set x 42
  38.     list [tproc 6] $x
  39. } {7 42}
  40. test proc-2.2 {local and global variables} {
  41.     proc tproc x {
  42.     set y [expr $x+1]
  43.     return $y
  44.     }
  45.     set y 18
  46.     list [tproc 6] $y
  47. } {7 18}
  48. test proc-2.3 {local and global variables} {
  49.     proc tproc x {
  50.     global y
  51.     set y [expr $x+1]
  52.     return $y
  53.     }
  54.     set y 189
  55.     list [tproc 6] $y
  56. } {7 7}
  57. test proc-2.4 {local and global variables} {
  58.     proc tproc x {
  59.     global y
  60.     return [expr $x+$y]
  61.     }
  62.     set y 189
  63.     list [tproc 6] $y
  64. } {195 189}
  65. catch {unset _undefined_}
  66. test proc-2.5 {local and global variables} {
  67.     proc tproc x {
  68.     global _undefined_
  69.     return $_undefined_
  70.     }
  71.     list [catch {tproc xxx} msg] $msg
  72. } {1 {can't read "_undefined_": no such variable}}
  73. test proc-2.6 {local and global variables} {
  74.     set a 114
  75.     set b 115
  76.     global a b
  77.     list $a $b
  78. } {114 115}
  79.  
  80. proc do {cmd} {eval $cmd}
  81. test proc-3.1 {local and global arrays} {
  82.     catch {unset a}
  83.     set a(0) 22
  84.     list [catch {do {global a; set a(0)}} msg] $msg
  85. } {0 22}
  86. test proc-3.2 {local and global arrays} {
  87.     catch {unset a}
  88.     set a(x) 22
  89.     list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
  90. } {0 newValue newValue}
  91. test proc-3.3 {local and global arrays} {
  92.     catch {unset a}
  93.     set a(x) 22
  94.     set a(y) 33
  95.     list [catch {do {global a; unset a(y)}; array names a} msg] $msg
  96. } {0 x}
  97. test proc-3.4 {local and global arrays} {
  98.     catch {unset a}
  99.     set a(x) 22
  100.     set a(y) 33
  101.     list [catch {do {global a; unset a; info exists a}} msg] $msg \
  102.         [info exists a]
  103. } {0 0 0}
  104. test proc-3.5 {local and global arrays} {
  105.     catch {unset a}
  106.     set a(x) 22
  107.     set a(y) 33
  108.     list [catch {do {global a; unset a(y); array names a}} msg] $msg
  109. } {0 x}
  110. catch {unset a}
  111. test proc-3.6 {local and global arrays} {
  112.     catch {unset a}
  113.     set a(x) 22
  114.     set a(y) 33
  115.     do {global a; do {global a; unset a}; set a(z) 22}
  116.     list [catch {array names a} msg] $msg
  117. } {0 z}
  118. test proc-3.7 {local and global arrays} {
  119.     proc t1 {args} {global info; set info 1}
  120.     catch {unset a}
  121.     set info {}
  122.     do {global a; trace var a(1) w t1}
  123.     set a(1) 44
  124.     set info
  125. } 1
  126. test proc-3.8 {local and global arrays} {
  127.     proc t1 {args} {global info; set info 1}
  128.     catch {unset a}
  129.     trace var a(1) w t1
  130.     set info {}
  131.     do {global a; trace vdelete a(1) w t1}
  132.     set a(1) 44
  133.     set info
  134. } {}
  135. test proc-3.9 {local and global arrays} {
  136.     proc t1 {args} {global info; set info 1}
  137.     catch {unset a}
  138.     trace var a(1) w t1
  139.     do {global a; trace vinfo a(1)}
  140. } {{w t1}}
  141. catch {unset a}
  142.  
  143. test proc-3.1 {arguments and defaults} {
  144.     proc tproc {x y z} {
  145.     return [list $x $y $z]
  146.     }
  147.     tproc 11 12 13
  148. } {11 12 13}
  149. test proc-3.2 {arguments and defaults} {
  150.     proc tproc {x y z} {
  151.     return [list $x $y $z]
  152.     }
  153.     list [catch {tproc 11 12} msg] $msg
  154. } {1 {no value given for parameter "z" to "tproc"}}
  155. test proc-3.3 {arguments and defaults} {
  156.     proc tproc {x y z} {
  157.     return [list $x $y $z]
  158.     }
  159.     list [catch {tproc 11 12 13 14} msg] $msg
  160. } {1 {called "tproc" with too many arguments}}
  161. test proc-3.4 {arguments and defaults} {
  162.     proc tproc {x {y y-default} {z z-default}} {
  163.     return [list $x $y $z]
  164.     }
  165.     tproc 11 12 13
  166. } {11 12 13}
  167. test proc-3.5 {arguments and defaults} {
  168.     proc tproc {x {y y-default} {z z-default}} {
  169.     return [list $x $y $z]
  170.     }
  171.     tproc 11 12
  172. } {11 12 z-default}
  173. test proc-3.6 {arguments and defaults} {
  174.     proc tproc {x {y y-default} {z z-default}} {
  175.     return [list $x $y $z]
  176.     }
  177.     tproc 11
  178. } {11 y-default z-default}
  179. test proc-3.7 {arguments and defaults} {
  180.     proc tproc {x {y y-default} {z z-default}} {
  181.     return [list $x $y $z]
  182.     }
  183.     list [catch {tproc} msg] $msg
  184. } {1 {no value given for parameter "x" to "tproc"}}
  185. test proc-3.8 {arguments and defaults} {
  186.     list [catch {
  187.     proc tproc {x {y y-default} z} {
  188.         return [list $x $y $z]
  189.     }
  190.     tproc 2 3
  191.     } msg] $msg
  192. } {1 {no value given for parameter "z" to "tproc"}}
  193. test proc-3.9 {arguments and defaults} {
  194.     proc tproc {x {y y-default} args} {
  195.     return [list $x $y $args]
  196.     }
  197.     tproc 2 3 4 5
  198. } {2 3 {4 5}}
  199. test proc-3.10 {arguments and defaults} {
  200.     proc tproc {x {y y-default} args} {
  201.     return [list $x $y $args]
  202.     }
  203.     tproc 2 3
  204. } {2 3 {}}
  205. test proc-3.11 {arguments and defaults} {
  206.     proc tproc {x {y y-default} args} {
  207.     return [list $x $y $args]
  208.     }
  209.     tproc 2
  210. } {2 y-default {}}
  211. test proc-3.12 {arguments and defaults} {
  212.     proc tproc {x {y y-default} args} {
  213.     return [list $x $y $args]
  214.     }
  215.     list [catch {tproc} msg] $msg
  216. } {1 {no value given for parameter "x" to "tproc"}}
  217.  
  218. test proc-4.1 {variable numbers of arguments} {
  219.     proc tproc args {return $args}
  220.     tproc
  221. } {}
  222. test proc-4.2 {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-4.3 {variable numbers of arguments} {
  227.     proc tproc args {return $args}
  228.     tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
  229. } {1 {2 3} {4 {5 6} {{{7}}}} 8}
  230. test proc-4.4 {variable numbers of arguments} {
  231.     proc tproc {x y args} {return $args}
  232.     tproc 1 2 3 4 5 6 7
  233. } {3 4 5 6 7}
  234. test proc-4.5 {variable numbers of arguments} {
  235.     proc tproc {x y args} {return $args}
  236.     tproc 1 2
  237. } {}
  238. test proc-4.6 {variable numbers of arguments} {
  239.     proc tproc {x missing args} {return $args}
  240.     list [catch {tproc 1} msg] $msg
  241. } {1 {no value given for parameter "missing" to "tproc"}}
  242.  
  243. test proc-5.1 {error conditions} {
  244.     list [catch {proc} msg] $msg
  245. } {1 {wrong # args: should be "proc name args body"}}
  246. test proc-5.2 {error conditions} {
  247.     list [catch {proc tproc b} msg] $msg
  248. } {1 {wrong # args: should be "proc name args body"}}
  249. test proc-5.3 {error conditions} {
  250.     list [catch {proc tproc b c d e} msg] $msg
  251. } {1 {wrong # args: should be "proc name args body"}}
  252. test proc-5.4 {error conditions} {
  253.     list [catch {proc tproc \{xyz {return foo}} msg] $msg
  254. } {1 {unmatched open brace in list}}
  255. test proc-5.5 {error conditions} {
  256.     list [catch {proc tproc {{} y} {return foo}} msg] $msg
  257. } {1 {procedure "tproc" has argument with no name}}
  258. test proc-5.6 {error conditions} {
  259.     list [catch {proc tproc {{} y} {return foo}} msg] $msg
  260. } {1 {procedure "tproc" has argument with no name}}
  261. test proc-5.7 {error conditions} {
  262.     list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
  263. } {1 {too many fields in argument specifier "x 1 2"}}
  264. test proc-5.8 {error conditions} {
  265.     catch {return}
  266. } 2
  267. test proc-5.9 {error conditions} {
  268.     list [catch {global} msg] $msg
  269. } {1 {wrong # args: should be "global varName ?varName ...?"}}
  270. proc tproc {} {
  271.     set a 22
  272.     global a
  273. }
  274. test proc-5.10 {error conditions} {
  275.     list [catch {tproc} msg] $msg
  276. } {1 {variable "a" already exists}}
  277. test proc-5.11 {error conditions} {
  278.     catch {rename tproc {}}
  279.     catch {
  280.     proc tproc {x {} z} {return foo}
  281.     }
  282.     list [catch {tproc 1} msg] $msg
  283. } {1 {invalid command name "tproc"}}
  284. test proc-5.12 {error conditions} {
  285.     proc tproc {} {
  286.     set a 22
  287.     error "error in procedure"
  288.     return
  289.     }
  290.     list [catch tproc msg] $msg
  291. } {1 {error in procedure}}
  292. test proc-5.13 {error conditions} {
  293.     proc tproc {} {
  294.     set a 22
  295.     error "error in procedure"
  296.     return
  297.     }
  298.     catch tproc msg
  299.     set errorInfo
  300. } {error in procedure
  301.     while executing
  302. "error "error in procedure""
  303.     (procedure "tproc" line 3)
  304.     invoked from within
  305. "tproc"}
  306. test proc-5.14 {error conditions} {
  307.     proc tproc {} {
  308.     set a 22
  309.     break
  310.     return
  311.     }
  312.     catch tproc msg
  313.     set errorInfo
  314. } {invoked "break" outside of a loop
  315.     while executing
  316. "tproc"}
  317. test proc-5.15 {error conditions} {
  318.     proc tproc {} {
  319.     set a 22
  320.     continue
  321.     return
  322.     }
  323.     catch tproc msg
  324.     set errorInfo
  325. } {invoked "continue" outside of a loop
  326.     while executing
  327. "tproc"}
  328. test proc-5.16 {error conditions} {
  329.     proc foo args {
  330.     global fooMsg
  331.     set fooMsg "foo was called: $args"
  332.     }
  333.     proc tproc {} {
  334.     set x 44
  335.     trace var x u foo
  336.     while {$x < 100} {
  337.         error "Nested error"
  338.     }
  339.     }
  340.     set fooMsg "foo not called"
  341.     list [catch tproc msg] $msg $errorInfo $fooMsg
  342. } {1 {Nested error} {Nested error
  343.     while executing
  344. "error "Nested error""
  345.     ("while" body line 2)
  346.     invoked from within
  347. "while {$x < 100} {
  348.         error "Nested error"
  349.     }"
  350.     (procedure "tproc" line 4)
  351.     invoked from within
  352. "tproc"} {foo was called: x {} u}}
  353.  
  354. # The tests below will really only be useful when run under Purify or
  355. # some other system that can detect accesses to freed memory...
  356.  
  357. test proc-6.1 {procedure that redefines itself} {
  358.     proc tproc {} {
  359.     proc tproc {} {
  360.         return 44
  361.     }
  362.     return 45
  363.     }
  364.     tproc
  365. } 45
  366. test proc-6.2 {procedure that deletes itself} {
  367.     proc tproc {} {
  368.     rename tproc {}
  369.     return 45
  370.     }
  371.     tproc
  372. } 45
  373.  
  374. proc tproc code {
  375.     return -code $code abc
  376. }
  377. test proc-7.1 {return with special completion code} {
  378.     list [catch {tproc ok} msg] $msg
  379. } {0 abc}
  380. test proc-7.2 {return with special completion code} {
  381.     list [catch {tproc error} msg] $msg $errorInfo $errorCode
  382. } {1 abc {abc
  383.     while executing
  384. "tproc error"} NONE}
  385. test proc-7.3 {return with special completion code} {
  386.     list [catch {tproc return} msg] $msg
  387. } {2 abc}
  388. test proc-7.4 {return with special completion code} {
  389.     list [catch {tproc break} msg] $msg
  390. } {3 abc}
  391. test proc-7.5 {return with special completion code} {
  392.     list [catch {tproc continue} msg] $msg
  393. } {4 abc}
  394. test proc-7.6 {return with special completion code} {
  395.     list [catch {tproc -14} msg] $msg
  396. } {-14 abc}
  397. test proc-7.7 {return with special completion code} {
  398.     list [catch {tproc gorp} msg] $msg
  399. } {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
  400. test proc-7.8 {return with special completion code} {
  401.     list [catch {tproc 10b} msg] $msg
  402. } {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
  403. test proc-7.9 {return with special completion code} {
  404.     proc tproc2 {} {
  405.     tproc return
  406.     }
  407.     list [catch tproc2 msg] $msg
  408. } {0 abc}
  409. test proc-7.10 {return with special completion code} {
  410.     proc tproc2 {} {
  411.     return -code error
  412.     }
  413.     list [catch tproc2 msg] $msg
  414. } {1 {}}
  415. test proc-7.11 {return with special completion code} {
  416.     proc tproc2 {} {
  417.     global errorCode errorInfo
  418.     catch {open _bad_file_name r} msg
  419.     return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
  420.     }
  421.     string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  422. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  423.     while executing
  424. "open _bad_file_name r"
  425.     invoked from within
  426. "tproc2"} {posix enoent {no such file or directory}}}
  427. test proc-7.12 {return with special completion code} {
  428.     proc tproc2 {} {
  429.     global errorCode errorInfo
  430.     catch {open _bad_file_name r} msg
  431.     return -code error -errorcode $errorCode $msg
  432.     }
  433.     string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  434. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  435.     while executing
  436. "tproc2"} {posix enoent {no such file or directory}}}
  437. test proc-7.13 {return with special completion code} {
  438.     proc tproc2 {} {
  439.     global errorCode errorInfo
  440.     catch {open _bad_file_name r} msg
  441.     return -code error -errorinfo $errorInfo $msg
  442.     }
  443.     string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  444. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  445.     while executing
  446. "open _bad_file_name r"
  447.     invoked from within
  448. "tproc2"} none}
  449. test proc-7.14 {return with special completion code} {
  450.     proc tproc2 {} {
  451.     global errorCode errorInfo
  452.     catch {open _bad_file_name r} msg
  453.     return -code error $msg
  454.     }
  455.     string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  456. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  457.     while executing
  458. "tproc2"} none}
  459. test proc-7.14 {return with special completion code} {
  460.     list [catch {return -badOption foo message} msg] $msg
  461. } {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}}
  462.