Updated 2012-05-15 10:54:25 by RLE

Richard Suchenwirth 2005-05-07 - Every year or so, I happen to read literature on Forth and Joy, and my fingers soon itch to do RPN in Tcl - see Minimal RPN, Playing Joy and RPN again for earlier takes. Here's the 2005 vintage.

Striving for minimality, the "runtime engine" is now just called "r" (not to be confused with the R language), and it boils down to a three-way switch done for each word:

  • "tcl" evaluates the top of stack as a Tcl script
  • known words in the ::C array are recursively evaluated in "r"
  • other words are just pushed

Joy's rich quoting for types ([list], {set}, "string", 'char) conflict with the Tcl parser, so lists in "r" are {braced} if their length isn't 1, and (parenthesized) if it is - but the word shall not be evaluated now. This looks better to me than /slashing as in Postscript, and RPN again.

As everything is a string, and to Tcl "a" is {a} is a , Joy's polymorphy has to be made explicit. I added converters between characters and integers, and between strings and lists (see the dictionary below). For Joy's sets I haven't bothered yet - they are restricted to the domain 0..31, probably implemented with bits in a 32-bit word.

Far as this is from Joy, it was mostly triggered by the examples in Manfred von Thun's papers, so I tongue-in-cheek still call it "Pocket Joy" - it was for me, at last, on the iPaq... The test suite at end should give many examples of what one can do in "r".
 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}