summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/wip
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/modules/wip')
-rw-r--r--tcllib/modules/wip/ChangeLog100
-rw-r--r--tcllib/modules/wip/pkgIndex.tcl5
-rw-r--r--tcllib/modules/wip/wip.man384
-rw-r--r--tcllib/modules/wip/wip.tcl463
-rw-r--r--tcllib/modules/wip/wip2.tcl464
5 files changed, 1416 insertions, 0 deletions
diff --git a/tcllib/modules/wip/ChangeLog b/tcllib/modules/wip/ChangeLog
new file mode 100644
index 0000000..4449185
--- /dev/null
+++ b/tcllib/modules/wip/ChangeLog
@@ -0,0 +1,100 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-04-07 Andreas Kupries <andreask@activestate.com>
+
+ * wip2.tcl (run_next_*): Fixed the run_next_ commands to stop
+ * wip.tcl: when detecting the end of the program. New feature,
+ * wip.man: a callback to handle unknown command words, defaults
+ * pkgIndex.tcl: to throwing an error. Updated documentation.
+ Bumped versions to 1.2 and 2.2.
+
+2010-04-05 Andreas Kupries <andreask@activestate.com>
+
+ * wip2.tcl (run_next_if, run_nextifnot): Extended API, two
+ * wip.tcl (run_next_if, run_nextifnot): more run_next_
+ * wip.man: commands to run a single following command instead
+ * pkgIndex.tcl: of all acceptable. Updated documentation. Bumped
+ versions to 1.1.3 and 2.1.3.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * wip.tcl: Made sure that wip classes are in the global
+ * wip2.tcl: namespace.
+
+2009-03-02 Andreas Kupries <andreask@activestate.com>
+
+ * wip.man: Made the use of 'wip' class in the snit macro
+ * wip.tcl: 'wip::dsl' fully qualified to prevent mis-resolutions
+ * wip2.tcl: of the name in case the user is a '...::wip' class
+ * pkgIndex.tcl: itself. In snit say this would resolve to the user
+ instead of the wip interpreter. Bumped the versions to 1.1.2 and
+ 2.1.2 respectively.
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * wip.tcl: Changed the name of the wip processor component added
+ * wip2.tcl: to DSL system, prevent it from clashing with the name
+ * pkgIndex.tcl: of the wip-core snit::type. Bumped the versions to
+ * wip.man: 1.1.1 and 2.1.1.
+
+2007-10-26 Andreas Kupries <andreask@activestate.com>
+
+ * wip.tcl: Extended error reporting, and fixes of bad indices in
+ * wip2.tcl: the methods manipulating the program (insert, push,
+ etc). wip v2 only extended error reporting.
+
+ * wip.tcl: Extended with method to undef DSL commands.
+ * wip2.tcl: Updated both variants, and the documentation.
+ * wip.man: Bumped versions to 1.1 and 2.1 respectively.
+ * pkgIndex.tcl:
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-07-30 Andreas Kupries <andreask@activestate.com>
+
+ * wip.man: Fixed bugs uncovered during test of
+ * wip.tcl: first user, fileutil::multi::op.
+ * wip2.tcl:
+
+2007-07-27 Andreas Kupries <andreask@activestate.com>
+
+ * New Module.
+
diff --git a/tcllib/modules/wip/pkgIndex.tcl b/tcllib/modules/wip/pkgIndex.tcl
new file mode 100644
index 0000000..7968ea1
--- /dev/null
+++ b/tcllib/modules/wip/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded wip 1.2 [list source [file join $dir wip.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded wip 2.2 [list source [file join $dir wip2.tcl]]
diff --git a/tcllib/modules/wip/wip.man b/tcllib/modules/wip/wip.man
new file mode 100644
index 0000000..bfffab3
--- /dev/null
+++ b/tcllib/modules/wip/wip.man
@@ -0,0 +1,384 @@
+[comment {-*- text -*-}]
+[manpage_begin wip n 2.2]
+[keywords interpreter]
+[keywords list]
+[keywords word]
+[copyright {2007-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Word Interpreter}]
+[titledesc {Word Interpreter}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require wip [opt 2.2]]
+[require snit [opt 1.3]]
+[require struct::set]
+[description]
+[para]
+
+This package provides a 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 the language desired. 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.
+
+[para]
+
+The idea is derived from Colin McCormack's [package 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.
+
+[section {GENERAL BEHAVIOUR}]
+
+Word interpreters have a mappping from the names of the language
+commands they shall recognize to the methods in the engine to invoke
+for them, and possibly fixed arguments for these methods. This mapping
+is largely static, however it is possible to change it during the
+execution of a word list (= program).
+
+[para]
+
+At the time a language command is defined the word interpreter will
+use [package snit]'s introspection capabilities to determine the
+number of arguments expected by the method of the egnine, and together
+with the number of fixed arguments supplied in the method prefix of
+the mapping it then knows how many arguments the language command is
+expecting. This is the command's [term arity]. Variable-argument
+methods (i.e. with the last argument named [arg args]) are [emph not]
+allowed and will cause the word interpreter to throw an error at
+definition time.
+
+[para]
+
+Note that while I said [package snit]'s abilities the engine object
+can be written in any way, as long as it understands the method
+[method {info args}], which takes a method name and returns the list
+of arguments for that method.
+
+[para]
+
+When executing a list of words (aka program) the first word is always
+taken as the name of a language command, and the next words as its
+arguments, per the [term arity] of the command. Command and argument
+words are removed from the list and then associated method of the
+engine is executed with the argument words. The process then repeats
+using the then-first word of the list.
+
+[para]
+
+Note that the methods implementing the language commands may have full
+access to the list of words and are allowed to manipulate as they see
+fit.
+
+[list_begin enum]
+
+[enum]
+This means, for example, that while we cannot specify
+variable-argument methods directly they can consume words after their
+fixed arguments before returning to the execution loop. This may be
+under the control of their fixed arguments.
+
+[enum]
+Another possibility is the use of method [method run_next] and its
+variants to execute commands coming after the current command,
+changing the order of execution.
+
+[enum]
+Execution can be further changed by use of the program accessor
+methods which allow a command implementation to modify the remaining
+list of words (insert, replace, prepend, append words) without
+executing them immediately.
+
+[enum]
+At last the basic [method run] methods save and restore an existing
+list of words when used, enabling recursive use from within command
+implementations.
+
+[list_end]
+
+[section {CLASS API}]
+
+The main command of the package is:
+
+[list_begin definitions]
+
+[call [cmd ::wip] [arg wipName] [arg engine] [arg arg]...]
+
+The command creates a new word interpreter object with an associated
+global Tcl command whose name is [arg wipName]. If however the string
+[const %AUTO%] was used as object name the package will generate its
+own unique name for the object.
+
+[para]
+
+The [arg engine] is the object the word interpreter will dispatch all
+recognized commands to, and the [arg arg]uments are a word list which
+defines an initial mapping from language words to engine methods.
+
+[para]
+
+The recognized language of this word list is
+
+[list_begin definitions]
+[call [cmd def] [arg name]]
+
+Defines [arg name] as command of the language, to be mapped to a
+method of the [arg engine] having the same name.
+
+[call [cmd def] [arg name] [arg method_prefix]]
+
+Defines [arg name] as command of the language, to be mapped to the
+method of the [arg engine] named in the [arg method_prefix].
+
+[list_end]
+
+[para]
+
+The returned command may be used to invoke various operations on the
+object. It has the following general form:
+
+[list_begin definitions]
+[call [cmd wipName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+[list_end]
+
+The package additionally exports the command:
+
+[list_begin definitions]
+
+[call [cmd wip::dsl] [opt [arg suffix]]]
+
+This command is for use within snit types which wish to use one or
+more wip interpreters as a component. Use within the type definition
+installs most of the boilerplate needed to setup and use a word
+interpreter.
+
+[para]
+
+It installs a component named [emph wip], and a method
+[method wip_setup] for initializing it. This method has to be called
+from within the constructor of the type using the word interpreter.
+
+If further installs a series of procedures which make the object API
+of the word interpreter directly available to the type's methods,
+without having to specify the component.
+
+[para]
+
+[emph Note] that this does and cannot install the language to
+interpret, i.e. the mapping from words to engine methods.
+
+[para]
+
+It is possible to instantiate multiple word interpreter components
+within a type by using different suffices as arguments to the command.
+
+In that case the name of the component changes to
+'wip_[var \$suffix]', the setup command becomes
+'wip_[var \$suffix]_setup' and all the procedures also get the suffix
+'_[var \$suffix]'.
+
+[list_end]
+
+[section {OBJECT API}]
+
+The following commands are possible for word interpreter objects:
+
+[list_begin definitions]
+
+[call [arg wipName] [method def] [arg name] [opt [arg method_prefix]]]
+
+Defines a language command [arg name] and maps it to the method named
+in the engine's [arg method_prefix]. If the [arg method_prefix] name
+is not specified it is simply the name of the language command.
+
+[call [arg wipName] [method defl] [arg names]]
+
+Defines a series of language commands, specified through the list of
+[arg names], all of which are mapped to engine methods of the same
+name.
+
+[call [arg wipName] [method defd] [arg dict]]
+
+Defines a series of language commands, specified through the
+dictionary [arg dict] of names and method prefixes.
+
+[call [arg wipName] [method deflva] [arg name]...]
+
+As method [method defl], however the list of names is specified
+through multiple arguments.
+
+[call [arg wipName] [method defdva] ([arg name] [arg method_prefix])...]
+
+As method [method defd], however the dictionary of names and method
+prefixes is specified through multiple arguments.
+
+[call [arg wipName] [method undefl] [arg names]]
+
+Removes the named series of language commands from the mapping.
+
+[call [arg wipName] [method undefva] [arg name]...]
+
+As method [method undefl], however the list of names is specified
+through multiple arguments.
+
+[call [arg wipName] [method unknown] [arg cmdprefix]]
+
+Sets the handler for unknown words to [arg cmdprefix]. This command
+prefix takes one argument, the current word, and either throws some
+error, or returns the result of executing the word, as defined by the
+handler. The default handler simply throws an error.
+
+[call [arg wipName] [method runl] [arg wordlist]]
+
+Treats the list of words in [arg wordlist] as a program and executes
+the contained command one by one. The result of the command executed
+last is returned as the result of this command.
+
+[para]
+
+The [arg wordlist] is stored in the object for access by the other
+[term run]-methods, and the general program accessor methods (see
+below). A previously stored wordlist is saved during the execution of
+this method and restored before it returns. This enables the recursive
+execution of word lists within word lists.
+
+[call [arg wipName] [method run] [arg word]...]
+
+As method [method runl], however the list of words to execute is
+specified through multiple arguments.
+
+[call [arg wipName] [method run_next]]
+
+Low-level method. Determines the next word in the list of words, and
+its arguments, and then executes it. The result of the executed word
+is the result of this method.
+
+[para]
+
+Exposed for use within command implementations.
+
+The methods [method run] and [method runl] use it to execute words
+until their word list is exhausted.
+
+[call [arg wipName] [method run_next_while] [arg acceptable]]
+
+Low-level method. Invokes the method [method run_next] as long as the
+next word is in the set of [arg acceptable] words, and the program is
+not empty. The result of the command executed last is returned as the
+result of this command.
+
+[para]
+
+Exposed for use within command implementations to change the order of
+execution.
+
+[call [arg wipName] [method run_next_until] [arg rejected]]
+
+Low-level method. Invokes the method [method run_next] until the next
+word is in the set of [arg rejected] words, and the program is not
+empty. The result of the command executed last is returned as the
+result of this command.
+
+[para]
+
+Exposed for use within command implementations to change the order of
+execution.
+
+[call [arg wipName] [method run_next_if] [arg acceptable]]
+
+Low-level method. Invokes the method [method run_next] if the next
+word is in the set of [arg acceptable] words, and the program is not
+empty. The result of the command executed last is returned as the
+result of this command.
+
+[para]
+
+Exposed for use within command implementations to change the order of
+execution.
+
+[call [arg wipName] [method run_next_ifnot] [arg rejected]]
+
+Low-level method. Invokes the method [method run_next] if the next
+word is not in the set of [arg rejected] words, and the program is not
+empty. The result of the command executed last is returned as the
+result of this command.
+
+[para]
+
+Exposed for use within command implementations to change the order of
+execution.
+
+[call [arg wipName] [method next]]
+
+Returns the next word in the programm. The word is also removed.
+
+[call [arg wipName] [method peek]]
+
+Returns the next word in the programm without removing it
+
+[call [arg wipName] [method peekall]]
+
+Returns the remaining programm in toto.
+
+[call [arg wipName] [method insertl] [arg at] [arg wordlist]]
+
+Basic programm accessor method. Inserts the specified [arg wordlist]
+into the program, just before the word at position [arg at]. Positions
+are counted from [const zero].
+
+[call [arg wipName] [method replacel] [arg wordlist]]
+
+Basic programm accessor method. Replaces the whole stored program with
+the specified [arg wordlist].
+
+[call [arg wipName] [method pushl] [arg wordlist]]
+
+Program accessor method. The specified [arg wordlist] is added to the
+front of the remaining program. Equivalent to
+
+[para]
+[example {$wip insertl 0 $wordlist}]
+
+[call [arg wipName] [method addl] [arg wordlist]]
+
+Program accessor method. The specified [arg wordlist] is appended at
+the end of the remaining program. Equivalent to
+
+[para]
+[example {$wip insertl end $wordlist}]
+
+[call [arg wipName] [method insert] [arg at] [arg word]...]
+
+Like method [method insertl], except the words are specified through
+multiple arguments.
+
+[call [arg wipName] [method replace] [arg word]...]
+
+Like method [method setl], except the words are specified through
+multiple arguments.
+
+[call [arg wipName] [method push] [arg word]...]
+
+Like method [method pushl], except the words are specified through
+multiple arguments.
+
+[call [arg wipName] [method add] [arg word]...]
+
+Like method [method addl], except the words are specified through
+multiple arguments.
+
+[list_end]
+
+[section EXAMPLES]
+
+No examples yet.
+
+[vset CATEGORY wip]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/wip/wip.tcl b/tcllib/modules/wip/wip.tcl
new file mode 100644
index 0000000..881a6a4
--- /dev/null
+++ b/tcllib/modules/wip/wip.tcl
@@ -0,0 +1,463 @@
+# ### ### ### ######### ######### #########
+##
+# (c) 2008-2009 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.4
+
+# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible.
+package require snit 1.3
+
+# The run_next_* methods use set operations (x in set)
+package require struct::set
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+snit::type ::wip {
+
+ # ### ### ### ######### ######### #########
+ ## API
+
+ constructor {e args} {} ; # create processor
+
+ # Defining commands and where they dispatch to.
+ method def {name {cp {}}} {} ; # Define a DSL command.
+ method def/ {name arity {cp {}}} {} ; # Ditto, with explicit arity.
+ 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
+
+ method undefva {args} {} ; # Remove DSL commands from the map.
+ method undefl {names} {} ; # Ditto, names given as list.
+
+ # 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
+ method run_next_if {accept} {} ; # s.a., if acceptable command
+ method run_next_ifnot {reject} {} ; # s.a., if not 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 unknown [mymethod ErrorForUnknown]
+ $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 unknown {} ; # command prefix invoked when
+ # encountering unknown command words.
+ 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 def/ {name ay {mp {}}} {
+ # Like def, except that the arity is specified
+ # explicitly. This is for methods with a variable number of
+ # arguments in their definition, possibly dependent on the
+ # fixed parts of the prefix.
+
+ if {$mp eq {}} {
+ # Derive method-prefix from DSL word.
+ set mp [list $name]
+ set m $name
+
+ } else {
+ # No need to check for an empty method-prefix. That cannot
+ # happen, as it is diverted, see above.
+
+ set m [lindex $mp 0]
+ }
+
+ # The arity of the command is specified by the caller.
+
+ set cmd($name) [linsert $mp 0 $engine]
+ set arity($name) $ay
+ 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
+ }
+
+ method undefva {args} { $self undefl $args ; return }
+ method undefl {names} {
+ foreach name $names {
+ unset -nocomplain cmd($name)
+ unset -nocomplain arity($name)
+ }
+ 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 {[llength $program] && [struct::set contains $accept [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_until {reject} {
+ set r {}
+ while {[llength $program] && ![struct::set contains $reject [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_if {accept} {
+ set r {}
+ if {[llength $program] && [struct::set contains $accept [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_ifnot {reject} {
+ set r {}
+ if {[llength $program] && ![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)]} {
+ # Invoke the unknown handler
+ return [uplevel #0 [linsert $unknown end $c]]
+ }
+
+ set n $arity($c)
+ set m $cmd($c)
+
+ # Take the fixed arguments from the input as well.
+
+ if {[llength $program] <= $n} {
+ return -code error -errorcode WIP \
+ "Not enough arguments for command \"$c\""
+ }
+
+ 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'.
+
+ if {![llength $cargs]} {
+ return [eval $m]
+ } else {
+ # Explanation: First linsert constructs 'linsert $m end {*}$cargs',
+ # which the inner eval transforms into '{*}$m {*}$cargs', which at
+ # last is run by the outer eval.
+ return [eval [eval [linsert $cargs 0 linsert $m end]]]
+ }
+ }
+
+ # ### ### ### ######### ######### #########
+ ## 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 [eval [linsert $args 0 linsert $program $at]]
+ return
+ }
+ method insertl {at alist} {
+ set program [eval [linsert $alist 0 linsert $program $at]]
+ return
+ }
+
+ # <=> insert 0
+ method push {args} {
+ set program [eval [linsert $args 0 linsert $program 0]]
+ return
+ }
+ method pushl {alist} {
+ set program [eval [linsert $alist 0 linsert $program 0]]
+ return
+ }
+
+ # <=> insert end
+ method add {args} {
+ set program [eval [linsert $args 0 linsert $program end]]
+ return
+ }
+ method addl {alist} {
+ set program [eval [linsert $alist 0 linsert $program end]]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method unknown {cmdprefix} {
+ set unknown $cmdprefix
+ return
+ }
+
+ method ErrorForUnknown {word} {
+ return -code error -errorcode WIP \
+ "Unknown command \"$word\""
+ }
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+##
+
+# 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 [eval [linsert $args 0 $dst {@m@}]]
+ }]
+}
+
+# ### ### ### ######### ######### #########
+## 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 mywip$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 {mywip@@} using ::wip "${selfns}::mywip@@" $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 undefva undefl
+ defd defdva defl deflva def/
+ insert insertl replace replacel
+ push pushl run runl
+ next peek peekall run_next
+ run_next_until run_next_while
+ run_next_ifnot run_next_if
+ } {
+ wip::methodasproc mywip$suffix $p $suffix
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide wip 1.2
diff --git a/tcllib/modules/wip/wip2.tcl b/tcllib/modules/wip/wip2.tcl
new file mode 100644
index 0000000..9cd5a19
--- /dev/null
+++ b/tcllib/modules/wip/wip2.tcl
@@ -0,0 +1,464 @@
+# ### ### ### ######### ######### #########
+##
+# (c) 2008-2010 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 snit 1.3 and anything above (incl. v2+).
+package require snit 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 args} {} ; # create processor
+
+ # Defining commands and where they dispatch to.
+ method def {name {cp {}}} {} ; # Define a DSL command.
+ method def/ {name arity {cp {}}} {} ; # Ditto, with explicit arity.
+ 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
+
+ method undefva {args} {} ; # Remove DSL commands from the map.
+ method undefl {names} {} ; # Ditto, names given as list.
+
+ # 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
+ method run_next_if {accept} {} ; # s.a., if acceptable command
+ method run_next_ifnot {reject} {} ; # s.a., if not 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
+
+ # Set callback for unknown command words.
+ method unknown {commandprefix} {}
+
+ # ### ### ### ######### ######### #########
+ ## Processor construction.
+
+ constructor {e args} {
+ if {$e eq ""} {
+ return -code error "No engine specified"
+ }
+ set engine $e
+ $self unknown [mymethod ErrorForUnknown]
+ $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 unknown {} ; # command prefix invoked when
+ # encountering unknown command words.
+ 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 from 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 the 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 def/ {name ay {mp {}}} {
+ # Like def, except that the arity is specified
+ # explicitly. This is for methods with a variable number of
+ # arguments in their definition, possibly dependent on the
+ # fixed parts of the prefix.
+
+ if {$mp eq {}} {
+ # Derive method-prefix from DSL word.
+ set mp [list $name]
+ set m $name
+
+ } else {
+ # No need to check for an empty method-prefix. That cannot
+ # happen, as it is diverted, see above.
+
+ set m [lindex $mp 0]
+ }
+
+ # The arity of the command is specified by the caller.
+
+ set cmd($name) [linsert $mp 0 $engine]
+ set arity($name) $ay
+ 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
+ }
+
+ method undefva {args} { $self undefl $args ; return }
+ method undefl {names} {
+ foreach name $names {
+ unset -nocomplain cmd($name)
+ unset -nocomplain arity($name)
+ }
+ 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 {[llength $program] && [struct::set contains $accept [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_until {reject} {
+ set r {}
+ while {[llength $program] && ![struct::set contains $reject [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_if {accept} {
+ set r {}
+ if {[llength $program] && [struct::set contains $accept [$self peek]]} {
+ set r [$self run_next]
+ }
+ return $r
+ }
+
+ method run_next_ifnot {reject} {
+ set r {}
+ if {[llength $program] && ![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)]} {
+ # Invoke the unknown handler
+ set program [lrange $program 1 end]
+ return [uplevel #0 [list {*}$unknown $c]]
+ }
+
+ set n $arity($c)
+ set m $cmd($c)
+
+ # Take the fixed arguments from the input as well.
+
+ if {[llength $program] <= $n} {
+ return -code error -errorcode WIP \
+ "Not enough arguments for command \"$c\""
+ }
+
+ 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
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method unknown {cmdprefix} {
+ set unknown $cmdprefix
+ return
+ }
+
+ method ErrorForUnknown {word} {
+ return -code error -errorcode WIP \
+ "Unknown command \"$word\""
+ }
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+##
+
+# 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 mywip$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 {mywip@@} using ::wip "${selfns}::mywip@@" $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 undefva undefl
+ defd defdva defl deflva def/
+ insert insertl replace replacel
+ push pushl run runl
+ next peek peekall run_next
+ run_next_until run_next_while
+ run_next_ifnot run_next_if
+ } {
+ wip::methodasproc mywip$suffix $p $suffix
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide wip 2.2
generated by cgit v0.12 at 2025-04-17 21:59:44 (GMT)