Tcl Library Source Code

Artifact [119bfcc5ef]
Login

Artifact 119bfcc5efc8b24d5dda02b2ed604becae08d55f021bbd321a789a079db0b378:

Attachment "ffp.tcl" to ticket [3ed39a451f] added by ssoberni 2017-10-06 13:17:20.
package req nx
package require pt::pgen

## Tiny example from:
##
## Maidl, A. M., Mascarenhas, F., & Ierusalimschy,
## R. (2013). Exception Handling for Error Reporting in Parsing
## Expression Grammars. In: Proc. 17th Brazilian Symposium
## Programming Languages (SBLP 2013) (pp. 1--15). Springer.
##

set grammar {
PEG Tiny (CmdSeq) 
 	CmdSeq 		<- Cmd SEMICOLON (Cmd SEMICOLON)*;
	Cmd 		<- Skip ((IfCmd / RepeatCmd / AssignCmd / ReadCmd / WriteCmd)) Skip;
	IfCmd 		<- 'if' Exp 'then' CmdSeq ('else' CmdSeq)? 'end';
	RepeatCmd 	<- 'repeat' CmdSeq 'until' Exp;
	AssignCmd 	<- Name ASSIGNMENT Exp;
	ReadCmd 	<- 'read' Skip Name;
	WriteCmd 	<- 'write' Skip Exp;
void:   SEMICOLON       <- Skip ';' Skip;
leaf:   ASSIGNMENT      <- Skip ':=' Skip;
	Name 		<- 'n' / 'f';
	Exp 		<- Operand Skip (('*' / '-' / '+' / '>' / '<') Operand)?;
	Operand 	<- Skip (Name / <digit>) Skip;
void:   Skip 	        <- <space>*;
END;
}

try [pt::pgen peg $grammar nx -class TinyParser -name TinyGrammar] on return {} {}

proc parse {p} {
    set tp [TinyParser new]
    try {
	set ast [$tp parset $p]
	lassign $ast nt start end
	puts prefix='[string range $p 0 $end]'
	puts suffix='[string range $p [expr {$end+1}] [string length $p]]'
    } on error {e} {
	puts err='$err'
    } on ok {r} {
	puts myerror=[$tp eval {set :myerror}]
    } finally {
	$tp destroy
    }
}

# correct tiny prog: 'suffix eq epsilon ("")' equiv 'prefix eq input'
parse {
  n := 5;
  f := 1;
  repeat
    f := f * n;
    n := n - 1;
  until n < 1;
  write f;
}

# incorrect tiny prog (missing ';' within 'repeat' block at line 5):
# suffix ne epsilon ("") equiv 'prefix ne input'
parse {
  n := 5;
  f := 1;
  repeat
    f := f * n;
    n := n - 1
  until n < 1;
  write f;
}

## -> myerror and suffix are pointing to the beginning of the 'repeat'
## -> statement; rather than the cmd at line 5.

## minimal FFP support

nx::Class create FFP {
    :variable ffp [list]

    # FFP: available on [complete]
    :public method complete {} {
	puts FFP=${:ffp}
	next
    }

    # FFP: actual FFP recording in the spirit of "i_error_pop_merge",
    # without popping, naturally. At this point, "myerror", if
    # available, carries a previously popped error-stack element.
    :method updateFFP {} {
      if {![llength ${:ffp}]} {
        set :ffp ${:myerror}; return
      }
      
      if {![llength ${:myerror}]} {
        return
      }
      
      lassign ${:myerror} currentErrPos currentErrMsg
      lassign ${:ffp} prevFfpPos prevFfpMsg
      
      if {$prevFfpPos > $currentErrPos} { return; }
      if {$currentErrPos > $prevFfpPos} {
        set :ffp ${:myerror}
      }
      # Equal locations, merge the message lists
      set :ffp [list $currentErrPos [lsort -uniq [list {*}$prevFfpMsg {*}$currentErrMsg]]]
    }

    # Instrumentation (1): end-of-choice
     
    foreach m {si:void_state_merge si:value_state_merge} {
      :method $m {} {
        :updateFFP
        next      
      }
    }

    # Instrumentation (2): mid-of-choice
    foreach m {si:valuevoid_branch si:valuevalue_branch si:voidvoid_branch si:voidvalue_branch} {
	:method $m {} {
	    try {set r [next]} on return {} {
		# caught a backtracking return, update ffp
		:updateFFP 
		return -code return
	    }
	    return $r
	}
    }
}

TinyParser mixins add FFP
parse {
  n := 5;
  f := 1;
  repeat
    f := f * n;
    n := n - 1
  until n < 1;
  write f;
}
# -> FFP=63 {{cl *-+><} space {t {;}}}
TinyParser mixins delete FFP