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

update peg for [let change

db4
Joe Groff 2009-10-27 22:29:20 -05:00
parent 935c0797c3
commit f1d9201cb2
2 changed files with 24 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/peg/ebnf/ebnf.factor
View File

@ -445,16 +445,16 @@ M: ebnf-sequence build-locals ( code ast -- code )
drop drop
] [ ] [
[ [
"FROM: locals => [let* ; FROM: sequences => nth ; [let* | " % "FROM: locals => [let ; FROM: sequences => nth ; [let " %
dup length swap [ dup length [
dup ebnf-var? [ over ebnf-var? [
" " % # " over nth :> " %
name>> % name>> %
" [ " % # " over nth ] " %
] [ ] [
2drop 2drop
] if ] if
] 2each ] 2each
" | " % " " %
% %
" nip ]" % " nip ]" %
] "" make ] "" make
@ -463,9 +463,9 @@ M: ebnf-sequence build-locals ( code ast -- code )
M: ebnf-var build-locals ( code ast -- ) M: ebnf-var build-locals ( code ast -- )
[ [
"FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " % "FROM: locals => [let ; FROM: kernel => dup nip ; [let " %
name>> % " [ dup ] " % " dup :> " % name>> %
" | " % " " %
% %
" nip ]" % " nip ]" %
] "" make ; ] "" make ;

44
basis/peg/peg.factor
View File

@ -172,9 +172,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
l lrstack get (setup-lr) ; l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast ) :: lr-answer ( r p m -- ast )
[let* | m ans>> head>> :> h
h [ m ans>> head>> ]
|
h rule-id>> r rule-id eq? [ h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans) m ans>> seed>> m (>>ans)
m ans>> failed? [ m ans>> failed? [
@ -184,14 +182,11 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if ] if
] [ ] [
m ans>> seed>> m ans>> seed>>
] if ] if ; inline
] ; inline
:: recall ( r p -- memo-entry ) :: recall ( r p -- memo-entry )
[let* | p r rule-id memo :> m
m [ p r rule-id memo ] p heads at :> h
h [ p heads at ]
|
h [ h [
m r rule-id h involved-set>> h rule-id>> 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
@ -207,15 +202,12 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if ] if
] [ ] [
m m
] if ] if ; inline
] ; inline
:: apply-non-memo-rule ( r p -- ast ) :: apply-non-memo-rule ( r p -- ast )
[let* | fail r rule-id f lrstack get left-recursion boa :> lr
lr [ fail r rule-id f lrstack get left-recursion boa ] lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ] r eval-rule :> ans
ans [ r eval-rule ]
|
lrstack get next>> lrstack set lrstack get next>> lrstack set
pos get m (>>pos) pos get m (>>pos)
lr head>> [ lr head>> [
@ -226,8 +218,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] [ ] [
ans m (>>ans) ans m (>>ans)
ans ans
] if ] if ; inline
] ; inline
: apply-memo-rule ( r m -- ast ) : apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set [ ans>> ] [ pos>> ] bi pos set
@ -622,20 +613,17 @@ PRIVATE>
ERROR: parse-failed input word ; ERROR: parse-failed input word ;
SYNTAX: PEG: SYNTAX: PEG:
(:) (:) :> effect :> def :> word
[let | effect [ ] def [ ] word [ ] |
[ [
[ [
[let | compiled-def [ def call compile ] | def call compile :> compiled-def
[ [
dup compiled-def compiled-parse dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if [ ast>> ] [ word parse-failed ] ?if
]
word swap effect define-declared
] ]
word swap effect define-declared
] with-compilation-unit ] with-compilation-unit
] over push-all ] over push-all ;
] ;
USING: vocabs vocabs.loader ; USING: vocabs vocabs.loader ;