steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Indirect Left recursive grammars working

db4
Chris Double 2008-03-29 02:45:21 +13:00
parent 68cbdf76aa
commit dd979c8b3b
1 changed files with 84 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
extra/peg/peg.factor
View File

@ -20,13 +20,18 @@ SYMBOL: packrat
SYMBOL: pos SYMBOL: pos
SYMBOL: input SYMBOL: input
SYMBOL: fail SYMBOL: fail
SYMBOL: lrstack
SYMBOL: heads
TUPLE: memo-entry ans pos ; TUPLE: memo-entry ans pos ;
C: <memo-entry> memo-entry C: <memo-entry> memo-entry
TUPLE: left-recursion detected? ; TUPLE: left-recursion seed rule head next ;
C: <left-recursion> left-recursion C: <left-recursion> left-recursion
TUPLE: peg-head rule involved-set eval-set ;
C: <head> peg-head
: rule-parser ( rule -- parser ) : rule-parser ( rule -- parser )
#! A rule is the parser compiled down to a word. It has #! A rule is the parser compiled down to a word. It has
#! a "peg" property containing the original parser. #! a "peg" property containing the original parser.
@ -72,6 +77,7 @@ C: <left-recursion> left-recursion
:: (grow-lr) ( r p m h -- ) :: (grow-lr) ( r p m h -- )
p pos set p pos set
h involved-set>> clone h (>>eval-set)
r eval-rule r eval-rule
dup fail = pos get m pos>> <= or [ dup fail = pos get m pos>> <= or [
drop drop
@ -82,39 +88,97 @@ C: <left-recursion> left-recursion
] if ; ] if ;
:: grow-lr ( r p m h -- ast ) :: grow-lr ( r p m h -- ast )
#! Placeholder for full left recursion implementation h p heads get set-at
r p m h (grow-lr) m pos>> pos set m ans>> r p m h (grow-lr)
p heads get delete-at
m pos>> pos set m ans>>
; ;
:: (setup-lr) ( r l s -- )
s head>> l head>> eq? [
l head>> s (>>head)
l head>> [ s rule>> add ] change-involved-set drop
r l s next>> (setup-lr)
] unless ;
:: setup-lr ( r l -- )
l head>> [
r V{ } clone V{ } clone <head> l (>>head)
] unless
r l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
[let* |
h [ m ans>> head>> ]
|
h rule>> r eq? [
m ans>> seed>> m (>>ans)
m ans>> fail = [
fail
] [
r p m h grow-lr
] if
] [
m ans>> seed>>
] if
] ;
:: recall ( r p -- memo-entry )
[let* |
m [ p r memo ]
h [ p heads get at ]
|
h [
m r h involved-set>> h rule>> add member? not and [
fail p <memo-entry>
] [
r h eval-set>> member? [
h [ r swap remove ] change-eval-set drop
r eval-rule
m (>>ans)
pos get m (>>pos)
m
] [
m
] if
] if
] [
m
] if
] ;
:: apply-non-memo-rule ( r p -- ast ) :: apply-non-memo-rule ( r p -- ast )
[let* | [let* |
lr [ f <left-recursion> ] lr [ fail r f lrstack get <left-recursion> ]
m [ lr p <memo-entry> dup p r set-memo ] m [ lr lrstack set lr p <memo-entry> dup p r set-memo ]
ans [ r eval-rule ] ans [ r eval-rule ]
| |
ans m (>>ans) lrstack get next>> lrstack set
pos get m (>>pos) pos get m (>>pos)
lr detected?>> ans fail = not and [ lr head>> [
r p m f grow-lr ans lr (>>seed)
r p m lr-answer
] [ ] [
ans m (>>ans)
ans ans
] if ] if
] ; ] ;
: apply-memo-rule ( m -- ast ) :: apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi m pos>> pos set
pos set m ans>> left-recursion? [
dup left-recursion? [ r m ans>> setup-lr
t swap (>>detected?) m ans>> seed>>
fail ] [
] when ; m ans>>
] if ;
:: apply-rule ( r p -- ast ) :: apply-rule ( r p -- ast )
[let* | [let* |
m [ p r memo ] m [ r p recall ]
| |
m [ m [
m apply-memo-rule r m apply-memo-rule
] [ ] [
r p apply-non-memo-rule r p apply-non-memo-rule
] if ] if
@ -125,6 +189,8 @@ C: <left-recursion> left-recursion
swap [ swap [
input set input set
0 pos set 0 pos set
f lrstack set
H{ } clone heads set
H{ } clone packrat set H{ } clone packrat set
] H{ } make-assoc swap bind ; ] H{ } make-assoc swap bind ;