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

Merge branch 'master' of git://double.co.nz/git/factor

db4
Slava Pestov 2008-04-09 02:23:05 -05:00
parent 639871900a 0dd8e462c6
commit bd78d7e889
2 changed files with 47 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
extra/peg/ebnf/ebnf.factor
View File

@ -318,11 +318,11 @@ M: object build-locals ( code ast -- )
M: ebnf-action (transform) ( ast -- parser ) M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
string-lines [ parse-lines ] with-compilation-unit action ; string-lines parse-lines action ;
M: ebnf-semantic (transform) ( ast -- parser ) M: ebnf-semantic (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
string-lines [ parse-lines ] with-compilation-unit semantic ; string-lines parse-lines semantic ;
M: ebnf-var (transform) ( ast -- parser ) M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ; parser>> (transform) ;
@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
[ compiled-parse ] curry [ with-scope ] curry ; [ compiled-parse ] curry [ with-scope ] curry ;
: replace-escapes ( string -- string ) : replace-escapes ( string -- string )
"\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; [
"\\t" token [ drop "\t" ] action ,
"\\n" token [ drop "\n" ] action ,
"\\r" token [ drop "\r" ] action ,
] choice* replace ;
: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing : [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing

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.