proc Pi {} {return 3.14159}but in Postscript, and this current take at RPN, it looks more minimal, and less procedural:/Pi 3.14159 defSo on a sunny Sunday afternoon (and the following rainy weekend), iPaq in hand, I concocted the following implementation - less minimal than Minimal RPN, but closer to the real thing. The rpn command walks over its arguments, and pushes them on the stack if they are not known commands (or "quoted" with a /, like in Postscript - to define something named /x just call it //x the first time), else it invokes the command, which typically pops its argument(s) from the stack, and pushes its result. As a gateway to the underlying language, if the first argument is "tcl", the rest are evalled in Tcl - somehow you have to bootstrap the functionality. The stack is a global list ::S, top at end, the dictionary a global array ::cmd, which maps command names to their RPN body. You can define commands like this:
rpn /square {dup *} defwhich, when executed, duplicates the top of stack, pops the two top elements and pushes their multiplication result. Somehow like proc square {x} {expr $x*$x}but without having to make up a variable name x. Most expr operators and functions have been exposed as RPN commands, hence unifying the Polish Tcl and the infix expr into Reverse Polish.Unlike Forth, more like Postscript or Joy, you can push arbitrarily large chunks of data on the stack at one time. This allows doing away with awkward lookahead, as in Forth(cond) if (thencmds) else (elsecmds) endif : (cmdname) (cmdbody) ;in favor of the Postscript-like
(cond) {thencmds} {elsecmds} if
/(cmdname) {cmdbody} defThe language developed herein is a mix of Forth, Postscript and Joy (with much reuse of Tcl functionality, especially with lists), so I just give it the generic name rpn. After setting up timing, let's start with the central proc: } set t0 [clock clicks]
proc timed args {
puts $args:[expr {[clock clicks]-$::t0}]
set ::t0 [clock clicks]
}
proc rpn args {
if {$::cmd(debug)} {puts stdout ---[info level 0]}
if {[llength $args]==1} {set args [lindex $args 0]}
if {[lindex $args 0] eq "tcl"} {
eval [lindex $args 1]
} else {
foreach word $args {
if {$::cmd(debug)} {puts $::S}
if {[regexp ^/(.+) $word -> word]} {
push $word ;# "/" quoting
} elseif [info ex ::cmd($word)] {
rpn $::cmd($word)
} else {push $word}
}
}
lindex $::S end ;#return top(stack)
}
#----------- Stack routines:
interp alias {} push {} lappend ::S
proc pop {} {
global S
if {![llength $S]} {error underflow}
K [lindex $S end] [set S [lrange $S 0 end-1]]
}
proc K {a b} {set a}
#-- Boolean selectors", see [If we had no if]
proc 0 {then else} {rpn $else}
proc 1 {then else} {rpn $then}
#-- stack reverters
proc swap {} {push [pop] [pop]}
proc 3sw {} {push [pop] [pop] [pop]}
proc 4sw {} {push [pop] [pop] [pop] [pop]}A base set of command words is implemented in Tcl. For the first time I could make good use of multiple bracketed commands, as in [swap;pop]: array unset ::cmd
array set ::cmd {
.s {tcl {puts $::S}}
$ {tcl {push $::cmd([pop])}}
debug 0
def {tcl {set ::cmd([swap;pop]) [pop]}}
drop {tcl pop}
dup {tcl {push [lindex $::S end]}}
filter {tcl {set cond [pop]
set res {}
foreach i [pop] {
push $i
if [rpn $cond;pop] {lappend res $i}
}
push $res}
}
for {tcl {set body [pop]
set max [pop]; set inc [pop]
for {set i [pop]} {$i<=$max} {incr i $inc} {
push $i; rpn $body
}
}}
lappend {tcl {push [concat [swap;pop] [list [pop]]]}}
map {tcl {set body [pop]
set res {}
foreach i [pop] {
push $i
lappend res [rpn $body;pop]
}
push $res
}}
pick {tcl {set i end-[expr {[pop]-1}]
push [lindex $::S $i]}}
primrec {tcl {set op [pop]
set b0 [pop]; set x [pop]
if {$x>0} {
push $x [incr x -1] $b0 $op
rpn primrec $op
} else { rpn $b0 }}}
roll {tcl {global S
set i end-[expr {[pop]-1}]
push [K [lindex $S $i] [set S [lreplace $S $i $i]]]}}
sp@ {tcl {push [llength $::S]}}
swap {tcl swap}
#while {tcl {set b [pop];set e [pop]
while {[pop]} {rpn $b; rpn $e}}}
}
#--------- expr binary operators:
foreach op {+ - * / % > >= == != <= < && ||} {
set ::cmd($op) [string map "@ $op" {tcl {push [expr {[swap;pop]@[pop]}]}}]
}
#--------- expr one-arg functions
foreach f {acos asin atan ceil cos cosh exp floor log log10
sin sinh sqrt tan tanh abs double int round srand} {
set ::cmd($f) [string map "@ $f" {tcl {push [expr @([pop])]}}]
}
#----- rpn "library functions":
rpn {
/# /drop def {for comments} #Tcl commands can be invoked generically, but the "arity" (number of arguments) must be specified: #
/tcl0 {tcl {push [[pop]]}} def
/tcl1 {tcl {push [[pop] [pop]]}} def
/tcl2 {tcl {push [[pop] [swap;pop] [pop]]}} def
/tcl3 {tcl {push [[pop] [3sw;pop] [pop] [pop]]}} def
/tcl4 {tcl {push [[pop] [4sw;pop] [pop] [pop] [pop]]}} def
/. {putc " " putc} def{Range generator, 1 3 ..-> {1 2 3}} # /.. {{} 3 roll 1 4 roll /lappend for} def
/and //&& def
{delete stack until given mark} #
/clear {dup rot == sp@ 2 < or {} /clear if} def
/close {//close tcl1} def
/concat {//concat tcl2} def
/cons {swap swons} def
/emit {%c swap /format tcl2 putc} def
/eval {//rpn tcl1 drop} def
/even {odd not} def
/expr {//expr tcl1} def
/fac2 {1 2 1 4 roll /* for} def
/first {1 nth} def
/if {rot 0 != tcl2 drop} def
/incr {swap dup $ 3 roll + def} def
/join {//join tcl2} def
/length {//llength tcl1} def
/nth {1 - /lindex tcl2} def
/not {0 ==} def
/lrange {//lrange tcl3} def
/odd {2 %} def
/open {//open tcl1} def
/or //|| def
/over {2 pick} def
/putc {-nonewline swap /puts tcl2 drop} def
/rand {rand() expr} def
/read {//read tcl1} def
/readfile {open dup read swap close drop} def
/rest {1 end lrange} def
/rot {3 roll} def
/sgn {dup 0 > swap 0 < -} def
/sq {dup *} def
/sum {//+ join expr} def
/swons {0 swap /linsert tcl3} def
/uncons {dup first swap rest} def
/unswons {dup rest swap first} def
}Factorial is recursively defined (I'm not sure whether that was possible in Forth):
rpn /fac {dup 2 < {drop 1} {dup 1 - fac *} if} def
#-- ...or in Joy style:
rpn /fac2 {1 /* primrec} def#--- Average of a list of numbers: rpn /avg {dup sum swap length double /} def# Celsius centigrades <> Fahrenheit: rpn /c2f {9 * 5 / 32 +} def
rpn /f2c {32 - 5 * 9 /} defif 0 {The following debugging helpers proved useful on the iPaq, where less typing is better:} set thisfile [info script]
proc s {} {
if [catch {uplevel #0 source $::thisfile}] {set ::errorInfo}
}
proc c name {set ::cmd($name)}
proc .s {} {K "" [rpn .s]}
proc cs {} {set ::S {}} ;# clear stack#---------------- Test suite (usage examples), now also with stack leak control: proc must {cmd exp} {
catch [list uplevel 1 $cmd] res
if {$res ne $exp} {
error "$cmd -> $res, expected $exp"
}
pop ;# don't let the stack leak
if [llength $::S] {error "$cmd leaked $::S"}
#timed $cmd->$res
}
timed definitions
cs
must {rpn 1 2 +} 3
must {rpn 1 2 -} -1
must {rpn 1.4 int} 1
must {rpn 1 0 > yes no if} yes
must {rpn 1 0 < yes no if} no
must {rpn 5 sq} 25
must {rpn 42 sgn} 1
must {rpn -42 sgn} -1
must {rpn 0 sgn} 0
must {rpn 4 fac} 24
must {rpn 6 fac2} 720
must {rpn {1 2 3} length} 3
must {rpn {1 2 3} sum} 6
must {rpn {1 2 3 4} avg} 2.5
must {rpn 0 c2f} 32
must {rpn 100 c2f} 212
must {rpn 212 f2c} 100
must {rpn {a b} c lappend} {a b c}
must {rpn {a b c} 2 nth} b
#-- "must" pops one result; more must be popped manually for leak control
must {K [rpn a b c 3 roll] [pop;pop]} a
must {K [rpn x y z over] [pop;pop;pop]} y
must {rpn 3+4 expr} 7
must {rpn {5 6 +} eval} 11
must {rpn {1 2 3} /sq map} {1 4 9}
must {rpn {1 2 3 4} /odd filter} {1 3}
must {rpn {1 2 3 4} {2 %} filter} {1 3}
must {rpn -- /i 22 def} --
must {rpn /i $} 22
must {rpn /i 3 incr i} 25
must {rpn /sq $} {dup *} ;#info body
must {rpn {a b c d} 1 2 lrange} {b c}
must {rpn {2 3 4} /sum eval} 9
must {rpn 1 5 ..} {1 2 3 4 5}
must {rpn 5 1 /* primrec} 120
must {rpn {a b} {c d} concat} {a b c d}
must {rpn 42 even} 1
must {rpn {a b c} first} a
must {rpn {a b c} rest} {b c}
must {rpn a {b c} cons} {a b c}
must {rpn {b c} a swons} {a b c}
must {rpn {1 2 3} uncons cons} {1 2 3}
must {rpn {1 2 3} unswons swons} {1 2 3}
.s
timed testsRS A year later, re-reading papers on Joy, a remake was needed - see Pocket Joy 2005
