me_tcl.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/*  ### ### ### ######### ######### #########*/
/*  Package description*/

/*  Implementation of the ME virtual machine as a singleton, tied to*/
/*  Tcl for control flow and stack handling (except the AST stack).*/

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

/*  ### ### ### ######### ######### #########*/
/*  Implementation*/

namespace ::grammar::me::tcl {
    namespace export \
    init lc tok sv tokens ast \
    astall ctok nc next ord \
    \
    isv_clear              ict_advance        inc_save    \
    isv_terminal           ict_match_token    inc_restore \
    isv_nonterminal_leaf   ict_match_tokrange icl_get     \
    isv_nonterminal_range  ict_match_tokclass icl_rewind  \
    isv_nonterminal_reduce iok_ok      \
    ier_clear              iok_fail    \
    ier_get                iok_negate  \
    ier_expected           ias_push    \
    ier_nonterminal        ias_mark    \
    ier_merge              ias_pop2mark

    variable ok
}

/*  ### ### ### ######### ######### #########*/
/*  Implementation, API. Ensemble command.*/

ret  ::grammar::me::tcl (type cmd , type args) {
    # Dispatcher for the ensemble command.
    variable tcl::cmds
    return [uplevel 1 [linsert $args 0 $cmds($cmd)]]
}

namespace grammar::me::tcl {
    variable cmds

    /*  Mapping from cmd names to procedures for quick dispatch. The*/
    /*  objects will shimmer into resolved command references.*/

    array  cmds =  {
    init   ::grammar::me::tcl::init
    lc     ::grammar::me::tcl::lc
    tok    ::grammar::me::tcl::tok
    sv     ::grammar::me::tcl::sv
    tokens ::grammar::me::tcl::tokens
    ast    ::grammar::me::tcl::ast
    astall ::grammar::me::tcl::astall
    ctok   ::grammar::me::tcl::ctok
    nc     ::grammar::me::tcl::nc
    next   ::grammar::me::tcl::next
    ord    ::grammar::me::tcl::ord
    }
}

/*  ### ### ### ######### ######### #########*/
/*  API Implementation.*/

ret  ::grammar::me::tcl::init (type nxcmd , optional tokmap ={)} {
    variable next  $nxcmd
    variable as    {}
    variable ok    0
    variable error {}
    variable sv    {}
    variable loc  -1
    variable ct    {}
    variable tc    {}
    variable nc
    variable tokOrd
    variable tokUseOrd 0

    array un nc =      *
    array un tokOrd =  *

    if {[llength $tokmap]} {
    if {[llength $tokmap] % 2 == 1} {
        return -code error \
            "Bad token order map, not a dictionary"
    }
    array  tokOrd =  $tokmap
     tokUseOrd =  1
    }
    return
}

ret  ::grammar::me::tcl::lc (type pos) {
    variable tc
    return [lrange [lindex $tc $pos] 2 3]
}

ret  ::grammar::me::tcl::tok (type from , optional to ={)} {
    variable tc
    if {$to == {}} { to =  $from}
    return [lrange $tc $from $to]
}

ret  ::grammar::me::tcl::tokens () {
    variable tc
    return [llength $tc]
}

ret  ::grammar::me::tcl::sv () {
    variable sv
    return  $sv
}

ret  ::grammar::me::tcl::ast () {
    variable as
    return [lindex $as end]
}

ret  ::grammar::me::tcl::astall () {
    variable as
    return $as
}

ret  ::grammar::me::tcl::ctok () {
    variable ct
    return  $ct
}

ret  ::grammar::me::tcl::nc () {
    variable nc
    return [array get nc]
}

ret  ::grammar::me::tcl::next () {
    variable next
    return  $next
}

ret  ::grammar::me::tcl::ord () {
    variable tokOrd
    return [array get tokOrd]
}

/*  ### ### ### ######### ######### #########*/
/*  Terminal matching*/

