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:
Joy's rich quoting for types ([list], {set}, "string") 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. Far as this is from Joy, it was mostly triggered by Manfred von Thun's papers, so I }
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
}
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#---------- definitions in Forth style
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
: . {pn "[pop] "} tcl
: .s {puts $::S} tcl
: ' {push [scan [pop] %c]} tcl
: ` {push [format %c [pop]]} tcl
: 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
: 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
: 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 {