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 3
  
We start with a little VM in run that has some core opcodes.  
  
A string is passed to compile, and compile returns a list of core opcodes for the task.  
  
: defined words translate directly to a list of core opcodes. 
  
Unlike Forth, : defined words are terminated with a period, rather than a semicolon.
  
The word emit prints any item on the top of the stack.
  
Special words get a marker that tells them how many instructions the next word consists of.
  
Caveat: It's difficult to factor some state-machine code ...
}
----
  
  array set ::words {
   + ADD
   / DIVIDE
   do.n.times DO_N_TIMES
   drop DROP
   dup DUP
   emit EMIT
   = EQUAL
   get GET
   > GREATER_THAN
   < LESS_THAN
  * MULTIPLY
   pick PICK
   set SET
   stack STACK
   - SUB
   then THEN
   vars VARS
  }
  array set ::vars {}
  
  array set ::special_words {
   then {}
   do.n.times {}
  }
  
  #This is to prevent giving a bad variable name:
  proc ?set {v_ptr val} {
   upvar $v_ptr v
   if {![info exists v]} {
    return -code error "$v_ptr should exist"
   }
   set v $val
  }
  
  proc compile s {
   set word_def [list]
   set work_list [list]
   set word ""
   set cur work_list
   set is_special 0
  
   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 {[string is integer $tok] || [string is double $tok] || "quote" == $type} {
     if {$is_special} {
      #To handle for example: 1 do.n.times 5
      lappend $cur MARKER
      lappend $cur 2
     }
     lappend $cur PUSH
     lappend $cur $tok
    } else {
     if {![info exists ::words($tok)]} {
      return -code error "invalid word: $tok"
     }
     if {$is_special} {
      #To handle for example: 1 do.n.times word
      lappend $cur MARKER
      lappend $cur [llength [set ::words($tok)]]
      ?set is_special 0
     }
     set $cur [concat [set $cur] [set ::words($tok)]]
     if {[info exists ::special_words($tok)]} {
      ?set is_special 1
     }
    }
   }
   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]]
     } 
     DIVIDE {
      set arg [pop]; 
      push [expr [pop] / $arg]
     }
     DO_N_TIMES {
      set num_times [pop]
      set num_inst [lindex $work_list [expr {$i + 2}]]
      incr i 3 ;# advance past MARKER num_inst
      set do_this [lrange $work_list $i [expr {$i + $num_inst}]]
      while {$num_times > 0} {
       run $do_this
       incr num_times -1
      }
      incr i $num_inst  
     }
     DROP {
      set ::stack [lrange $::stack 0 end-1]
     }
     DUP {
      lappend ::stack [lindex $::stack end] 
     }
     EMIT {
      puts [pop]
     }
     EQUAL {
       push [expr [pop] == [pop]]
     }
     GET {
      push [set ::vars([pop])]
     }
     GREATER_THAN {
      set arg [pop]
      push [expr [pop] > $arg]
     }
     LESS_THAN {
       set arg [pop]
       push [expr [pop] < $arg]
     }
     MARKER {
      incr i
      #do nothing
     }
     MULTIPLY {
      push [expr [pop] * [pop]]
     }
     PICK {
      set n [pop]
      push [lindex $::stack end-$n]
     }
     PUSH {
      push [lindex $work_list [incr 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]
     }
     THEN {
      if {![pop]} {
       #We want to skip the next instructions for a single word.
       set i [expr {$i + 2}]
       set i [expr $i + [lindex $work_list $i] + 1]     
      }
     }
     VARS {
      parray ::vars
     }
    }
   }
  }
  
  proc main {} {
   #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
----
Runtime example:
 > : incr 1 + .
 > 1 
 > 5 do.n.times incr 
 > stack
 [0] = 6
 > dup
 > stack
 [0] = 6
 [1] = 6
 > *
 > stack
 [0] = 36
 > : say 'Hello' emit .
 > : George 'George' emit .
 > : joined say George .
 > joined
 Hello
 George
 >5 6 <
 > stack
 [0] = 36
 [1] = 1
 > - 
 > stack
 [0] = 35
 > 7 7 = stack
 [0] = 35
 [1] = 1
 > 'var' set
 > stack
 [0] = 35
 > drop
 > 'var' get
 > stack
 [0] = 1
 > 
----
Exercises:
   1. add more error checking to compile
   1. using dup or pick create an incr.var word that increases the value of a variable.
   1. add other looping constructs

----
[Category Application]
[Category Mathematics]