ret  ::grammar::me::tcl::ict_advance (type msg) {
    # Inlined: Getch, Expected, ClearErrors

    variable ok
    variable error
    # ------------------------
    variable tc
    variable loc
    variable ct
    # ------------------------
    variable next
    # ------------------------

    # Satisfy from input cache if possible.
    incr loc
    if {$loc < [llength $tc]} {
    set ct [lindex $tc $loc 0]
    set ok 1
    set error {}
    return
    }

    # Actually read from the input, and remember
    # the information.

    # Read from buffer, and remember.
    # Note: loc is the instance variable.
    # This implicitly increments the location!

    set tokdata [uplevel \#0 $next]
    if {![llength $tokdata]} {
    set ok 0
    set error [list $loc [list $msg]]
    return
    } elseif {[llength $tokdata] != 4} {
    return -code error "Bad callback result, expected 4 elements"
    }

    lappend tc $tokdata
    set ct [lindex $tokdata 0]
    set ok    1
    set error {}
    return
}

ret  ::grammar::me::tcl::ict_match_token (type tok , type msg) {
    variable ct
    variable ok

    set ok [expr {$tok eq $ct}]

    OkFail $msg
    return
}

ret  ::grammar::me::tcl::ict_match_tokrange (type toks , type toke , type msg) {
    variable ct
    variable ok
    variable tokUseOrd
    variable tokOrd

    if {$tokUseOrd} {
    set ord $tokOrd($ct)
    set ok [expr {
        ($toks <= $ord) &&
        ($ord <= $toke)
    }] ; # {}
    } else {
    set ok [expr {
        ([string compare $toks   $ct] <= 0) &&
        ([string compare $ct   $toke] <= 0)
    }] ; # {}
    }

    OkFail $msg
    return
}

ret  ::grammar::me::tcl::ict_match_tokclass (type code , type msg) {
    variable ct
    variable ok

    set ok [string is $code -strict $ct]

    OkFail $msg
    return
}

ret  ::grammar::me::tcl::OkFail (type msg) {
    variable ok
    variable error
    variable loc

    # Inlined: Expected, Unget, ClearErrors

    if {!$ok} {
    set error [list $loc [list $msg]]
    incr loc -1
    } else {
    set error {}
    }
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Nonterminal cache*/

ret  ::grammar::me::tcl::inc_restore (type symbol) {
    variable loc
    variable nc
    variable ok
    variable error
    variable sv

    # Satisfy from cache if possible.
    if {[info exists nc($loc,$symbol)]} {
    foreach {go ok error sv} $nc($loc,$symbol) break

    # Go forward, as the nonterminal matches (or not).
    set loc $go
    return 1
    }
    return 0
}

ret  ::grammar::me::tcl::inc_save (type symbol , type at) {
    variable loc
    variable nc
    variable ok
    variable error
    variable sv

    if 0 {
    if {[info exists nc($at,$symbol)]} {
        return -code error "Cannot overwrite\
            existing data @ ($at, $symbol)"
    }
    }

    # FIXME - end location should be argument.

    # Store not only the value, but also how far
    # the match went (if it was a match).

    set nc($at,$symbol) [list $loc $ok $error $sv]
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Unconditional matching.*/

ret  ::grammar::me::tcl::iok_ok () {
    variable ok 1
    return
}

ret  ::grammar::me::tcl::iok_fail () {
    variable ok 0
    return
}

ret  ::grammar::me::tcl::iok_negate () {
    variable ok
    set ok [expr {!$ok}]
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Basic input handling and tracking*/

ret  ::grammar::me::tcl::icl_get () {
    variable loc
    return  $loc
}

ret  ::grammar::me::tcl::icl_rewind (type oldloc) {
    variable loc

    if 0 {
    if {($oldloc < -1) || ($oldloc > $loc)} {
        return -code error "Bad location \"$oldloc\" (vs $loc)"
    }
    }
    set loc $oldloc
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Error handling.*/

ret  ::grammar::me::tcl::ier_get () {
    variable error
    return  $error
}

ret  ::grammar::me::tcl::ier_clear () {
    variable error {}
    return
}

ret  ::grammar::me::tcl::ier_nonterminal (type msg , type pos) {
    # Inlined: Errors, Expected.

    variable error

    if {[llength $error]} {
    foreach {l m} $error break
    incr pos
    if {$l == $pos} {
        set error [list $l [list $msg]]
    }
    }
}

ret  ::grammar::me::tcl::ier_merge (type new) {
    variable error

    # We have either old or new error data, keep it.

    if {![llength $error]} {set error $new ; return}
    if {![llength $new]}   {return}

    # If one of the errors is further on in the input choose that as
    # the information to propagate.

    foreach {loe msgse} $error break
    foreach {lon msgsn} $new   break

    if {$lon > $loe} {set error $new ; return}
    if {$loe > $lon} {return}

    # Equal locations, merge the message lists.

    foreach m $msgsn {lappend msgse $m}
    set error [list $loe [lsort -uniq $msgse]]
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Operations for the construction of the*/
/*  abstract syntax tree (AST).*/

ret  ::grammar::me::tcl::isv_clear () {
    variable sv {}
    return
}

ret  ::grammar::me::tcl::isv_terminal () {
    variable loc
    variable sv
    variable as

    set sv [list {} $loc $loc]
    lappend as $sv
    return
}

ret  ::grammar::me::tcl::isv_nonterminal_leaf (type nt , type pos) {
    # Inlined clear, reduce, and optimized.
    variable ok
    variable loc
    variable sv {}

    # Clear ; if {$ok} {Reduce $nt}

    if {$ok} {
    incr pos
    set sv [list $nt $pos $loc]
    }
    return
}

ret  ::grammar::me::tcl::isv_nonterminal_range (type nt , type pos) {
    variable ok
    variable loc
    variable sv {}

    if {$ok} {
    # TerminalString $pos
    # Get all characters after 'pos' to current location as terminal data.

    incr pos
    set sv [list $nt $pos $loc [list {} $pos $loc]]

    #set sv [linsert $sv 0 $nt] ;#Reduce $nt
    }
    return
}

ret  ::grammar::me::tcl::isv_nonterminal_reduce (type nt , type pos , optional mrk =0) {
    variable ok
    variable as
    variable loc
    variable sv {}

    if {$ok} {
    incr pos
    set sv [lrange $as $mrk end]         ;#SaveToMark $mrk
    set sv [linsert $sv 0 $nt $pos $loc] ;#Reduce $nt
    }
    return
}

/*  ### ### ### ######### ######### #########*/
/*  AST stack handling*/

ret  ::grammar::me::tcl::ias_push () {
    variable as
    variable sv
    lappend as $sv
    return
}

ret  ::grammar::me::tcl::ias_mark () {
    variable as
    return [llength $as]
}

ret  ::grammar::me::tcl::ias_pop2mark (type mark) {
    variable as
    if {[llength $as] <= $mark} return
    incr mark -1
    set as [lrange $as 0 $mark]
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Data structures.*/

namespace ::grammar::me::tcl {
    /*  ### ### ### ######### ######### #########*/
    /*  Public State of MVM (Matching Virtual Machine)*/

    variable ok   0  ; /*  Boolean: Ok/Fail of last match operation.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Internal state.*/

    variable ct   {}  ; /*  Current token.*/
    variable loc  0   ; /*  Location of 'ct' as offset in input.*/

    variable error {} ; /*  Error data for last match.*/
    /*                  ; # == List (loc, list of strings)*/
    /*                  ; # or empty list*/
    variable sv   {}  ; /*  Semantic value for last match.*/

    /*  ### ### ### ######### ######### #########*/
    /*  Data structures for AST construction*/

    variable as {} ; /*  Stack of values for AST*/

    /*  ### ### ### ######### ######### #########*/
    /*  Memo data structures for tokens and match results.*/

    variable tc {}
    variable nc ; array  nc =  {}

    /*  ### ### ### ######### ######### #########*/
    /*  Input buffer, location of next character to read.*/
    /*  ASSERT (loc <= cloc)*/

    variable next   ; /*  Callback to get next character.*/

    /*  Token ordering for range checks. Optional*/

    variable tokOrd ; array  tokOrd =  {}
    variable tokUseOrd 0

    /*  ### ### ### ######### ######### #########*/
}

/*  ### ### ### ######### ######### #########*/
/*  Package Management*/

package provide grammar::me::tcl 0.1