wip.tcl

Go to the documentation of this file.

/*  ### ### ### ######### ######### #########*/
/** 
 * (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.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::

# ### ### ### ######### ######### #########
## API =  & Implementation

snit::type wip {

    /*  ### ### ### ######### ######### #########*/
    /*  API*/

    constructor           {e}       {} ; /*  create processor*/

    /*  Defining commands and where they dispatch to.*/
    ret  def            (type name , optional 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"
    }
     engine =  $e
    $self Definitions $args
    return
    }

    ret  Definitions (type 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.*/

    ret  def (type name , optional mp ={)} {
    if {$mp eq {}} {
        /*  Derive method-prefix from DSL word.*/
         mp =  [list $name]
         m =   $name
         n =  0

    } else {
        /*  No need to check for an empty method-prefix. That cannot*/
        /*  happen, as it is diverted, see above.*/

         m =  [lindex $mp 0]
         n =  [expr {[llength $mp]-1}]
    }

    /*  Get method arguments, check for problems.*/
     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.*/

     cmd = ($name)   [linsert $mp 0 $engine]
     arity = ($name) [expr {[llength $a] - $n}]
    return
    }

    ret  deflva (type args)  { $self defl $args ; return }
    ret  defdva (type args)  { $self defd $args ; return }
    ret  defl   (type names) { foreach n $names { $self def $n } ; return }
    ret  defd   (type 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*/

    ret  run (type args) {
    return [$self runl $args]
    }

    ret  runl (type 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
    }

    ret  run_next_while (type accept) {
    set r {}
    while {[struct::set contains $accept [$self peek]]} {
        set r [$self run_next]
    }
    return $r
    }

    ret  run_next_until (type reject) {
    set r {}
    while {![struct::set contains $reject [$self peek]]} {
        set r [$self run_next]
    }
    return $r
    }

    ret  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'.

    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)*/
    ret  next () {
    set w       [lindex $program 0]
    set program [lrange $program 1 end]
    return $w
    }

    /*  Peek at the next word in the input*/
    ret  peek () {
    return [lindex $program 0]
    }

    /*  Retrieve the whole current program*/
    ret  peekall () {
    return $program
    }

    /*  Replace the current programm*/
    ret  replace (type args) {
    set program $args
    return
    }
    ret  replacel (type alist) {
    set program $alist
    return
    }

    /*  Insert words into the input stream.*/
    ret  insert (type at , type args) {
    set program [eval [linsert $args end linsert $program $at]]
    return
    }
    ret  insertl (type at , type alist) {
    set program [eval [linsert $alist end linsert $program $at]]
    return
    }

    /*  <=> insert 0*/
    ret  push (type args) {
    set program [eval [linsert $args end linsert $program 0]]
    return
    }
    ret  pushl (type alist) {
    set program [eval [linsert $alist end linsert $program 0]]
    return
    }

    /*  <=> insert end*/
    ret  add (type args) {
    set program [eval [linsert $args end linsert $program end]]
    return
    }
    ret  addl (type alist) {
    set program [eval [linsert $alist end linsert $program end]]
    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::ret asproc (type var , type method , type 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 ""} { 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.*/

    ret  wip$(type 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::ret asproc wip$suffix $p $suffix
    }
    return
}

# ### ### ### ######### ######### #########
## Ready

package provide wip 1.0