if 0 {[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} if 0 { ---- [Arts and crafts of Tcl-Tk programming] }