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
}
}
}
mainRuntime 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:
- add more error checking to compile
- using dup or pick create an incr.var word that increases the value of a variable.
- add other looping constructs
