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

Store peg rules by their id rather than word in left recursion handling

db4
Chris Double 2008-07-09 14:26:11 +12:00
parent 9e78bb70f2
commit 2ed0d561ae
1 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
extra/peg/peg.factor
View File

@ -93,8 +93,8 @@ reset-pegs
#! pos = the position in the input string of this entry #! pos = the position in the input string of this entry
TUPLE: memo-entry ans pos ; TUPLE: memo-entry ans pos ;
TUPLE: left-recursion seed rule head next ; TUPLE: left-recursion seed rule-id head next ;
TUPLE: peg-head rule involved-set eval-set ; TUPLE: peg-head rule-id involved-set eval-set ;
: rule-id ( word -- id ) : rule-id ( word -- id )
#! A rule is the parser compiled down to a word. It has #! A rule is the parser compiled down to a word. It has
@ -123,15 +123,15 @@ TUPLE: peg-head rule involved-set eval-set ;
#! stack effect ( -- parse-result ) #! stack effect ( -- parse-result )
pos get swap execute process-rule-result ; inline pos get swap execute process-rule-result ; inline
: memo ( pos rule -- memo-entry ) : memo ( pos id -- memo-entry )
#! Return the result from the memo cache. #! Return the result from the memo cache.
rule-id packrat at packrat at
! " memo result " write dup . ! " memo result " write dup .
; ;
: set-memo ( memo-entry pos rule -- ) : set-memo ( memo-entry pos id -- )
#! Store an entry in the cache #! Store an entry in the cache
rule-id packrat set-at ; packrat set-at ;
: update-m ( ast m -- ) : update-m ( ast m -- )
swap >>ans pos get >>pos drop ; swap >>ans pos get >>pos drop ;
@ -163,13 +163,13 @@ TUPLE: peg-head rule involved-set eval-set ;
:: (setup-lr) ( r l s -- ) :: (setup-lr) ( r l s -- )
s head>> l head>> eq? [ s head>> l head>> eq? [
l head>> s (>>head) l head>> s (>>head)
l head>> [ s rule>> suffix ] change-involved-set drop l head>> [ s rule-id>> suffix ] change-involved-set drop
r l s next>> (setup-lr) r l s next>> (setup-lr)
] unless ; ] unless ;
:: setup-lr ( r l -- ) :: setup-lr ( r l -- )
l head>> [ l head>> [
r V{ } clone V{ } clone peg-head boa l (>>head) r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
] unless ] unless
r l lrstack get (setup-lr) ; r l lrstack get (setup-lr) ;
@ -177,7 +177,7 @@ TUPLE: peg-head rule involved-set eval-set ;
[let* | [let* |
h [ m ans>> head>> ] h [ m ans>> head>> ]
| |
h rule>> r eq? [ h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans) m ans>> seed>> m (>>ans)
m ans>> failed? [ m ans>> failed? [
fail fail
@ -191,15 +191,15 @@ TUPLE: peg-head rule involved-set eval-set ;
:: recall ( r p -- memo-entry ) :: recall ( r p -- memo-entry )
[let* | [let* |
m [ p r memo ] m [ p r rule-id memo ]
h [ p heads at ] h [ p heads at ]
| |
h [ h [
m r h involved-set>> h rule>> suffix member? not and [ m r rule-id h involved-set>> h rule-id>> suffix member? not and [
fail p memo-entry boa fail p memo-entry boa
] [ ] [
r h eval-set>> member? [ r rule-id h eval-set>> member? [
h [ r swap remove ] change-eval-set drop h [ r rule-id swap remove ] change-eval-set drop
r eval-rule r eval-rule
m update-m m update-m
m m
@ -214,8 +214,8 @@ TUPLE: peg-head rule involved-set eval-set ;
:: apply-non-memo-rule ( r p -- ast ) :: apply-non-memo-rule ( r p -- ast )
[let* | [let* |
lr [ fail r f lrstack get left-recursion boa ] lr [ fail r rule-id f lrstack get left-recursion boa ]
m [ lr lrstack set lr p memo-entry boa dup p r set-memo ] m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
ans [ r eval-rule ] ans [ r eval-rule ]
| |
lrstack get next>> lrstack set lrstack get next>> lrstack set