tests/tailcall.test

   1 # vim:se syntax=tcl:
   2
   3 source [file dirname [info script]]/testing.tcl
   4
   5 needs cmd tailcall
   6 needs cmd try tclcompat
   7
   8 test tailcall-1.1 {Basic tailcall} {
   9         # Demo -- a tail-recursive factorial function
  10         proc fac {x {val 1}} {
  11                 if {$x <= 2} {
  12                         expr {$x * $val}
  13                 } else {
  14                         tailcall fac [expr {$x -1}] [expr {$x * $val}]
  15                 }
  16         }
  17         fac 10
  18 } {3628800}
  19
  20 test tailcall-1.2 {Tailcall in try} {
  21         set x 0
  22         proc a {} { upvar x x; incr x }
  23         proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
  24         b
  25         set x
  26 } {13}
  27
  28 test tailcall-1.3 {Tailcall does return} {
  29         set x 0
  30         proc a {} { upvar x x; incr x }
  31         proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
  32         b
  33         set x
  34 } {5}
  35
  36 test tailcall-1.5 {interaction of uplevel and tailcall} {
  37         proc a {cmd} {
  38                 tailcall $cmd
  39         }
  40         proc b {} {
  41                 lappend result [uplevel 1 a c]
  42                 lappend result [uplevel 1 a c]
  43         }
  44         proc c {} {
  45                 return c
  46         }
  47         a b
  48 } {c c}
  49
  50 test tailcall-1.6 {tailcall pass through return} {
  51         proc a {script} {
  52                 # return from $script should pass through back to the caller
  53                 tailcall foreach i {1 2 3} $script
  54         }
  55         proc b {} {
  56                 a {return ok}
  57                 # Should not get here
  58                 return bad
  59         }
  60         b
  61 } {ok}
  62
  63 test tailcall-1.7 {tailcall with namespaces} jim {
  64         proc a::b {} {
  65                 proc c {} {
  66                         return 1
  67                 }
  68                 set d [local lambda {} { c }]
  69                 # $d should resolve in namespace 'a', not ""
  70                 tailcall $d
  71         }
  72         a::b
  73 } 1
  74
  75 test tailcall-1.8 {tailcall with local} jim {
  76         proc a {} {
  77                 tailcall [local proc b {} { return c }]
  78         }
  79         a
  80 } {c}
  81
  82 test tailcall-1.9 {tailcall with large number of invocations} {
  83         proc a {n} {
  84                 if {$n == 0} {
  85                         return 1
  86                 }
  87                 incr n -1
  88                 tailcall a $n
  89         }
  90         a 1000
  91 } 1
  92
  93 test tailcall-1.10 {tailcall through uplevel} {
  94         proc a {} { tailcall b }
  95         proc b {} { uplevel 1 c }
  96         proc c {} { tailcall d }
  97         proc d {} { return [info level] }
  98         a
  99 } 1
 100
 101 test tailcall-1.11 {chained tailcall} {
 102         proc a {} { b }
 103         proc b {} { tailcall tailcall c }
 104         proc c {} { return [info level] }
 105         a
 106 } 1
 107
 108 test tailcall-1.12 {uplevel tailcall} {
 109         proc a {} { b }
 110         proc b {} { uplevel 1 tailcall c }
 111         proc c {} { return [info level] }
 112         a
 113 } 1
 114
 115 testreport