# ### ### ### ######### ######### #########
##
# (c) 2007 Andreas Kupries.
# WIP = Word Interpreter (Also a Work In Progress :). Especially while
# it is running :P
# Micro interpreter for lists of words. Domain specific languages
# based on this will have a bit of a Forth feel, with the input stream
# segmented into words and any other structuring left to whatever
# language. Note that we have here in essence only the core dispatch
# loop, and no actual commands whatsoever, making this definitely only
# a Forth feel and not an actual Forth.
# The idea is derived from Colin McCormack's treeql processor,
# modified to require less boiler plate within the command
# implementations, at the expense of, likely, execution speed. In
# addition the interface between processor core and commands is more
# complex too.
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.5
# Use new Tcl 8.5a6+ features for specification of allowed packages.
# We can use either snit 2.2+, or 1.3+ if snit2 is not available.
package require snit 2.2 1.3
# The run_next_* methods use set operations (x in set)
package require struct::set
# For 8.5 we are using features like word-expansion to simplify the
# various evaluations. Otherwise this is identical to v1.
# ### ### ### ######### ######### #########
## API & Implementation
snit::type wip {
# ### ### ### ######### ######### #########
## API
constructor {e} {} ; # create processor
# Defining commands and where they dispatch to.
method def {name {cp {}}} {} ; # Define a DSL command.
method defl {names} {} ; # Def many, simple names (cp = name)
method defd {dict} {} ; # s.a. name/cp dict
method deflva {args} {} ; # s.a. defl, var arg form
method defdva {args} {} ; # s.a. defd, var arg form
# Execution of word lists.
method runl {alist} {} ; # execute list of words
method run {args} {} ; # ditto, words as varargs
method run_next {} {} ; # run the next command in the input.
method run_next_while {accept} {} ; # s.a., while acceptable command
method run_next_until {reject} {} ; # s.a., until rejectable command
# Manipulation of the input word list.
method peek {} {} ; # peek at next word in input
method next {} {} ; # pull next word from input
method insert {at args} {} ; # insert words back into the input
method push {args} {} ; # ditto, at == 0
# ### ### ### ######### ######### #########
## Processor construction.
constructor {e args} {
if {$e eq ""} {
return -code error "No engine specified"
}
set engine $e
$self Definitions $args
return
}
method Definitions {alist} {
# args = series of 'def name' and 'def name cp' statements.
# The code to handle them is in essence a WIP too, just
# hardcoded, as state machine.
set state expect-def
set n {}
set cp {}
foreach a $alist {
if {$state eq "expect-def"} {
if {$a ne "def"} {
return -code error "Expected \"def\", got \"$a\""
}
set state get-name
} elseif {$state eq "get-name"} {
set name $a
set state get-cp-or-def
} elseif {$state eq "get-cp-or-def"} {
# This means that 'def' cannot be a command prefix for
# DSL command.
if {$a eq "def"} {
# Short definition, name only, completed.
$self def $name
# We already have the first word of the next
# definition here, name is coming up next.
set state get-name
} else {
# Long definition, name + cp, completed.
$self def $name $a
# Must be followed by the next definition.
set state expect-def
}
}
}
if {$state eq "get-cp-or-def"} {
# Had a short definition last, now complete.
$self def $name
} elseif {$state eq "get-name"} {
# Incomplete definition at the end, bogus
return -code error "Incomplete definition at end, name missing."
}
return
}
# ### ### ### ######### ######### #########
## Processor state
## Handle of the object incoming commands are dispatched to.
## The currently active DSL code, i.e. word list.
variable engine {} ; # command
variable program {} ; # list (string)
variable arity -array {} ; # array (command name -> command arity)
variable cmd -array {} ; # array (command name -> method cmd prefix)
# ### ### ### ######### ######### #########
## API: DSL definition
## DSL words map to method-prefixes, i.e. method names + fixed
## arguments. We store them with the engine already added in front
## to make them regular command prefixes. No 'mymethod' however,
## that works only in engine code itself, not form the outside.
method def {name {mp {}}} {
if {$mp eq {}} {
# Derive method-prefix from DSL word.
set mp [list $name]
set m $name
set n 0
} else {
# No need to check for an empty method-prefix. That cannot
# happen, as it is diverted, see above.
set m [lindex $mp 0]
set n [expr {[llength $mp]-1}]
}
# Get method arguments, check for problems.
set a [$engine info args $m]
if {[lindex $a end] eq "args"} {
return -code error "Unable to handle Tcl varargs"
}
# The arity of the command is number of required arguments,
# with compensation for those already covered by the
# method-prefix.
set cmd($name) [linsert $mp 0 $engine]
set arity($name) [expr {[llength $a] - $n}]
return
}
method deflva {args} { $self defl $args ; return }
method defdva {args} { $self defd $args ; return }
method defl {names} { foreach n $names { $self def $n } ; return }
method defd {dict} {
if {[llength $dict]%2==1} {
return -code error "Expected a dictionary, got \"$dict\""
}
foreach {name mp} $dict {
$self def $name $mp
}
return
}
# ### ### ### ######### ######### #########
## API: DSL execution
#
## Consider moving the core implementation into procs, to reduce
## call overhead
method run {args} {
return [$self runl $args]
}
method runl {alist} {
# Note: We are saving the current program and restore it
# afterwards, this handles the possibility that this is a
# recursive call into the dispatcher.
set saved $program
set program $alist
set r {}
while {[llength $program]} {
set r [$self run_next]
}
set program $saved
return $r
}
method run_next_while {accept} {
set r {}
while {[struct::set contains $accept [$self peek]]} {
set r [$self run_next]
}
return $r
}
method run_next_until {reject} {
set r {}
while {![struct::set contains $reject [$self peek]]} {
set r [$self run_next]
}
return $r
}
method run_next {} {
# The first word in the list is the current command. Determine
# the number of its fixed arguments. This also checks command
# validity in general.
set c [lindex $program 0]
if {![info exists arity($c)]} {
return -code error \
"Unknown command \"$c\""
}
set n $arity($c)
set m $cmd($c)
# Take the fixed arguments from the input as well.
set cargs [lrange $program 1 $n]
incr n
# Remove the command to dispatch, and its fixed arguments from
# the program. This is done before the dispatch so that the
# command has access to the true current state of the input.
set program [lrange $program $n end]
# Now run the command with its arguments. Commands needing
# more than the declared fixed number of arguments are
# responsible for reading them from input via the method
# 'next' provided by the processor core.
# Note: m already has the engine at the front, it was stored
# that way, see 'def'.
return [{*}$m {*}$cargs]
}
# ### ### ### ######### ######### #########
## Input manipulation
# Get next word from the input (shift)
method next {} {
set w [lindex $program 0]
set program [lrange $program 1 end]
return $w
}
# Peek at the next word in the input
method peek {} {
return [lindex $program 0]
}
# Retrieve the whole current program
method peekall {} {
return $program
}
# Replace the current programm
method replace {args} {
set program $args
return
}
method replacel {alist} {
set program $alist
return
}
# Insert words into the input stream.
method insert {at args} {
set program [linsert $program $at {*}$args]
return
}
method insertl {at alist} {
set program [linsert $program $at {*}$alist]
return
}
# <=> insert 0
method push {args} {
set program [linsert $program 0 {*}$args]
return
}
method pushl {alist} {
set program [linsert $program 0 {*}$alist]
return
}
# <=> insert end
method add {args} {
set program [linsert $program end {*}$args]
return
}
method addl {alist} {
set program [linsert $program end {*}$alist]
return
}
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
##
# Macro to declare the method of a component as proc. We use this
# later to make access to a WIP processor simpler (no need to write
# the component reference on our own). And no, this is not the same as
# the standard delegation. Doing that simply replaces the component
# name in the call with '$self'. We remove the need to have this
# written in the call.
snit::macro wip::methodasproc {var method suffix} {
proc $method$suffix {args} [string map [list @v@ $var @m@ $method] {
upvar 1 {@v@} dst
return [$dst {@m@} {*}$args]
}]
}
# ### ### ### ######### ######### #########
## Ready
# ### ### ### ######### ######### #########
##
# Macro to install most of the boilerplate needed to setup and use a
# WIP. The only thing left is to call the method 'wip_setup' in the
# constructor of the class using WIP. This macro allows the creation
# of multiple wip's, through custom suffices.
snit::macro wip::dsl {{suffix {}}} {
if {$suffix ne ""} {set suffix _$suffix}
# Instance state, wip processor used to run the language
component wip$suffix
# Standard method to create the processor component. The user has
# to manually add a call of this method to the constructor.
method wip${suffix}_setup {} [string map [list @@ $suffix] {
install {wip@@} using wip "${selfns}::wip@@" $self
}]
# Procedures for easy access to the processor methods, without
# having to use self and wip. I.e. special delegation.
foreach {p} {
add addl def
defd defdva defl deflva
insert insertl replace replacel
push pushl run runl
next peek peekall run_next
run_next_until run_next_while
} {
wip::methodasproc wip$suffix $p $suffix
}
return
}
# ### ### ### ######### ######### #########
## Ready
package provide wip 2.0
