After some experimentation with [Joy 2005] (thanks to [RS] :), I tried to build a minimalist RPN language that could handle vectors, matrices and binary data. It is still experimental, but I think that, when coded in C, it may address an item of [Tcl 9.0 Wishlist] for doing some math with a fast interpreted language. Then ''Tcl + C'' ([Ousterhout's Dichotomy]) may become ''Tcl + Rpn + C'', with less efforts than binding another language to Tcl. -- [Sarnold] 2006-04-21 ---- '''rpn2006.tcl''' namespace eval ::rpn { proc r args { variable S variable C variable N variable R foreach {callstack cleanup} [refactor $args rpn] {break} set check "" set callstack [list $callstack] set out "" while {[llength $callstack]} { set args [lindex $callstack end] set callyet 0 foreach a $args { set args [lrange $args 1 end] dputs [info level]:[llength $callstack]:$S\\$a set cont no switch -- $a { debug { debug [lindex $callstack end] $args } trace {puts $code} . {lappend out [pop]} .b {lappend out [to_binary]} .v {lappend out [to_vector]} .m {lappend out [to_matrix]} default {set cont yes} } if {!$cont} { if {[llength $callstack]!=1} { set out "" } continue } if {[info exists N($a)]} { eval $N($a) } elseif {[info exists C($a)]} { lset callstack end $args lappend callstack $C($a) if {$C($a,regcheck)} { lappend check [llength $R] [llength $callstack] } set callyet 1 break } else { # command name without evaluation: the string (+) # pushes + onto the stack without # performing any addition push [string trim $a ()] # example: r 2 3 (+) -> 2 3 + # r 2 3 + -> 5 # evaluating the first one with i: # r 2 3 (+) i -> 5 } } if {$callyet} {continue} if {[llength $callstack] == [lindex $check end]} { set nbreg [K [lindex $check end-1] [set check [lrange $check 0 end-2]]] if {[llength $R] != $nbreg} { return -code error -errorcode {RPN register} \ "register check failed : $nbreg expected, got [llength $R]" } } set callstack [lrange $callstack 0 end-1] } if {[llength $callstack] != 0} { return -code error -errorcode {RPN callstack} "internal error : callstack still active" } foreach cmd $cleanup { cleansub $cmd } return $out } proc defn {name args} { variable N set N($name) $args } # cleanup subcommands created from eval bodies proc cleansub {n} { variable C foreach name [array names C $n,*] { unset C($name) } catch {unset C($n)} } proc commands {{match *}} { variable C array names C $match } proc body {name} { variable C set C($name) } proc def {n args} { variable C cleansub $n set C($n) [lindex [refactor $args $n] 0] } proc interactive_debug {stack remaining} { while 1 { puts -nonewline "debug (q to leave)> " gets stdin input switch -- $input { "" { r .s .r continue } q { return } error { error "operation cancelled by the user" } trace { set msg "$stack\nremains : $remaining" } default { if {[catch {eval r $input} msg]} { puts "error in rpn expression :\n $msg\n" continue } } } if {$msg eq ""} { r .s return } puts $msg } } # That's it. Stack (list), Native and Command arrays are namespace variables variable S {} variable R {} ; # register stack variable code {} catch {array unset C} catch {array unset N} variable C variable N array set C {} array set N {} #-- A tiny switchable debugger: proc d+ {{type trace}} { switch -- $type { trace - stack {proc dputs s {puts $s}} break - breakpoint - br { proc debug {s r} {interactive_debug $s $r} } default {error "unknown debug feature"} } } proc d- {} {proc dputs args {}; proc debug 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; Here : def elt ?elt ...? or, for tcl commands : defn tclcommand ?arg ...? } # since lists are not supported, we have to refactor so that each code sequence # is replaced with a new command # # The -regcheck option tells the interpreter (not Tcl, RPN :) # to checks there are the same registers number at the end than at the beginning. # (because it is easy to get memory leaks when you don't tell that) # # 'def foo {dup *} for' is translated into: # 'def foo (foo,1) for' # 'def foo,1 dup *' proc refactor {arg name} { variable C if {[lindex $arg 0] eq "-regcheck"} { set C($name,regcheck) yes set arg [lrange $arg 1 end] } else { set C($name,regcheck) no } set out "" set created "" set nbsub 1 for {set i 0} {$i<[llength $arg]} {incr i} { set value [lindex $arg $i] if {[llength $value] > 1} { set func [lindex $arg [expr {$i+1}]] switch -- $func { vector - matrix - binary { eval lappend out [from_$func $value] incr i } default { while {[info exists C($name,$nbsub)]} { incr nbsub } set C($name,$nbsub) [lindex [refactor $value $name,$nbsub] 0] lappend out ($name,$nbsub) lappend created $name,$nbsub } } } else { lappend out $value } } return [list $out $created] } 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 {+ - * / > >= != <= <} {defn $op 2op $op} defn = 2op == defn ++ radd 1 defn -- radd -1 proc radd {increment} { push [expr {[pop]+$increment}] } proc 1f f {push [expr $f\([pop])]} foreach f {abs double exp int sqrt sin cos tan asin acos atan} {defn $f 1f $f} # stubs between the main stack and the register stack # pushes the last value into the register stack defn sto store # pop the last value from the register stack and push it defn get get # sget : get without pop; ssto : sto without pop defn ssto sstore defn sget sget defn rdrop rdrop proc store {} { variable R lappend R [pop] } proc sstore {} { variable R set var [pop] lappend R $var push $var } proc get {} { variable R push [K [lindex $R end] [set R [lrange $R 0 end-1]]] } proc rdrop {} { variable R set R [lrange $R 0 end-1] } proc sget {} { variable R push [lindex $R end] } # ------ rpn commands linked to procs defn .s putstack proc putstack {} {puts $::rpn::S} defn .r regput proc regput {} {puts $::rpn::R} defn and 2op && defn bitand 2op & defn bitcomp 1f ~ defn bitor 2op | defn bitxor 2op ^ defn c clearstack proc clearstack {} { variable S variable R set S {} set R {} } defn cleave cleave proc cleave {} { foreach {f g} [pop 2] break r vdup $f r dupd swap insert r $g } defn drop pop defn dup dup defn dupd dupd defn dupt dupt foreach {name number index} { dup 0 end dupd 1 end-1 dupt 2 end-2 } { proc $name {} [string map [list num $number end $index] { variable S Index num push [lindex $S end] }] } defn filter vfilter proc vfilter {} { foreach {len cmd} [pop 2] {break} foreach e [pop $len] { r $e $cmd if {[pop]} {push $e} {incr len -1} } push $len } defn vfold vfold proc vfold {} { foreach {size init f} [pop 3] {break} set vector [pop $size] push $init foreach e $vector { r $e $f } } # iterations : for i:=0..n do push i; f(); next i defn for rfor proc rfor {} { foreach {n f} [pop 2] {break} for {set i 0} {$i<$n} {incr i} { r $i $f } } # a foreach command : foreach defn foreach rforeach proc rforeach {} { set f [pop] foreach e [pop [pop]] { push $e r $f } } defn i i proc i {} { r [pop] } # if-then-else defn ifte rifte proc rifte {} { foreach {cond then else} [pop 3] {break} r dup $cond r [expr {[pop]? $then: $else}] } defn in in proc in {} { set l [pop [pop]] push [expr {[lsearch $l [pop]]>=0}] } defn insert rinsert proc rinsert {} { variable S foreach {pos value} [pop 2] {break} Index $pos set S [linsert $S end-[incr pos] $value] } # stack manipulation : item by item defn itemdup ritemdup defn itemgrab ritemgrab defn itemset ritemset defn itempick ritempick proc ritemdup {} { variable S set index [pop] if {$index<0} { return -code error -errorcode {RPN stack} "negative index" } Index $index push [lindex $S end-$index] } proc ritemgrab {} { set index [pop] if {$index<0} { return -code error -errorcode {RPN stack} "negative index" } set item [Index $index] variable S set S [lreplace $S end-$index end-$index] push $item } proc ritemset {} { foreach {index value} [pop 2] {break} if {$index<0} { return -code error -errorcode {RPN stack} "negative index" } Index $index variable S lset S end-$index $value } proc ritempick {} { set index [pop] if {$index<0} { return -code error -errorcode {RPN stack} "negative index" } Index $index variable S set S [lreplace $S end-$index end-$index] } defn max max defn min min proc max {} {push [expr {[set x [pop]]>[set y [pop]]?$x:$y}]} proc min {} {push [expr {[set x [pop]]<[set y [pop]]?$x:$y}]} defn vmap vmap proc vmap {} { foreach {len f} [pop 2] {break} foreach e [pop $len] { push $e r $f } push $len } defn matrow matrow defn matcol matcol proc matrow {} { set index [pop] foreach {cols len} [pop 2] {break} # the inverse routing set rows [rows $len $cols] set index [expr {$rows - $index - 1}] set start [expr {$index * $cols + 2}] set end [expr {$start + $cols - 1}] push $cols $len $end $start range push $cols } proc rows {len cols} { incr len -1 if {$len % $cols != 0} { return -code error -errorcode {RPN matrix} "rows and columns do not match" } return [expr {$len / $cols}] } proc matcol {} { set index [pop] foreach {cols len} [pop 2] {break} # the inverse routing set index [expr {$cols - 1 - $index}] set out "" for {set i 0} {$i < $len-1} {incr i $cols} { set pos [expr {$i+$index}] set out [linsert $out 0 [Index $pos]] } push $cols $len vpush $out } defn matconcat matconcat proc matconcat {} { set n [pop] set cols [pop] push $cols set out "" for {set row 0} {$row < $n} {incr row} { if {$cols != [pop]} { return -code error -errorcode {RPN matrix} "columns numbers do not match" } set out [concat [pop $cols] $out] } lappend out $cols vpush $out } defn move move proc move {} { foreach {end start} [pop 2] {break} if {$start<0} { return -code error -errorcode {RPN stack} "negative index" } elseif {$end<$start} { return -code error -errorcode {RPN stack} "range end smaller than start" } Index $end variable S foreach elt [K [lrange $S end-$end end-$start] [set S [lreplace $S end-$end end-$start]]] { lappend S $elt } } defn nop nop proc nop {} {} defn not 1f ! defn or 2op || defn pick pick proc pick {} { foreach {end start} [pop 2] {break} if {$start<0} { return -code error -errorcode {RPN stack} "negative index" } elseif {$end<$start} { return -code error -errorcode {RPN stack} "range end smaller than start" } Index $end variable S set S [lreplace $S end-$end end-$start] } defn range range proc range {} { foreach {end start} [pop 2] {break} if {$start<0} { return -code error -errorcode {RPN stack} "negative index" } elseif {$end<$start} { return -code error -errorcode {RPN stack} "range end smaller than start" } Index $end variable S foreach elt [lrange $S end-$end end-$start] { lappend S $elt } } defn rem rem proc rem {} { foreach {a b} [pop 2] {break} if {[string is integer $a] && [string is integer $b]} { push [expr {$a % $b}] return } # double do not have % operator, but fmod() function push [expr {fmod($a,$b)}] } defn reverse reverse proc reverse {} { vpush [lreverse [pop [pop]]] } proc lreverse {mylist} { set r "" foreach e $mylist {set r [concat $e $r]} set r } defn lshift 2op << defn rshift 2op >> defn split vsplit proc vsplit {} { foreach {len f} [pop 2] {break} set list [pop $len] foreach e $list { r $e $f if {[pop]} { lappend true $e } else { lappend false $e } } foreach l [list $false $true] { vpush $l } } defn swap swap proc swap {} { push [pop] [pop] } defn vswap vswap proc vswap {} { set v [pop [pop]] set x [pop] vpush $v push $x } defn vvswap vvswap proc vvswap {} { set a [pop [pop]] set b [pop [pop]] vpush $a vpush $b } # iterations : repeat $n times $f defn times times proc times {} { foreach {n f} [pop 2] {break} for {set i 0} {$i<$n} {incr i} { r $f } } defn vdup vdup proc vdup {} { set a [pop [pop]] vpush $a vpush $a } # ------ The dictionary has all one-liners: # pure-rpn commands def append swap ++ def concat dup ++ itemdup dupd + swap ++ dup pick # concatenate two vectors into a list of two vectors def sconcat dup ++ itemdup dupd + 2 + # like sconcat, but with any number of vectors... def struct {{0 =} {drop sconcat} {drop sconcat -- swap drop} ifte} for def rows dupd dupd -- swap / def cons ++ def vdrop dup 0 pick def vdup dup 0 range def vdupd dup ++ dup dup 2 + itemdup + swap range def even odd not def factorial {0 !=} {-- dup ++ dup -- {dupd * swap -- swap} times swap drop} (++) ifte def first dup itemdup swap {swap drop} times def gcd swap {0 >} {swap dupd rem swap gcd} (drop) ifte def has -vswap in # matrix index : $row $col matindex def matindex swap 3 itemdup * + dupd swap - itemdup def matrix.colrange_asrows -regcheck dupd ssto - ++ ssto swap drop rswap {sget + matcol vvswap} for rdrop vdrop get matconcat def matrix.rowrange -regcheck dupd ssto - ++ ssto swap drop rswap {sget + matrow vvswap} for rdrop vdrop get matconcat def matrix.rowcolrange -regcheck sto sto matrix.rowrange get get matrix.colrange def matrix.colrange matrix.colrange_asrows transpose # concatenates $1 vectors on the stack to build a matrix # example : r {1 2 3} vector {4 5 6} vector 2 matconcat .m => {{1 2 3} {4 5 6}} def matmul -regcheck rows sto vvswap rows sto vvswap sconcat dupt { sto rswap sget (_vmul) for get get swap sto drop } for vdrop get get swap sto dup get * ++ # registers : rows1 rows2 index1 rows1 def _vmul rswap sto vdup drop get matcol sconcat vvswap sget matrow vvswap vdrop vvswap drop vvswap vdrop _mulsum # registers : rows1 rows2 rows1 index1 def _mulsum rswap vvmul -- (+) times dupd swap insert # rswap : swap the last two elements in the register stack def rswap get get swap sto sto def vvmul -regcheck dup ++ itempick dup sto {sget itemgrab *} foreach get def transpose dupd {matcol vvswap} for dupd -vswap vdrop matconcat def index ++ itemdup def vinsert dup dupt ++ {3 itemdup swap - 2 + itemdup swap ++ swap insert dup} for drop drop def newstack c def odd 2 rem def of swap at def product -- (*) times def rest dup dup pick -- def vroll sconcat ssto itemdup sget + get swap move def roll dupt 3 itempick def sign {0 <} {drop -1} {{0 >} i} ifte def size dup 1 pick def sum -- (+) times def -vswap dupd swap insert def xor != if 0 {Helper functions written in Tcl:} # matrix : bidimensional array defn matrix rmatrix proc rmatrix {} {eval push [from_matrix [pop]]} # vector : simple array (of doubles and ints) defn vector rvector proc rvector {} {eval push [from_vector [pop]]} # binary : binary string (char sequence) defn binary rbinary proc rbinary {} {eval push [from_binary [pop]]} # --------------- in/out tcl data proc from_vector {list} { lappend list [llength $list] return $list } proc from_matrix {list} { set out "" set rows [llength $list] set cols [llength [lindex $list 0]] foreach row $list { if {[llength $row] != $cols} { return -code error -errorcode {RPN matrix} "rows may not have different lengths" } set out [concat $out $row] } return [concat $out $cols [expr {$rows * $cols + 1}]] } proc from_binary {value} { # value is supposed to be enclosed in parentheses # to prevent an arbitrary binary string to act like a command set value [string range $value 1 end-1] binary scan $value c* charlist set out "" foreach char $charlist { lappend out [expr {($char + 0x100)%0x100}] } lappend out [llength $out] set out } proc to_vector {} { return [pop [pop]] } proc to_matrix {} { foreach {cols len} [pop 2] {break} set out "" incr len -1 set rows [expr {$len/$cols}] if {$rows * $cols != $len} { return -code error -errorcode {RPN matrix} "rows and columns numbers do not match" } for {set i 0} {$i < $rows} {incr i} { set out [linsert $out 0 [pop $cols]] } return $out } proc to_binary {} { set charlist [pop [pop]] set signed "" foreach char $charlist { # ensure it is a 'byte' set char [expr {$char & 0xff}] # convert unsigned chars to signed ones lappend signed [expr {($char & 0x80)? $char - 0x100 : $char}] } # value is supposed to be enclosed in parentheses # to prevent an arbitrary binary string to act like a command return [binary format c* $signed] } #------------------ Stack routines proc push args { variable S foreach a $args {lappend S $a} } proc pop {{len 1}} { if {$len>1} { return [npop $len] } Index 0 variable S K [lindex $S end] [set S [lrange $S 0 end-1]] } proc K {a b} {set a} proc npop {len} { if {$len<2} { return -code error -errorcode {RPN stack} "vectors must have at least 2 elements" } Index [incr len -1] variable S K [lrange $S end-$len end] [set S [lreplace $S end-$len end]] } proc vpush {mylist} { set l [llength $mylist] foreach e $mylist { push $e } push $l } # get the end-index position in the stack proc Index {pos} { variable S if {[llength $S] <= $pos} { return -code error -errorcode {RPN stack} "stack underflow" } return [lindex $S end-$pos] } # ------------------------------ public procs namespace export r def d+ d- } #------------------------ The test suite: namespace import ::rpn::* proc ? {cmd expected} { if {[catch {uplevel 1 [string map [list CMD $cmd] { CMD }] } res]} { puts "$cmd->$res, not $expected" } if {[llength $res] == 0} { set res $::rpn::S } if {$res ne $expected} {puts "$cmd->$res, not $expected"} } def at dupd swap - ++ itemdup -vswap vdrop def of vswap at def sqr dup * def hypot sqr swap sqr + sqrt ? {r 2 3 +} 5 ? {r 2 *} 10 ? {r c 5 dup *} 25 ? {r c 3 4 hypot} 5.0 ? {r c {1 2 3} vector {dup *} vmap} {1 4 9 3} ? {r c {1 2 3} vector} {1 2 3 3} ? {r c {1 2 3} vector a append} {1 2 3 a 4} ? {r c a {1 2 3} vector cons} {a 1 2 3 4} ? {r c {1 2 3} vector {4 5 6} vector concat} {1 2 3 4 5 6 6} ? {r c {2 5 3} vector 0 (+) vfold} 10 ? {r c {3 4 5} vector product} 60 ? {r c {2 5 3} vector 0 {dup * +} vfold} 38 ? {r c {1 2 3 4} vector vdup sum dupd double / swap {swap drop} times} 2.5 ? {r c {1 2 3 4} vector (sum) {size double} cleave /} 2.5 def 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 factorial} 120 ? {r c 0 factorial} 1 # some logic ? {r c 1 0 and} 0 ? {r c 1 0 or} 1 ? {r c 1 0 and not} 1 # stack manipulation : vector commands ? {r c {1 2 3} vector hello -vswap} {hello 1 2 3 3} ? {r c {1 2 3} vector a append} {1 2 3 a 4} ? {r c a {1 2 3} vector cons} {a 1 2 3 4} ? {r c {1 2 3} vector first} 1 ? {r c {1 2 3} vector rest} {2 3 2} # matrices... def mymatrix {{1 2} {3 4} {5 6}} matrix ? {r c mymatrix} {1 2 3 4 5 6 2 7} ? {r c mymatrix .m} {{{1 2} {3 4} {5 6}}} ? {r c mymatrix vdrop} {} ? {r c mymatrix 0 0 matindex .} 1 ? {r c mymatrix 2 0 matindex .} 5 ? {r c mymatrix 1 1 matindex .} 4 # should put a warning ! -> index out of range ? {r c mymatrix 1 3 matindex .} 6 ? {r c mymatrix 0 matrow .v} {{1 2}} ? {r c mymatrix 2 matrow .v} {{5 6}} ? {r c mymatrix 0 matcol .v} {{1 3 5}} ? {r c mymatrix 1 matcol .v} {{2 4 6}} # make a matrix out of vectors ? {r c {1 2 3} vector {4 5 6} vector 2 matconcat .m} {{{1 2 3} {4 5 6}}} # transpose a matrix ? {r c mymatrix 0 matcol vvswap 1 matcol vvswap vdrop 2 matconcat .m} {{{1 3 5} {2 4 6}}} ? {r c mymatrix {0 1} vector {matcol vvswap} foreach vdrop 2 matconcat .m} {{{1 3 5} {2 4 6}}} ? {r c mymatrix transpose .m} {{{1 3 5} {2 4 6}}} ? {r c {{1 2 3 4 5} {6 7 8 9 10}} matrix transpose .m} {{{1 6} {2 7} {3 8} {4 9} {5 10}}} # multiplies two matrices ? {r c {{1 2} {3 4}} matrix vdup matmul .m} {{{7 10} {15 22}}} ? {r c hello mymatrix vswap . .m} {hello {{1 2} {3 4} {5 6}}} ? {r c mymatrix hello -vswap .m .} {{{1 2} {3 4} {5 6}} hello} def mymatrix {{1 2 3} {4 5 6} {7 8 9}} matrix ? {r c mymatrix 0 1 matrix.colrange .m} {{{1 2} {4 5} {7 8}}} ? {r c mymatrix 0 1 matrix.colrange_asrows .m} {{{1 4 7} {2 5 8}}} ? {r c mymatrix 0 1 matrix.rowrange .m} {{{1 2 3} {4 5 6}}} ? {r c {6 1 5 2 4 3} vector {3 >} filter} {6 5 4 3} ? {r c 1 2 {+ 20 * 10 4 -} i} {60 6} ? {r c 42 ++} 43 ? {r c 42 --} 41 ? {r c {2 3 5 7} vector 2 at} 3 ? {r c 2 {2 3 5 7} vector of} 3 ? {r c 1 2 drop} 1 ? {r c 'Aa' binary} {65 97 2} ? {r c 'Aa' binary .b} Aa ? {r c 'Aa' binary {3 +} vmap .b} Dd ? {r c 'A' binary swap 32 + ++ ++ swap .b} c ? {r c {1 2 3 4} vector reverse} {4 3 2 1 4} ? {r c 1 2 dupd} {1 2 1} ? {r c 6 9 gcd} 3 ? {r c {1 2 3 4} vector (odd) split} {2 4 2 1 3 2} ? {r c 1 {1 2 3} vector in} 1 ? {r c 4 {1 2 3} vector in} 0 ? {r c {1 2 3} vector 2 has} 1 ? {r c {1 2 3} vector 5 has} 0 ? {r c 3 4 max} 4 ? {r c 3 4 min} 3 ? {r c 0xff 128 bitand} 128 ? {r c 0xff 134 bitand} 134 ? {r c 0xff 134 bitor} 255 ? {r c 134 0xff bitor} 255 ? {r c 134 0xff bitxor} [expr {134^0xff}] ? {r c 134 0 bitxor} 134 ? {r c 0xff bitcomp} [expr ~0xff] ? {r c 12 2 lshift} 48 ? {r c 48 2 rshift} 12 ? {r c 51 2 rshift} 12 #-- Little dev. helper on the iPaq - short to type, tells the time interp alias {} s {} time {source rpn2006.tcl} #-- Useless if you have it into a versionning control system interp alias {} backup {} file copy -force rpn2006.tcl rpn.bak ---- See [RPN], [Pocket Joy 2005]. ---- [[ [Category Language] ]]