can't create object "::pt::rde::oo": command already exists with that name
while executing
"oo::class create ::pt::rde::oo {
# # ## ### ##### ######## ############# #####################
## Instruction counter for tracing. Unused else..."
(in namespace eval "::request" script line 36)
invoked from within
"namespace eval ::request $script"
("::try" body line 12)
OUTPUT BUFFER:
# -*- tcl -*-
#
# Copyright (c) 2009-2015 by Andreas Kupries
# # ## ### ##### ######## ############# #####################
## Package description
## Implementation of the PackRat Machine (PARAM), a virtual machine on
## top of which parsers for Parsing Expression Grammars (PEGs) can be
## realized. This implementation is tied to Tcl for control flow. We
## (will) have alternate implementations written in TclOO, and critcl,
## all exporting the same API.
#
## RD stands for Recursive Descent.
# # ## ### ##### ######## ############# #####################
## Requisites
package require Tcl 8.5
package require TclOO
package require struct::stack 1.5 ; # Requiring peekr, getr, get, trim* methods
package require pt::ast
package require pt::pe
# # ## ### ##### ######## ############# #####################
## Support narrative tracing.
package require debug
debug level pt/rdengine
debug prefix pt/rdengine {}
# # ## ### ##### ######## ############# #####################
## Implementation
oo::class create ::pt::rde::oo {
# # ## ### ##### ######## ############# #####################
## Instruction counter for tracing. Unused else. Plus other helpers.
method TraceInitialization {} {
# Creation of the tracing support procedures.
# Conditional on debug tag "pt/rdengine".
# The instance namespace is the current context.
# This is where the procedures go.
proc Instruction {label {a {}} {b {}}} {
upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
set theinst [list $label $a $b]
return "[uplevel 1 self] <<[format %08d [incr mytracecounter]]>> START I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
}
proc InstReturn {} {
upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
lassign $theinst label a b
return "[uplevel 1 self] <<[format %08d $mytracecounter]>> END__ I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
}
proc State {} {
upvar 1 myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror
set sv [expr {[info exists mysvalue] ? $mysvalue : ""}]
return "ST $myok CL $myloc CC ($mycurrent) SV ($sv) ER ($myerror)"
}
proc TraceSetupStacks {} {
set selfns [namespace current]
# Move stack instances aside.
rename ${selfns}::LOC ${selfns}::LOC__
rename ${selfns}::ERR ${selfns}::ERR__
rename ${selfns}::AST ${selfns}::AST__
rename ${selfns}::MARK ${selfns}::MRK__
# Create procedures doing tracing, and forwarding to
# the renamed actual instances.
interp alias {} ${selfns}::LOC {} ${selfns}::WRAP LS LOC__
interp alias {} ${selfns}::ERR {} ${selfns}::WRAP ES ERR__
interp alias {} ${selfns}::AST {} ${selfns}::WRAP ARS AST__
interp alias {} ${selfns}::MARK {} ${selfns}::WRAP ASM MRK__
proc WRAP {label stack args} {
debug.pt/rdengine { $label ___ $args}
set res [$stack {*}$args]
# Show state state after the op
set n [$stack size]
if {!$n} {
set c {()}
} elseif {$n == 1} {
set c <<[$stack peek $n]>>
} else {
set c <<[join [$stack peek $n] {>> <<}]>>
}
debug.pt/rdengine { $label == ($n):$c}
# And op return
debug.pt/rdengine { $label ==> ($res)}
return $res
}
return
}
return
}
# # ## ### ##### ######## ############# #####################
## API - Lifecycle
constructor {} {
debug.pt/rdengine {[my TraceInitialization][self] constructor}
#set selfns [self namespace]
set mystackloc [struct::stack LOC] ; # LS
set mystackerr [struct::stack ERR] ; # ES
set mystackast [struct::stack AST] ; # ARS/AS
set mystackmark [struct::stack MARK] ; # s.a.
debug.pt/rdengine {[TraceSetupStacks][self] constructor /done}
my reset {}
return
}
method reset {chan} {
debug.pt/rdengine {[self] reset ($chan)}
set mychan $chan ; # IN
set mycurrent {} ; # CC
set myloc -1 ; # CL
set myok 0 ; # ST
set msvalue {} ; # SV
set myerror {} ; # ER
set mytoken {} ; # TC (string)
array unset mysymbol * ; # NC
$mystackloc clear
$mystackerr clear
$mystackast clear
$mystackmark clear
debug.pt/rdengine {[self] reset /done}
return
}
method complete {} {
debug.pt/rdengine {[self] complete [State]}
if {$myok} {
set n [$mystackast size]
debug.pt/rdengine {[self] complete ast $n}
if {$n > 1} {
# Multiple ASTs left, reduce into single containing them.
set pos [$mystackloc peek]
incr pos
set children [$mystackast peekr [$mystackast size]] ; # SaveToMark
set ast [pt::ast new {} $pos $myloc {*}$children] ; # Reduce ALL
debug.pt/rdengine {[self] complete n ==> ($ast)}
return $ast
} elseif {$n == 0} {
# Match, but no AST. This is possible if the grammar
# consists of only the start expression.
debug.pt/rdengine {[self] complete 0 ==> ()}
return {}
} else {
# Match, with AST.
set ast [$mystackast peek]
debug.pt/rdengine {[self] complete 1 ==> ($ast)}
return $ast
}
} else {
lassign $myerror loc messages
return -code error \
-errorcode {PT RDE SYNTAX} \
[list pt::rde $loc $messages]
}
}
# # ## ### ##### ######## ############# #####################
## API - State accessors
method chan {} { debug.pt/rdengine {[self] chan} ; return $mychan }
# - - -- --- ----- --------
method current {} { debug.pt/rdengine {[self] current} ; return $mycurrent }
method location {} { debug.pt/rdengine {[self] location} ; return $myloc }
method lmarked {} { debug.pt/rdengine {[self] lmarked} ; return [$mystackloc getr] }
# - - -- --- ----- --------
method ok {} { debug.pt/rdengine {[self] ok} ; return $myok }
method value {} { debug.pt/rdengine {[self] value} ; return $mysvalue }
method error {} { debug.pt/rdengine {[self] error} ; return $myerror }
method emarked {} { debug.pt/rdengine {[self] emarked} ; return [$mystackerr getr] }
# - - -- --- ----- --------
method tokens {{from {}} {to {}}} {
debug.pt/rdengine {[self] tokens ($from) ($to)}
switch -exact [llength [info level 0]] {
4 { return $mytoken }
5 { return [string range $mytoken $from $from] }
6 { return [string range $mytoken $from $to] }
}
}
method symbols {} {
debug.pt/rdengine {[self] symbols}
return [array get mysymbol]
}
method scached {} {
debug.pt/rdengine {[self] scached}
return [array names mysymbol]
}
# - - -- --- ----- --------
method asts {} { debug.pt/rdengine {[self] asts} ; return [$mystackast getr] }
method amarked {} { debug.pt/rdengine {[self] amarked} ; return [$mystackmark getr] }
method ast {} { debug.pt/rdengine {[self] ast} ; return [$mystackast peek] }
# # ## ### ##### ######## ############# #####################
## API - Preloading the token cache.
method data {string} {
debug.pt/rdengine {[self] data +[string length $string]}
append mytoken $string
return
}
# # ## ### ##### ######## ############# #####################
## Common instruction sequences
method si:void_state_push {} {
debug.pt/rdengine {[Instruction si:void_state_push]}
# i_loc_push
# i_error_clear_push
$mystackloc push $myloc
set myerror {}
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
method si:void2_state_push {} {
debug.pt/rdengine {[Instruction si:void2_state_push]}
# i_loc_push
# i_error_push
$mystackloc push $myloc
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_state_push {} {
debug.pt/rdengine {[Instruction si:value_state_push]}
# i_ast_push
# i_loc_push
# i_error_clear_push
$mystackmark push [$mystackast size]
$mystackloc push $myloc
set myerror {}
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:void_state_merge {} {
debug.pt/rdengine {[Instruction si:void_state_merge]}
# i_error_pop_merge
# i_loc_pop_rewind/discard
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
set last [$mystackloc pop]
if {!$myok} {
set myloc $last
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_state_merge_ok {} {
debug.pt/rdengine {[Instruction si:void_state_merge_ok]}
# i_error_pop_merge
# i_loc_pop_rewind/discard
# i_status_ok
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
set last [$mystackloc pop]
if {!$myok} {
set myloc $last
set myok 1
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_state_merge {} {
debug.pt/rdengine {[Instruction si:value_state_merge]}
# i_error_pop_merge
# i_ast_pop_rewind/discard
# i_loc_pop_rewind/discard
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
set mark [$mystackmark pop]
set last [$mystackloc pop]
if {!$myok} {
$mystackast trim* $mark
set myloc $last
}
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:value_notahead_start {} {
debug.pt/rdengine {[Instruction si:value_notahead_start]}
# i_loc_push
# i_ast_push
$mystackloc push $myloc
$mystackmark push [$mystackast size]
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_notahead_exit {} {
debug.pt/rdengine {[Instruction si:void_notahead_exit]}
# i_loc_pop_rewind
# i_status_negate
set myloc [$mystackloc pop]
set myok [expr {!$myok}]
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_notahead_exit {} {
debug.pt/rdengine {[Instruction si:value_notahead_exit]}
# i_ast_pop_discard/rewind
# i_loc_pop_rewind
# i_status_negate
set mark [$mystackmark pop]
if {$myok} {
$mystackast trim* $mark
}
set myloc [$mystackloc pop]
set myok [expr {!$myok}]
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:kleene_abort {} {
debug.pt/rdengine {[Instruction si:kleene_abort]}
# i_loc_pop_rewind/discard
# i:fail_return
set last [$mystackloc pop]
if {$myok} {
debug.pt/rdengine {[InstReturn]}
return
}
set myloc $last
debug.pt/rdengine {[InstReturn]}
return -code return
}
method si:kleene_close {} {
debug.pt/rdengine {[Instruction si:kleene_close]}
# i_error_pop_merge
# i_loc_pop_rewind/discard
# i:fail_status_ok
# i:fail_return
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
set last [$mystackloc pop]
if {$myok} {
debug.pt/rdengine {[InstReturn]}
return
}
set myok 1
set myloc $last
debug.pt/rdengine {[InstReturn]}
return -code return
}
# - -- --- ----- -------- ------------- ---------------------
method si:voidvoid_branch {} {
debug.pt/rdengine {[Instruction si:voidvoid_branch]}
# i_error_pop_merge
# i:ok_loc_pop_discard
# i:ok_return
# i_loc_rewind
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {$myok} {
$mystackloc pop
debug.pt/rdengine {[InstReturn]}
return -code return
}
set myloc [$mystackloc peek]
$mystackerr push $myerror
debug.pt/rdengine {[InstReturn]}
return
}
method si:voidvalue_branch {} {
debug.pt/rdengine {[Instruction si:voidvalue_branch]}
# i_error_pop_merge
# i:ok_loc_pop_discard
# i:ok_return
# i_ast_push
# i_loc_rewind
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {$myok} {
$mystackloc pop
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackmark push [$mystackast size]
set myloc [$mystackloc peek]
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
method si:valuevoid_branch {} {
debug.pt/rdengine {[Instruction si:valuevoid_branch]}
# i_error_pop_merge
# i_ast_pop_rewind/discard
# i:ok_loc_pop_discard
# i:ok_return
# i_loc_rewind
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
set mark [$mystackmark pop]
if {$myok} {
$mystackloc pop
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackast trim* $mark
set myloc [$mystackloc peek]
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
method si:valuevalue_branch {} {
debug.pt/rdengine {[Instruction si:valuevalue_branch]}
# i_error_pop_merge
# i_ast_pop_discard
# i:ok_loc_pop_discard
# i:ok_return
# i_ast_rewind
# i_loc_rewind
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {$myok} {
$mystackmark pop
$mystackloc pop
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackast trim* [$mystackmark peek]
set myloc [$mystackloc peek]
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:voidvoid_part {} {
debug.pt/rdengine {[Instruction si:voidvoid_part]}
# i_error_pop_merge
# i:fail_loc_pop_rewind
# i:fail_return
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {!$myok} {
set myloc [$mystackloc pop]
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackerr push $myerror
debug.pt/rdengine {[InstReturn]}
return
}
method si:voidvalue_part {} {
debug.pt/rdengine {[Instruction si:voidvalue_part]}
# i_error_pop_merge
# i:fail_loc_pop_rewind
# i:fail_return
# i_ast_push
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {!$myok} {
set myloc [$mystackloc pop]
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackmark push [$mystackast size]
$mystackerr push $myerror
debug.pt/rdengine {[InstReturn]}
return
}
method si:valuevalue_part {} {
debug.pt/rdengine {[Instruction si:valuevalue_part]}
# i_error_pop_merge
# i:fail_ast_pop_rewind
# i:fail_loc_pop_rewind
# i:fail_return
# i_error_push
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} {
set myerror $olderror
} elseif {[llength $olderror]} {
# If one of the errors is further on in the input choose
# that as the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} {
set myerror $olderror
} elseif {$loe == $lon} {
# Equal locations, merge the message lists, set-like.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
}
}
if {!$myok} {
$mystackast trim* [$mystackmark pop]
set myloc [$mystackloc pop]
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackerr push $myerror
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:next_str {tok} {
debug.pt/rdengine {[Instruction si:next_str $tok]}
# String = sequence of characters.
# No need for all the intermediate stack churn.
set n [string length $tok]
set last [expr {$myloc + $n}]
set max [string length $mytoken]
incr myloc
if {($last >= $max) && ![my ExtendTCN [expr {$last - $max + 1}]]} {
set myok 0
set myerror [list $myloc [list [list str $tok]]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set lex [string range $mytoken $myloc $last]
set mycurrent [string index $mytoken $last]
# ATTENTION: The error output of this instruction is different
# from a regular sequence of si:next_char instructions. The
# error location will be the start of the string token we
# wanted to match, and the message will contain the entire
# string token. In the regular sequence we would see the exact
# point of the mismatch instead, with the message containing
# the expected character.
set myok [expr {$tok eq $lex}]
if {$myok} {
set myloc $last
set myerror {}
} else {
set myerror [list $myloc [list [list str $tok]]]
incr myloc -1
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_class {tok} {
debug.pt/rdengine {[Instruction si:next_class $tok]}
# Class = Choice of characters. No need for stack churn.
# i_input_next "\{t $c\}"
# i:fail_return
# i_test_
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list [list cl $tok]]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
# Note what is needle versus hay. The token, i.e. the string
# of allowed characters is the hay in which the current
# character is looked, making it the needle.
set myok [expr {[string first $mycurrent $tok] >= 0}]
if {$myok} {
set myerror {}
} else {
set myerror [list $myloc [list [list cl $tok]]]
incr myloc -1
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_char {tok} {
debug.pt/rdengine {[Instruction si:next_char $tok]}
# i_input_next "\{t $c\}"
# i:fail_return
# i_test_char $c
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list [list t $tok]]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [expr {$tok eq $mycurrent}]
if {$myok} {
set myerror {}
} else {
set myerror [list $myloc [list [list t $tok]]]
incr myloc -1
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_range {toks toke} {
debug.pt/rdengine {[Instruction si:next_range $toks $toke]}
#Asm::Ins i_input_next "\{.. $s $e\}"
#Asm::Ins i:fail_return
#Asm::Ins i_test_range $s $e
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list [list .. $toks $toke]]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [expr {
([string compare $toks $mycurrent] <= 0) &&
([string compare $mycurrent $toke] <= 0)
}] ; # {}
if {$myok} {
set myerror {}
} else {
set myerror [list $myloc [list [pt::pe range $toks $toke]]]
incr myloc -1
}
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:next_alnum {} {
debug.pt/rdengine {[Instruction si:next_alnum]}
#Asm::Ins i_input_next alnum
#Asm::Ins i:fail_return
#Asm::Ins i_test_alnum
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list alnum]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is alnum -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list alnum]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_alpha {} {
debug.pt/rdengine {[Instruction si:next_alpha]}
#Asm::Ins i_input_next alpha
#Asm::Ins i:fail_return
#Asm::Ins i_test_alpha
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list alpha]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is alpha -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list alpha]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_ascii {} {
debug.pt/rdengine {[Instruction si:next_ascii]}
#Asm::Ins i_input_next ascii
#Asm::Ins i:fail_return
#Asm::Ins i_test_ascii
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list ascii]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is ascii -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list ascii]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_control {} {
debug.pt/rdengine {[Instruction si:next_control]}
#Asm::Ins i_input_next control
#Asm::Ins i:fail_return
#Asm::Ins i_test_control
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list control]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is control -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list control]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_ddigit {} {
debug.pt/rdengine {[Instruction si:next_ddigit]}
#Asm::Ins i_input_next ddigit
#Asm::Ins i:fail_return
#Asm::Ins i_test_ddigit
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list ddigit]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string match {[0-9]} $mycurrent]
if {!$myok} {
set myerror [list $myloc [list ddigit]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_digit {} {
debug.pt/rdengine {[Instruction si:next_digit]}
#Asm::Ins i_input_next digit
#Asm::Ins i:fail_return
#Asm::Ins i_test_digit
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list digit]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is digit -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list digit]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_graph {} {
debug.pt/rdengine {[Instruction si:next_graph]}
#Asm::Ins i_input_next graph
#Asm::Ins i:fail_return
#Asm::Ins i_test_graph
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list graph]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is graph -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list graph]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_lower {} {
debug.pt/rdengine {[Instruction si:next_lower]}
#Asm::Ins i_input_next lower
#Asm::Ins i:fail_return
#Asm::Ins i_test_lower
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list lower]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is lower -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list lower]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_print {} {
debug.pt/rdengine {[Instruction si:next_print]}
#Asm::Ins i_input_next print
#Asm::Ins i:fail_return
#Asm::Ins i_test_print
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list print]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is print -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list print]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_punct {} {
debug.pt/rdengine {[Instruction si:next_punct]}
#Asm::Ins i_input_next punct
#Asm::Ins i:fail_return
#Asm::Ins i_test_punct
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list punct]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is punct -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list punct]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_space {} {
debug.pt/rdengine {[Instruction si:next_space]}
#Asm::Ins i_input_next space
#Asm::Ins i:fail_return
#Asm::Ins i_test_space
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list space]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is space -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list space]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_upper {} {
debug.pt/rdengine {[Instruction si:next_upper]}
#Asm::Ins i_input_next upper
#Asm::Ins i:fail_return
#Asm::Ins i_test_upper
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list upper]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is upper -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list upper]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_wordchar {} {
debug.pt/rdengine {[Instruction si:next_wordchar]}
#Asm::Ins i_input_next wordchar
#Asm::Ins i:fail_return
#Asm::Ins i_test_wordchar
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list wordchar]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is wordchar -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list wordchar]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:next_xdigit {} {
debug.pt/rdengine {[Instruction si:next_xdigit]}
#Asm::Ins i_input_next xdigit
#Asm::Ins i:fail_return
#Asm::Ins i_test_xdigit
incr myloc
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list xdigit]]
# i:fail_return
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok [string is xdigit -strict $mycurrent]
if {!$myok} {
set myerror [list $myloc [list xdigit]]
incr myloc -1
} else {
set myerror {}
}
debug.pt/rdengine {[InstReturn]}
return
}
# - -- --- ----- -------- ------------- ---------------------
method si:value_symbol_start {symbol} {
debug.pt/rdengine {[Instruction si:value_symbol_start $symbol]}
# if @runtime@ i_symbol_restore $symbol
# i:found:ok_ast_value_push
# i:found_return
# i_loc_push
# i_ast_push
set k [list $myloc $symbol]
if {[info exists mysymbol($k)]} {
lassign $mysymbol($k) myloc myok myerror mysvalue
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackloc push $myloc
$mystackmark push [$mystackast size]
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_void_symbol_start {symbol} {
debug.pt/rdengine {[Instruction si:value_void_symbol_start $symbol]}
# if @runtime@ i_symbol_restore $symbol
# i:found_return
# i_loc_push
# i_ast_push
set k [list $myloc $symbol]
if {[info exists mysymbol($k)]} {
lassign $mysymbol($k) myloc myok myerror mysvalue
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackloc push $myloc
$mystackmark push [$mystackast size]
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_symbol_start {symbol} {
debug.pt/rdengine {[Instruction si:void_symbol_start $symbol]}
# if @runtime@ i_symbol_restore $symbol
# i:found:ok_ast_value_push
# i:found_return
# i_loc_push
set k [list $myloc $symbol]
if {[info exists mysymbol($k)]} {
lassign $mysymbol($k) myloc myok myerror mysvalue
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackloc push $myloc
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_void_symbol_start {symbol} {
debug.pt/rdengine {[Instruction si:void_void_symbol_start $symbol]}
# if @runtime@ i_symbol_restore $symbol
# i:found_return
# i_loc_push
set k [list $myloc $symbol]
if {[info exists mysymbol($k)]} {
lassign $mysymbol($k) myloc myok myerror mysvalue
debug.pt/rdengine {[InstReturn]}
return -code return
}
$mystackloc push $myloc
debug.pt/rdengine {[InstReturn]}
return
}
method si:reduce_symbol_end {symbol} {
debug.pt/rdengine {[Instruction si:reduce_symbol_end $symbol]}
# i_value_clear/reduce $symbol
# i_symbol_save $symbol
# i_error_nonterminal $symbol
# i_ast_pop_rewind
# i_loc_pop_discard
# i:ok_ast_value_push
set mysvalue {}
set at [$mystackloc pop]
if {$myok} {
set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
set newa [expr {[$mystackast size] - $mark}]
set pos $at
incr pos
if {!$newa} {
set mysvalue {}
} elseif {$newa == 1} {
# peek 1 => single element comes back
set mysvalue [list [$mystackast peek]] ; # SaveToMark
} else {
# peek n > 1 => list of elements comes back
set mysvalue [$mystackast peekr $newa] ; # SaveToMark
}
if {$at == $myloc} {
# The symbol did not process any input. As this is
# signaled to be ok (*) we create a node covering an
# empty range. (Ad *): Can happen for a RHS using
# toplevel operators * or ?.
set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
} else {
set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
}
}
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
# si:reduce_symbol_end / i_error_nonterminal -- inlined -- disabled
if {0} {if {[llength $myerror]} {
set pos $at
incr pos
lassign $myerror loc messages
if {$loc == $pos} {
set myerror [list $loc [list [list n $symbol]]]
}
}}
$mystackast trim* [$mystackmark pop]
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_leaf_symbol_end {symbol} {
debug.pt/rdengine {[Instruction si:void_leaf_symbol_end $symbol]}
# i_value_clear/leaf $symbol
# i_symbol_save $symbol
# i_error_nonterminal $symbol
# i_loc_pop_discard
# i:ok_ast_value_push
set mysvalue {}
set at [$mystackloc pop]
if {$myok} {
set pos $at
incr pos
if {$at == $myloc} {
# The symbol did not process any input. As this is
# signaled to be ok (*) we create a node covering an
# empty range. (Ad *): Can happen for a RHS using
# toplevel operators * or ?.
set mysvalue [pt::ast new0 $symbol $pos]
} else {
set mysvalue [pt::ast new $symbol $pos $myloc]
}
}
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
# si:void_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
if {0} {if {[llength $myerror]} {
set pos $at
incr pos
lassign $myerror loc messages
if {$loc == $pos} {
set myerror [list $loc [list [list n $symbol]]]
}
}}
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_leaf_symbol_end {symbol} {
debug.pt/rdengine {[Instruction si:value_leaf_symbol_end $symbol]}
# i_value_clear/leaf $symbol
# i_symbol_save $symbol
# i_error_nonterminal $symbol
# i_loc_pop_discard
# i_ast_pop_rewind
# i:ok_ast_value_push
set mysvalue {}
set at [$mystackloc pop]
if {$myok} {
set pos $at
incr pos
if {$at == $myloc} {
# The symbol did not process any input. As this is
# signaled to be ok (*) we create a node covering an
# empty range. (Ad *): Can happen for a RHS using
# toplevel operators * or ?.
set mysvalue [pt::ast new0 $symbol $pos]
} else {
set mysvalue [pt::ast new $symbol $pos $myloc]
}
}
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
# si:value_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
if {0} {if {[llength $myerror]} {
set pos $at
incr pos
lassign $myerror loc messages
if {$loc == $pos} {
set myerror [list $loc [list [list n $symbol]]]
}
}}
$mystackast trim* [$mystackmark pop]
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return
}
method si:value_clear_symbol_end {symbol} {
debug.pt/rdengine {[Instruction si:value_clear_symbol_end $symbol]}
# i_value_clear
# i_symbol_save $symbol
# i_error_nonterminal $symbol
# i_loc_pop_discard
# i_ast_pop_rewind
set mysvalue {}
set at [$mystackloc pop]
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
# si:value_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
if {0} {if {[llength $myerror]} {
set pos $at
incr pos
lassign $myerror loc messages
if {$loc == $pos} {
set myerror [list $loc [list [list n $symbol]]]
}
}}
$mystackast trim* [$mystackmark pop]
debug.pt/rdengine {[InstReturn]}
return
}
method si:void_clear_symbol_end {symbol} {
debug.pt/rdengine {[Instruction si:void_clear_symbol_end $symbol]}
# i_value_clear
# i_symbol_save $symbol
# i_error_nonterminal $symbol
# i_loc_pop_discard
set mysvalue {}
set at [$mystackloc pop]
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
# si:void_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
if {0} {if {[llength $myerror]} {
set pos $at
incr pos
lassign $myerror loc messages
if {$loc == $pos} {
set myerror [list $loc [list [list n $symbol]]]
}
}}
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Control flow
method i:ok_continue {} {
debug.pt/rdengine {[Instruction i:ok_continue]}
if {!$myok} return
return -code continue
}
method i:fail_continue {} {
debug.pt/rdengine {[Instruction i:fail_continue]}
if {$myok} return
return -code continue
}
method i:fail_return {} {
debug.pt/rdengine {[Instruction i:fail_return]}
if {$myok} return
return -code return
}
method i:ok_return {} {
debug.pt/rdengine {[Instruction i:ok_return]}
if {!$myok} return
return -code return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Unconditional matching.
method i_status_ok {} {
debug.pt/rdengine {[Instruction i_status_ok]}
set myok 1
debug.pt/rdengine {[InstReturn]}
return
}
method i_status_fail {} {
debug.pt/rdengine {[Instruction i_status_fail]}
set myok 0
debug.pt/rdengine {[InstReturn]}
return
}
method i_status_negate {} {
debug.pt/rdengine {[Instruction i_status_negate]}
set myok [expr {!$myok}]
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Error handling.
method i_error_clear {} {
debug.pt/rdengine {[Instruction i_error_clear]}
set myerror {}
debug.pt/rdengine {[InstReturn]}
return
}
method i_error_push {} {
debug.pt/rdengine {[Instruction i_error_push]}
$mystackerr push $myerror
debug.pt/rdengine {[InstReturn]}
return
}
method i_error_clear_push {} {
debug.pt/rdengine {[Instruction i_error_clear_push]}
set myerror {}
$mystackerr push {}
debug.pt/rdengine {[InstReturn]}
return
}
method i_error_pop_merge {} {
debug.pt/rdengine {[Instruction i_error_pop_merge]}
set olderror [$mystackerr pop]
# We have either old or new error data, keep it.
if {![llength $myerror]} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
if {![llength $olderror]} { debug.pt/rdengine {[InstReturn]} ; return }
# If one of the errors is further on in the input choose that as
# the information to propagate.
lassign $myerror loe msgse
lassign $olderror lon msgsn
if {$lon > $loe} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
if {$loe > $lon} { debug.pt/rdengine {[InstReturn]} ; return }
# Equal locations, merge the message lists.
set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
debug.pt/rdengine {[InstReturn]}
return
}
method i_error_nonterminal {symbol} {
debug.pt/rdengine {[Instruction i_error_nonterminal $symbol]}
# i_error_nonterminal -- Disabled. Generate only low-level
# i_error_nonterminal -- errors until we have worked out how
# i_error_nonterminal -- to integrate symbol information with
# i_error_nonterminal -- them. Do not forget where this
# i_error_nonterminal -- instruction is inlined.
return
# Inlined: Errors, Expected.
if {![llength $myerror]} {
debug.pt/rdengine {no error}
return
}
set pos [$mystackloc peek]
incr pos
lassign $myerror loc messages
if {$loc != $pos} {
debug.pt/rdengine {my $myerror != pos $pos}
return
}
set myerror [list $loc [list [list n $symbol]]]
debug.pt/rdengine {::= ($myerror)}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Basic input handling and tracking
method i_loc_pop_rewind/discard {} {
debug.pt/rdengine {[Instruction i_loc_pop_rewind/discard]}
#$myparser i:fail_loc_pop_rewind
#$myparser i:ok_loc_pop_discard
#return
set last [$mystackloc pop]
if {!$myok} {
set myloc $last
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_loc_pop_discard {} {
debug.pt/rdengine {[Instruction i_loc_pop_discard]}
$mystackloc pop
debug.pt/rdengine {[InstReturn]}
return
}
# i:ok_loc_pop_discard - all uses inlined
method i_loc_pop_rewind {} {
debug.pt/rdengine {[Instruction i_loc_pop_rewind]}
set myloc [$mystackloc pop]
debug.pt/rdengine {[InstReturn]}
return
}
method i:fail_loc_pop_rewind {} {
debug.pt/rdengine {[Instruction i:fail_loc_pop_rewind]}
if {!$myok} {
set myloc [$mystackloc pop]
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_loc_push {} {
debug.pt/rdengine {[Instruction i_loc_push]}
$mystackloc push $myloc
debug.pt/rdengine {[InstReturn]}
return
}
method i_loc_rewind {} {
debug.pt/rdengine {[Instruction i_loc_rewind]}
# i_loc_pop_rewind - set myloc [$mystackloc pop]
# i_loc_push - $mystackloc push $myloc
set myloc [$mystackloc peek]
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - AST stack handling
method i_ast_pop_rewind/discard {} {
debug.pt/rdengine {[Instruction i_ast_pop_rewind/discard]}
#$myparser i:fail_ast_pop_rewind
#$myparser i:ok_ast_pop_discard
#return
set mark [$mystackmark pop]
if {!$myok} {
$mystackast trim* $mark
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_ast_pop_discard/rewind {} {
debug.pt/rdengine {[Instruction i_ast_pop_discard/rewind]}
#$myparser i:ok_ast_pop_rewind
#$myparser i:fail_ast_pop_discard
#return
set mark [$mystackmark pop]
if {$myok} {
$mystackast trim* $mark
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_ast_pop_discard {} {
debug.pt/rdengine {[Instruction i_ast_pop_discard]}
$mystackmark pop
debug.pt/rdengine {[InstReturn]}
return
}
# i:ok_ast_pop_discard - all uses inlined
method i_ast_pop_rewind {} {
debug.pt/rdengine {[Instruction i_ast_pop_rewind]}
$mystackast trim* [$mystackmark pop]
debug.pt/rdengine {[InstReturn]}
return
}
method i:fail_ast_pop_rewind {} {
debug.pt/rdengine {[Instruction i:fail_ast_pop_rewind]}
if {!$myok} {
$mystackast trim* [$mystackmark pop]
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_ast_push {} {
debug.pt/rdengine {[Instruction i_ast_push]}
$mystackmark push [$mystackast size]
debug.pt/rdengine {[InstReturn]}
return
}
method i:ok_ast_value_push {} {
debug.pt/rdengine {[Instruction i:ok_ast_value_push]}
if {$myok} {
$mystackast push $mysvalue
}
debug.pt/rdengine {[InstReturn]}
return
}
# i_ast_rewind - all uses inlined
# # ## ### ##### ######## ############# #####################
## API - Instructions - Nonterminal cache
method i_symbol_restore {symbol} {
debug.pt/rdengine {[Instruction i_symbol_restore $symbol]}
# Satisfy from cache if possible.
set k [list $myloc $symbol]
if {![info exists mysymbol($k)]} {
debug.pt/rdengine {[InstReturn]}
return 0
}
lassign $mysymbol($k) myloc myok myerror mysvalue
# We go forward, as the nonterminal matches (or not).
debug.pt/rdengine {[InstReturn]}
return 1
}
method i_symbol_save {symbol} {
debug.pt/rdengine {[Instruction i_symbol_save $symbol]}
# Store not only the value, but also how far
# the match went (if it was a match).
set at [$mystackloc peek]
set k [list $at $symbol]
set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Semantic values.
method i_value_clear {} {
debug.pt/rdengine {[Instruction i_value_clear]}
set mysvalue {}
debug.pt/rdengine {[InstReturn]}
return
}
method i_value_clear/leaf {symbol} {
debug.pt/rdengine {[Instruction i_value_clear/leaf $symbol] :: ([expr {[$mystackloc peek]+1}])-@$myloc)}
# not quite value_lead (guarded, and clear on fail)
# Inlined clear, reduce, and optimized.
# Clear ; if {$ok} {Reduce $symbol}
set mysvalue {}
if {$myok} {
set pos [$mystackloc peek]
incr pos
if {($pos - 1) == $myloc} {
# The symbol did not process any input. As this is
# signaled to be ok (*) we create a node covering an
# empty range. (Ad *): Can happen for a RHS using
# toplevel operators * or ?.
set mysvalue [pt::ast new0 $symbol $pos]
} else {
set mysvalue [pt::ast new $symbol $pos $myloc]
}
}
debug.pt/rdengine {[InstReturn]}
return
}
method i_value_clear/reduce {symbol} {
debug.pt/rdengine {[Instruction i_value_clear/reduce $symbol]}
set mysvalue {}
if {$myok} {
set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
set newa [expr {[$mystackast size] - $mark}]
set pos [$mystackloc peek]
incr pos
if {!$newa} {
set mysvalue {}
} elseif {$newa == 1} {
# peek 1 => single element comes back
set mysvalue [list [$mystackast peek]] ; # SaveToMark
} else {
# peek n > 1 => list of elements comes back
set mysvalue [$mystackast peekr $newa] ; # SaveToMark
}
if {($pos - 1) == $myloc} {
# The symbol did not process any input. As this is
# signaled to be ok (*) we create a node covering an
# empty range. (Ad *): Can happen for a RHS using
# toplevel operators * or ?.
set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
} else {
set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
}
}
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## API - Instructions - Terminal matching
method i_input_next {msg} {
debug.pt/rdengine {[Instruction i_input_next $msg]}
# Inlined: Getch, Expected, ClearErrors
# Satisfy from input cache if possible.
incr myloc
# May read from the input (ExtendTC), and remember the
# information. Note: We are implicitly incrementing the
# location!
if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
set myok 0
set myerror [list $myloc [list $msg]]
debug.pt/rdengine {[InstReturn]}
return
}
set mycurrent [string index $mytoken $myloc]
set myok 1
set myerror {}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_char {tok} {
debug.pt/rdengine {[Instruction i_test_char $tok] :: ok [expr {$tok eq $mycurrent}], [expr {$tok eq $mycurrent ? "@$myloc" : "back@[expr {$myloc-1}]"}]}
set myok [expr {$tok eq $mycurrent}]
my OkFailD {pt::pe terminal $tok}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_range {toks toke} {
debug.pt/rdengine {[Instruction i_test_range $toks $toke]}
set myok [expr {
([string compare $toks $mycurrent] <= 0) &&
([string compare $mycurrent $toke] <= 0)
}] ; # {}
my OkFailD {pt::pe range $toks $toke}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_alnum {} {
debug.pt/rdengine {[Instruction i_test_alnum]}
set myok [string is alnum -strict $mycurrent]
my OkFailD {pt::pe alnum}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_alpha {} {
debug.pt/rdengine {[Instruction i_test_alpha]}
set myok [string is alpha -strict $mycurrent]
my OkFailD {pt::pe alpha}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_ascii {} {
debug.pt/rdengine {[Instruction i_test_ascii]}
set myok [string is ascii -strict $mycurrent]
my OkFailD {pt::pe ascii}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_control {} {
debug.pt/rdengine {[Instruction i_test_control]}
set myok [string is control -strict $mycurrent]
my OkFailD {pt::pe control}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_ddigit {} {
debug.pt/rdengine {[Instruction i_test_ddigit]}
set myok [string match {[0-9]} $mycurrent]
my OkFailD {pt::pe ddigit}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_digit {} {
debug.pt/rdengine {[Instruction i_test_digit]}
set myok [string is digit -strict $mycurrent]
my OkFailD {pt::pe digit}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_graph {} {
debug.pt/rdengine {[Instruction i_test_graph]}
set myok [string is graph -strict $mycurrent]
my OkFailD {pt::pe graph}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_lower {} {
debug.pt/rdengine {[Instruction i_test_lower]}
set myok [string is lower -strict $mycurrent]
my OkFailD {pt::pe lower}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_print {} {
debug.pt/rdengine {[Instruction i_test_print]}
set myok [string is print -strict $mycurrent]
my OkFailD {pt::pe printable}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_punct {} {
debug.pt/rdengine {[Instruction i_test_punct]}
set myok [string is punct -strict $mycurrent]
my OkFailD {pt::pe punct}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_space {} {
debug.pt/rdengine {[Instruction i_test_space]}
set myok [string is space -strict $mycurrent]
my OkFailD {pt::pe space}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_upper {} {
debug.pt/rdengine {[Instruction i_test_upper]}
set myok [string is upper -strict $mycurrent]
my OkFailD {pt::pe upper}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_wordchar {} {
debug.pt/rdengine {[Instruction i_test_wordchar]}
set myok [string is wordchar -strict $mycurrent]
my OkFailD {pt::pe wordchar}
debug.pt/rdengine {[InstReturn]}
return
}
method i_test_xdigit {} {
debug.pt/rdengine {[Instruction i_test_xdigit]}
set myok [string is xdigit -strict $mycurrent]
my OkFailD {pt::pe xdigit}
debug.pt/rdengine {[InstReturn]}
return
}
# # ## ### ##### ######## ############# #####################
## Internals
method ExtendTC {} {
if {($mychan eq {}) ||
[eof $mychan]} {return 0}
set ch [read $mychan 1]
if {$ch eq {}} {
return 0
}
append mytoken $ch
return 1
}
method ExtendTCN {n} {
if {($mychan eq {}) ||
[eof $mychan]} {return 0}
set str [read $mychan $n]
set k [string length $str]
append mytoken $str
if {$k < $n} {
return 0
}
return 1
}
method OkFailD {msgcmd} {
# Inlined: Expected, Unget, ClearErrors
if {!$myok} {
set myerror [list $myloc [list [uplevel 1 $msgcmd]]]
incr myloc -1
} else {
set myerror {}
}
return
}
# # ## ### ##### ######## ############# #####################
## Data structures.
## Mainly the architectural state of the instance's PARAM.
variable \
mychan mycurrent myloc mystackloc \
myok mysvalue myerror mystackerr \
mytoken mysymbol mystackast mystackmark \
mytracecounter
# Parser Input (channel, location (line, column)) ...........
# Token, current parsing location, stack of locations .......
# Match state . ........ ............. .....................
# Caches for tokens and nonterminals .. .....................
# Abstract syntax tree (AST) .......... .....................
# # ## ### ##### ######## ############# #####################
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide pt::rde::oo 1.1
return