if 0 {
George Peter Staplin's version of RPN.

Licence ([OLL]):  Get it, use it, share it, improve it, but don't blame me.

Revision 2
}
----
  array set ::words {
   + ADD
   emit EMIT
   get GET
   set SET
   stack STACK
   - SUB
   vars VARS
  }
  array set ::vars {}
  
  proc compile s {
   set word_def [list]
   set work_list [list]
   set word ""
   set cur work_list
  
   while 1 {
    set tok [get.token s type]
    if {"" == $tok} {
     break
    } elseif {"." == $tok} {
     #We found the end of a word definition.  Store the list of instructions for it.
     set ::words($word) $word_def
     set word_def [list]
     set word ""
     set cur work_list
    } elseif {":" == $tok} {
     #We found the start of a word definition.
     set word [get.token s type]
     set cur word_def
    } elseif {"quote" == $type || [string is integer $tok]} {
      lappend $cur PUSH
      lappend $cur $tok
    } else {
     if {![info exists ::words($tok)]} {
      return -code error "invalid word: $tok"
     }
     set $cur [concat [set $cur] [set ::words($tok)]]
    }
   }
   return $work_list
  }
  
  proc get.token {s_ptr type_ptr} {
   upvar $s_ptr s
   upvar $type_ptr type
   set s_len [string length $s]
   set tok ""
   set type ""
   set is_quote 0
  
   for {set i 0} {$i < $s_len} {incr i} {
    set c [string index $s $i]
    if {$is_quote} {
     if {"'" == $c} {
      #We have reached the end of our ' quoted string.
      incr i
      set s [string range $s $i end]
      set type quote
      return $tok
     }
     append tok $c
    } elseif {"'" == $c} {
     set is_quote 1
     continue
    } elseif {[string is space $c]} {
     if {[string length $tok] > 0} {
      set s [string range $s $i end]
      return $tok  
     }
    } else {
     append tok $c
    } 
   }
   set s ""
   return $tok
  }
  
  set ::stack [list]
  proc pop {} {
   set i [lindex $::stack end]
   set ::stack [lrange $::stack 0 end-1]
   set i
  } 
  proc push i {
   lappend ::stack $i
  }
  
  proc run work_list {
   set work_list_len [llength $work_list]
   for {set i 0} {$i < $work_list_len} {incr i} {
    switch -exact [lindex $work_list $i] {
     ADD {
      push [expr [pop] + [pop]]
     } 
     EMIT {
      puts [pop]
     }
     GET {
      push [set ::vars([pop])]
     }
     PUSH {
      incr i
      push [lindex $work_list $i]
     }
     SET {
      set ::vars([pop]) [pop]
     }
     STACK {
      set count 0
      foreach cell $::stack {
       puts "\[[set count]\] = $cell"
       incr count
      }
     }
     SUB {
      set arg [pop]
      push [expr [pop] - $arg]
     }
     VARS {
      parray ::vars
     }
    }
   }
  }
  
  proc main {} {
   set s "'Hello World' emit  4 5 +  3 - 'num' set 'num' get emit"
   run [compile $s]
   #Now begin our read, compile, run endless loop
   while 1 {
    puts -nonewline "> "
    flush stdout
    if {[catch {run [compile [gets stdin]]} res]} {
     puts error:$res
    } 
   }
  }
  main
----
Here's an example run:
 $ tclsh85g.exe tcl_fun.tcl 
 Hello World
 6
 > : incr 1 + .
 > 50
 > incr
 > stack
 [0] = 51
 > incr
 > stack
 [0] = 52
 > 60 + stack
 [0] = 112
 > 
 > : incr 1 + 'incr' emit .
 > : decr 1 - 'decr' emit .
 > : foo incr decr .
 > 400
 > foo
 incr
 decr
 > stack
 [0] = 112
 [1] = 400

----
Exercises:
   1. add a dup word
   1. add a drop word
   1. add more error checking to compile