proc r args {
    foreach a $args {
      dputs [info level]:$::S//$a
      if {$a eq "tcl"} {
              eval [pop]
      } elseif [info exists ::C($a)] {
              eval r $::C($a)
      } else {push [string trim $a ()]}
    }
    set ::S 
 }
# That's it. Stack (list) and Command array are global variables:
 set S {}; unset C
#-- A tiny switchable debugger:
 proc d+ {} {proc dputs s {puts $s}}
 proc d- {}  {proc dputs args {}}
 d- ;#-- initially, debug mode off
if 0 {Definitions are in Forth style, as they look much more compact than Joy's
 DEFINE n == args;
}
 proc : {n args} {set ::C($n) $args}
if 0 {[expr] functionality is exposed for binary operators and one-arg functions:}
 proc 2op op {
    set t [pop]
    push [expr {[pop]} $op {$t}]
 }
 foreach op {+ - * / > >= != <= <} {: $op [list 2op $op] tcl}
 : =    {2op ==} tcl

 proc 1f  f {push [expr $f ([pop])]}
 foreach f {abs double exp int sqrt sin cos acos tan} {: $f [list 1f $f] tcl}

 interp alias {} pn {} puts -nonewline

#----- The '''dictionary''' has all one-liners:
 : .      {pn "[pop] "} tcl
 : .s    {puts $::S} tcl
 : '      {push [scan [pop] %c]} tcl   ;# char -> int
 : `     {push [format %c [pop]]} tcl  ;# int -> char
 : and  {2op &&} tcl
 : at     1 - swap {push [lindex [pop] [pop]]} tcl
 : c      {set ::S {}} tcl ;# clear stack
 : choice {choice [pop] [pop] [pop]} tcl
 : cleave {cleave [pop] [pop] [pop]} tcl
 : cons {push [linsert [pop] 0 [pop]]} tcl
 : dup  {push [set x [pop]] $x} tcl
 : dupd {push [lindex $::S end-1]} tcl
 : emit {pn [format %c [pop]]} tcl
 : even  odd not
 : explode  {push [split [pop] ""]} tcl  ;# string -> char list
 : fact  1 (*) primrec
 : filter  split swap pop
 : first  {push [lindex [pop] 0]} tcl
 : fold  {rfold [pop] [pop] [pop]} tcl
 : gcd  swap {0 >} {swap dupd rem swap gcd} (pop) ifte
 : has  swap in
 : i      {eval r [pop]} tcl
 : ifte   {rifte [pop] [pop] [pop]} tcl
 : implode  {push [join [pop] ""]} tcl ;# char list -> string
 : in  {push [lsearch [pop] [pop]]} tcl 0 >=
 : map  {rmap [pop] [pop]} tcl
 : max  {push [max [pop] [pop]]} tcl
 : min  {push [min [pop] [pop]]} tcl
 : newstack  c
 : not   {1f !} tcl
 : odd  2 rem
 : of  swap at
 : or    {2op ||} tcl
 : pop  (pop) tcl
 : pred 1 -
 : primrec {primrec [pop] [pop] [pop]} tcl
 : product 1 (*) fold
 : qsort (lsort) tcl
 : qsort1 {lsort -index 0} tcl
 : rem  {2op %} tcl
 : rest  {push [lrange [pop] 1 end]} tcl
 : reverse {} swap (swons) step
 : set  {set ::[pop] [pop]} tcl
 : $     {push [set ::[pop]]} tcl
 : sign  {0 >}  {0 <} cleave -
 : size  {push [llength [pop]]} tcl
 : split  {rsplit [pop] [pop]} tcl
 : step  {step [pop] [pop]} tcl
 : succ  1 +
 : sum   0 (+) fold
 : swap  {push [pop] [pop]} tcl
 : swons  swap cons
 : xor  !=

if 0 {Helper functions written in Tcl:}
 proc rifte {else then cond} {
    eval r dup $cond
    eval r [expr {[pop]? $then: $else}]
 }
 proc choice {z y x} {
    push [expr {$x? $y: $z}]
 }
 proc cleave { g f x} {
    eval [list r $x] $f [list $x] $g
 }
 proc max {x y} {expr {$x>$y?$x:$y}}
 proc min {x y} {expr {$x<$y? $x:$y}}
 proc rmap {f list} {
    set res {}
    foreach e $list {
       eval [list r $e] $f
       lappend res [pop]
    }
    push $res
 }
 proc step {f list} {
    foreach e $list {eval [list r ($e)] $f}
 }
 proc rsplit {f list} {
    foreach i {0 1} {set $i {}}
    foreach e $list {
       eval [list r $e] $f
       lappend [expr {!![pop]}] $e
    }
    push $0 $1
 }
 proc primrec {f init n} {
    if {$n>0} {
       push $n
       while {$n>1} {
           eval [list r [incr n -1]] $f
       }
    } else {push $init}
 }
 proc rfold {f init list} {
    push $init
    foreach e $list {eval [list r $e] $f}    
 }
#------------------ Stack routines
 proc push args {
   foreach a $args {lappend ::S $a}
 }
 proc pop {} {
    if [llength $::S] {
       K [lindex $::S end] [set ::S [lrange $::S 0 end-1]]
    } else {error "stack underflow"}
 }
 proc K {a b} {set a}
#------------------------ The test suite:
 proc ? {cmd expected} {
    catch {uplevel 1 $cmd} res
    if {$res ne $expected} {puts "$cmd->$res, not $expected"}
 }
 ? {r 2 3 +} 5
 ? {r 2 *}   10
 ? {r c 5 dup *} 25
 : sqr dup *
 : hypot sqr swap sqr + sqrt
 ? {r c 3 4 hypot} 5.0
 ? {r c {1 2 3} {dup *} map} {{1 4 9}}
 ? {r size} 3
 ? {r c {2 5 3} 0 (+) fold} 10
 ? {r c {3 4 5} product} 60
 ? {r c {2 5 3} 0 {dup * +} fold} 38
 ? {r c {1 2 3 4} dup sum swap size double /} 2.5
 ? {r c {1 2 3 4} (sum)  {size double} cleave /} 2.5
 : if0 {1000 >} {2 /} {3 *} ifte
 ? {r c 1200 if0} 600
 ? {r c 600 if0}  1800
 ? {r c 42 sign}   1
 ? {r c 0 sign}     0
 ? {r c -42 sign} -1
 ? {r c 5 fact} 120
 ? {r c 1 0 and} 0
 ? {r c 1 0 or}   1
 ? {r c 1 0 and not} 1
 ? {r c 3 {2 1} cons} {{3 2 1}}
 ? {r c {2 1} 3 swons} {{3 2 1}}
 ? {r c {1 2 3} first} 1
 ? {r c {1 2 3} rest} {{2 3}}
 ? {r c {6 1 5 2 4 3} {3 >} filter} {{6 5 4}}
 ? {r c 1 2 {+ 20 * 10 4 -} i} {60 6}
 ? {r c 42 succ} 43
 ? {r c 42 pred} 41
 ? {r c {a b c d} 2 at} b
 ? {r c 2 {a b c d} of} b
 ? {r c 1 2 pop} 1
 ? {r c A ' 32 + succ succ `} c
 ? {r c {a b c d} reverse} {{d c b a}}
 ? {r c 1 2 dupd} {1 2 1}
 ? {r c 6 9 gcd} 3
 ? {r c true yes no choice} yes
 ? {r c false yes no choice} no
 ? {r c {1 2 3 4} (odd) split} {{2 4} {1 3}}
 ? {r c a {a b c} in} 1
 ? {r c d {a b c} in} 0
 ? {r c {a b c} b has} 1
 ? {r c {a b c} e has} 0
 ? {r c 3 4 max} 4
 ? {r c 3 4 min}  3
 ? {r c hello explode reverse implode} olleh
 : palindrome dup explode reverse implode =
 ? {r c hello palindrome} 0
 ? {r c otto palindrome}  1
#-- reading (varname $) and setting (varname set) global Tcl vars
 set tv 42
 ? {r c (tv) $ 1 + dup (tv) set} 43
 ? {expr $tv==43} 1

#-- Little dev. helper on the iPaq - short to type, tells the time
 interp alias {} s {} time {source rpn.txt}