tests/tailcall.test

   1 source [file dirname [info script]]/testing.tcl
   2 needs constraint jim
   3 needs cmd tailcall
   4 needs cmd try tclcompat
   5
   6 test tailcall-1.1 {Basic tailcall} {
   7         # Demo -- a tail-recursive factorial function
   8         proc fac {x {val 1}} {
   9                 if {$x <= 2} {
  10                         expr {$x * $val}
  11                 } else {
  12                         tailcall fac [expr {$x -1}] [expr {$x * $val}]
  13                 }
  14         }
  15         fac 10
  16 } {3628800}
  17
  18 test tailcall-1.2 {Tailcall in try} {
  19         set x 0
  20         proc a {} { upvar x x; incr x }
  21         proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
  22         b
  23         set x
  24 } {13}
  25
  26 test tailcall-1.3 {Tailcall does return} {
  27         set x 0
  28         proc a {} { upvar x x; incr x }
  29         proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
  30         b
  31         set x
  32 } {5}
  33
  34 test tailcall-1.4 {uplevel tailcall} {
  35         proc a {} { set ::y [info level] }
  36         proc b {} { set ::x [info level]; uplevel 1 tailcall a}
  37         b
  38         list $x $y
  39 } {1 1}
  40
  41 test tailcall-1.5 {interaction of uplevel and tailcall} {
  42         proc a {cmd} {
  43                 tailcall $cmd
  44         }
  45         proc b {} {
  46                 lappend result [uplevel 1 a c]
  47                 lappend result [uplevel 1 a c]
  48         }
  49         proc c {} {
  50                 return c
  51         }
  52         a b
  53 } {c c}
  54
  55 testreport