- "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
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 offif 0 {Definitions are in Forth style, as they look much more compact than Joy'sDEFINE 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 }