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

Minor peg refactorings

db4
Chris Double 2008-04-09 12:52:49 +12:00
parent c39ece54a1
commit 0dd8e462c6
1 changed files with 40 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
extra/peg/peg.factor
View File

@ -30,6 +30,9 @@ SYMBOL: fail
SYMBOL: lrstack SYMBOL: lrstack
SYMBOL: heads SYMBOL: heads
: failed? ( obj -- ? )
fail = ;
: delegates ( -- cache ) : delegates ( -- cache )
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
@ -66,21 +69,18 @@ C: <head> peg-head
#! that maps the position to the parser result. #! that maps the position to the parser result.
id>> packrat get [ drop H{ } clone ] cache ; id>> packrat get [ drop H{ } clone ] cache ;
: process-rule-result ( p result -- result )
[
nip [ ast>> ] [ remaining>> ] bi input-from pos set
] [
pos set fail
] if* ;
: eval-rule ( rule -- ast ) : eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it. #! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has #! Return fail if the rule failed. The rule has
#! stack effect ( input -- parse-result ) #! stack effect ( input -- parse-result )
pos get swap pos get swap execute process-rule-result ; inline
execute
! drop f f <parse-result>
[
nip
[ ast>> ] [ remaining>> ] bi
input-from pos set
] [
pos set
fail
] if* ; inline
: memo ( pos rule -- memo-entry ) : memo ( pos rule -- memo-entry )
#! Return the result from the memo cache. #! Return the result from the memo cache.
@ -90,21 +90,29 @@ C: <head> peg-head
#! Store an entry in the cache #! Store an entry in the cache
rule-parser input-cache set-at ; rule-parser input-cache set-at ;
:: (grow-lr) ( r p m h -- ) : update-m ( ast m -- )
p pos set swap >>ans pos get >>pos drop ;
h involved-set>> clone h (>>eval-set)
: stop-growth? ( ast m -- ? )
[ failed? pos get ] dip
pos>> <= or ;
: setup-growth ( h p -- )
pos set dup involved-set>> clone >>eval-set drop ;
:: (grow-lr) ( h p r m -- )
h p setup-growth
r eval-rule r eval-rule
dup fail = pos get m pos>> <= or [ dup m stop-growth? [
drop drop
] [ ] [
m (>>ans) m update-m
pos get m (>>pos) h p r m (grow-lr)
r p m h (grow-lr)
] if ; inline ] if ; inline
:: grow-lr ( r p m h -- ast ) :: grow-lr ( h p r m -- ast )
h p heads get set-at h p heads get set-at
r p m h (grow-lr) h p r m (grow-lr)
p heads get delete-at p heads get delete-at
m pos>> pos set m ans>> m pos>> pos set m ans>>
; inline ; inline
@ -128,10 +136,10 @@ C: <head> peg-head
| |
h rule>> r eq? [ h rule>> r eq? [
m ans>> seed>> m (>>ans) m ans>> seed>> m (>>ans)
m ans>> fail = [ m ans>> failed? [
fail fail
] [ ] [
r p m h grow-lr h p r m grow-lr
] if ] if
] [ ] [
m ans>> seed>> m ans>> seed>>
@ -150,8 +158,7 @@ C: <head> peg-head
r h eval-set>> member? [ r h eval-set>> member? [
h [ r swap remove ] change-eval-set drop h [ r swap remove ] change-eval-set drop
r eval-rule r eval-rule
m (>>ans) m update-m
pos get m (>>pos)
m m
] [ ] [
m m
@ -207,20 +214,18 @@ C: <head> peg-head
GENERIC: (compile) ( parser -- quot ) GENERIC: (compile) ( parser -- quot )
: execute-parser ( word -- result )
:: parser-body ( parser -- quot ) pos get apply-rule dup failed? [
#! Return the body of the word that is the compiled version
#! of the parser.
[let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
|
[
rule pos get apply-rule dup fail = [
drop f drop f
] [ ] [
input-slice swap <parse-result> input-slice swap <parse-result>
] if ] if ; inline
]
] ; : parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
[ execute-parser ] curry ;
: compiled-parser ( parser -- word ) : compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled. #! Look to see if the given parser has been compiled.