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

packrat refactoring

db4
Chris Double 2008-07-09 12:07:17 +12:00
parent 4135f81514
commit 9e78bb70f2
1 changed files with 45 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
extra/peg/peg.factor
View File

@ -48,12 +48,27 @@ SYMBOL: error-stack
SYMBOL: ignore SYMBOL: ignore
SYMBOL: packrat : packrat ( id -- cache )
#! The packrat cache is a mapping of parser-id->cache.
#! For each parser it maps to a cache holding a mapping
#! of position->result. The packrat cache therefore keeps
#! track of all parses that have occurred at each position
#! of the input string and the results obtained from that
#! parser.
\ packrat get [ drop H{ } clone ] cache ;
SYMBOL: pos SYMBOL: pos
SYMBOL: input SYMBOL: input
SYMBOL: fail SYMBOL: fail
SYMBOL: lrstack SYMBOL: lrstack
SYMBOL: heads
: heads ( -- cache )
#! A mapping from position->peg-head. It maps a
#! position in the input string being parsed to
#! the head of the left recursion which is currently
#! being grown. It is 'f' at any position where
#! left recursion growth is not underway.
\ heads get ;
: failed? ( obj -- ? ) : failed? ( obj -- ? )
fail = ; fail = ;
@ -71,19 +86,20 @@ SYMBOL: heads
reset-pegs reset-pegs
#! An entry in the table of memoized parse results
#! ast = an AST produced from the parse
#! or the symbol 'fail'
#! or a left-recursion object
#! pos = the position in the input string of this entry
TUPLE: memo-entry ans pos ; TUPLE: memo-entry ans pos ;
C: <memo-entry> memo-entry
TUPLE: left-recursion seed rule head next ; TUPLE: left-recursion seed rule head next ;
C: <left-recursion> left-recursion
TUPLE: peg-head rule involved-set eval-set ; TUPLE: peg-head rule involved-set eval-set ;
C: <head> peg-head
: rule-parser ( rule -- parser ) : 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
#! a "peg" property containing the original parser. #! a "peg-id" property containing the id of the original parser.
"peg" word-prop ; "peg-id" word-prop ;
: input-slice ( -- slice ) : input-slice ( -- slice )
#! Return a slice of the input from the current parse position #! Return a slice of the input from the current parse position
@ -94,11 +110,6 @@ C: <head> peg-head
#! input slice is based on. #! input slice is based on.
dup slice? [ slice-from ] [ drop 0 ] if ; dup slice? [ slice-from ] [ drop 0 ] if ;
: input-cache ( parser -- cache )
#! From the packrat cache, obtain the cache for the parser
#! that maps the position to the parser result.
id>> packrat get [ drop H{ } clone ] cache ;
: process-rule-result ( p result -- result ) : process-rule-result ( p result -- result )
[ [
nip [ ast>> ] [ remaining>> ] bi input-from pos set nip [ ast>> ] [ remaining>> ] bi input-from pos set
@ -114,11 +125,13 @@ C: <head> peg-head
: memo ( pos rule -- memo-entry ) : memo ( pos rule -- memo-entry )
#! Return the result from the memo cache. #! Return the result from the memo cache.
rule-parser input-cache at ; rule-id packrat at
! " memo result " write dup .
;
: set-memo ( memo-entry pos rule -- ) : set-memo ( memo-entry pos rule -- )
#! Store an entry in the cache #! Store an entry in the cache
rule-parser input-cache set-at ; rule-id packrat set-at ;
: update-m ( ast m -- ) : update-m ( ast m -- )
swap >>ans pos get >>pos drop ; swap >>ans pos get >>pos drop ;
@ -141,9 +154,9 @@ C: <head> peg-head
] if ; inline ] if ; inline
: grow-lr ( h p r m -- ast ) : grow-lr ( h p r m -- ast )
>r >r [ heads get set-at ] 2keep r> r> >r >r [ heads set-at ] 2keep r> r>
pick over >r >r (grow-lr) r> r> pick over >r >r (grow-lr) r> r>
swap heads get delete-at swap heads delete-at
dup pos>> pos set ans>> dup pos>> pos set ans>>
; inline ; inline
@ -156,7 +169,7 @@ C: <head> peg-head
:: setup-lr ( r l -- ) :: setup-lr ( r l -- )
l head>> [ l head>> [
r V{ } clone V{ } clone <head> l (>>head) r V{ } clone V{ } clone peg-head boa l (>>head)
] unless ] unless
r l lrstack get (setup-lr) ; r l lrstack get (setup-lr) ;
@ -179,11 +192,11 @@ C: <head> peg-head
:: recall ( r p -- memo-entry ) :: recall ( r p -- memo-entry )
[let* | [let* |
m [ p r memo ] m [ p r memo ]
h [ p heads get at ] h [ p heads at ]
| |
h [ h [
m r h involved-set>> h rule>> suffix member? not and [ m r h involved-set>> h rule>> suffix member? not and [
fail p <memo-entry> fail p memo-entry boa
] [ ] [
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
@ -201,8 +214,8 @@ C: <head> peg-head
:: apply-non-memo-rule ( r p -- ast ) :: apply-non-memo-rule ( r p -- ast )
[let* | [let* |
lr [ fail r f lrstack get <left-recursion> ] lr [ fail r f lrstack get left-recursion boa ]
m [ lr lrstack set lr p <memo-entry> dup p r set-memo ] m [ lr lrstack set lr p memo-entry boa dup p r set-memo ]
ans [ r eval-rule ] ans [ r eval-rule ]
| |
lrstack get next>> lrstack set lrstack get next>> lrstack set
@ -224,10 +237,15 @@ C: <head> peg-head
nip nip
] if ; ] if ;
USE: prettyprint
: apply-rule ( r p -- ast ) : apply-rule ( r p -- ast )
! 2dup [ rule-id ] dip 2array "apply-rule: " write .
2dup recall [ 2dup recall [
! " memoed" print
nip apply-memo-rule nip apply-memo-rule
] [ ] [
! " not memoed" print
apply-non-memo-rule apply-non-memo-rule
] if* ; inline ] if* ; inline
@ -238,8 +256,8 @@ C: <head> peg-head
0 pos set 0 pos set
f lrstack set f lrstack set
V{ } clone error-stack set V{ } clone error-stack set
H{ } clone heads set H{ } clone \ heads set
H{ } clone packrat set H{ } clone \ packrat set
] H{ } make-assoc swap bind ; inline ] H{ } make-assoc swap bind ; inline
@ -258,7 +276,7 @@ GENERIC: (compile) ( peg -- quot )
: parser-body ( parser -- quot ) : parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version #! Return the body of the word that is the compiled version
#! of the parser. #! of the parser.
gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ; [ execute-parser ] curry ;
: compiled-parser ( parser -- word ) : compiled-parser ( parser -- word )