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-05 00:51:04 -05:00
parent 5a4b5b01f9 e00a392736
commit d64921e8a2
1 changed files with 103 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

252
extra/peg/peg.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Chris Double. ! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser unicode.categories sequences.lib compiler.units parser
words quotations effects memoize accessors locals effects ; words quotations effects memoize accessors locals effects splitting ;
IN: peg IN: peg
USE: prettyprint USE: prettyprint
@ -179,25 +179,20 @@ C: <head> peg-head
] if ] if
] ; inline ] ; inline
:: apply-memo-rule ( r m -- ast ) : apply-memo-rule ( r m -- ast )
m pos>> pos set [ ans>> ] [ pos>> ] bi pos set
m ans>> left-recursion? [ dup left-recursion? [
r m ans>> setup-lr [ setup-lr ] keep seed>>
m ans>> seed>>
] [ ] [
m ans>> nip
] if ; ] if ;
:: apply-rule ( r p -- ast ) : apply-rule ( r p -- ast )
[let* | 2dup recall [
m [ r p recall ] nip apply-memo-rule
| ] [
m [ apply-non-memo-rule
r m apply-memo-rule ] if* ; inline
] [
r p apply-non-memo-rule
] if
] ; inline
: with-packrat ( input quot -- result ) : with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active. #! Run the quotation with a packrat cache active.
@ -274,206 +269,169 @@ MATCH-VARS: ?token ;
: parse-token ( input string -- result ) : parse-token ( input string -- result )
#! Parse the string, returning a parse result #! Parse the string, returning a parse result
2dup head? [ dup >r ?head-slice [
dup >r length tail-slice r> <parse-result> r> <parse-result>
] [ ] [
2drop f r> 2drop f
] if ; ] if ;
M: token-parser (compile) ( parser -- quot ) M: token-parser (compile) ( parser -- quot )
[ \ input-slice , symbol>> , \ parse-token , ] [ ] make ; symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ; TUPLE: satisfy-parser quot ;
MATCH-VARS: ?quot ; : parse-satisfy ( input quot -- result )
swap dup empty? [
2drop f
] [
unclip-slice rot dupd call [
<parse-result>
] [
2drop f
] if
] if ; inline
: satisfy-pattern ( -- quot )
[
input-slice dup empty? [
drop f
] [
unclip-slice dup ?quot call [
<parse-result>
] [
2drop f
] if
] if
] ;
M: satisfy-parser (compile) ( parser -- quot ) M: satisfy-parser (compile) ( parser -- quot )
quot>> \ ?quot satisfy-pattern match-replace ; quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
MATCH-VARS: ?min ?max ; : parse-range ( input min max -- result )
pick empty? [
: range-pattern ( -- quot ) 3drop f
[ ] [
input-slice dup empty? [ pick first -rot between? [
unclip-slice <parse-result>
] [
drop f drop f
] [ ] if
0 over nth dup ] if ;
?min ?max between? [
[ 1 tail-slice ] dip <parse-result>
] [
2drop f
] if
] if
] ;
M: range-parser (compile) ( parser -- quot ) M: range-parser (compile) ( parser -- quot )
T{ range-parser _ ?min ?max } range-pattern match-replace ; [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ; TUPLE: seq-parser parsers ;
: seq-pattern ( -- quot ) : ignore? ( ast -- bool )
ignore = ;
: calc-seq-result ( prev-result current-result -- next-result )
[ [
dup [ [ remaining>> swap (>>remaining) ] 2keep
?quot [ ast>> dup ignore? [
[ remaining>> swap (>>remaining) ] 2keep drop
ast>> dup ignore = [
drop
] [
swap [ ast>> push ] keep
] if
] [
drop f
] if*
] [ ] [
drop f swap [ ast>> push ] keep
] if ] if
] ; ] [
drop f
] if* ;
: parse-seq-element ( result quot -- result )
over [
call calc-seq-result
] [
2drop f
] if ; inline
M: seq-parser (compile) ( parser -- quot ) M: seq-parser (compile) ( parser -- quot )
[ [
[ input-slice V{ } clone <parse-result> ] % [ input-slice V{ } clone <parse-result> ] %
parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
] [ ] make ; ] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
: choice-pattern ( -- quot )
[
[ ?quot ] unless*
] ;
M: choice-parser (compile) ( parser -- quot ) M: choice-parser (compile) ( parser -- quot )
[ [
f , f ,
parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each parsers>> [ compiled-parser 1quotation , \ unless* , ] each
] [ ] make ; ] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
: (repeat0) ( quot result -- result ) : (repeat) ( quot result -- result )
over call [ over call [
[ remaining>> swap (>>remaining) ] 2keep [ remaining>> swap (>>remaining) ] 2keep
ast>> swap [ ast>> push ] keep ast>> swap [ ast>> push ] keep
(repeat0) (repeat)
] [ ] [
nip nip
] if* ; inline ] if* ; inline
: repeat0-pattern ( -- quot )
[
[ ?quot ] swap (repeat0)
] ;
M: repeat0-parser (compile) ( parser -- quot ) M: repeat0-parser (compile) ( parser -- quot )
[ p1>> compiled-parser 1quotation '[
[ input-slice V{ } clone <parse-result> ] % input-slice V{ } clone <parse-result> , swap (repeat)
p1>> compiled-parser \ ?quot repeat0-pattern match-replace % ] ;
] [ ] make ;
TUPLE: repeat1-parser p1 ; TUPLE: repeat1-parser p1 ;
: repeat1-pattern ( -- quot ) : repeat1-empty-check ( result -- result )
[ [
[ ?quot ] swap (repeat0) [ dup ast>> empty? [ drop f ] when
dup ast>> empty? [ ] [
drop f f
] when ] if* ;
] [
f
] if*
] ;
M: repeat1-parser (compile) ( parser -- quot ) M: repeat1-parser (compile) ( parser -- quot )
[ p1>> compiled-parser 1quotation '[
[ input-slice V{ } clone <parse-result> ] % input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
p1>> compiled-parser \ ?quot repeat1-pattern match-replace % ] ;
] [ ] make ;
TUPLE: optional-parser p1 ; TUPLE: optional-parser p1 ;
: optional-pattern ( -- quot ) : check-optional ( result -- result )
[ [ input-slice f <parse-result> ] unless* ;
?quot [ input-slice f <parse-result> ] unless*
] ;
M: optional-parser (compile) ( parser -- quot ) M: optional-parser (compile) ( parser -- quot )
p1>> compiled-parser \ ?quot optional-pattern match-replace ; p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ; TUPLE: semantic-parser p1 quot ;
MATCH-VARS: ?quot ;
MATCH-VARS: ?parser ; MATCH-VARS: ?parser ;
: semantic-pattern ( -- quot ) : check-semantic ( result quot -- result )
[ over [
?parser [ over ast>> swap call [ drop f ] unless
dup parse-result-ast ?quot call [ drop f ] unless ] [
] [ drop
f ] if ; inline
] if*
] ;
M: semantic-parser (compile) ( parser -- quot ) M: semantic-parser (compile) ( parser -- quot )
[ p1>> compiled-parser ] [ quot>> ] bi [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
2array { ?parser ?quot } semantic-pattern match-replace ; '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
: ensure-pattern ( -- quot ) : check-ensure ( old-input result -- result )
[ [ ignore <parse-result> ] [ drop f ] if ;
input-slice ?quot [
ignore <parse-result>
] [
drop f
] if
] ;
M: ensure-parser (compile) ( parser -- quot ) M: ensure-parser (compile) ( parser -- quot )
p1>> compiled-parser \ ?quot ensure-pattern match-replace ; p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
: ensure-not-pattern ( -- quot ) : check-ensure-not ( old-input result -- result )
[ [ drop f ] [ ignore <parse-result> ] if ;
input-slice ?quot [
drop f
] [
ignore <parse-result>
] if
] ;
M: ensure-not-parser (compile) ( parser -- quot ) M: ensure-not-parser (compile) ( parser -- quot )
p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
MATCH-VARS: ?action ; MATCH-VARS: ?action ;
: action-pattern ( -- quot ) : check-action ( result quot -- result )
[ over [
?quot dup [ over ast>> swap call >>ast
dup ast>> ?action call ] [
>>ast drop
] when ] if ; inline
] ;
M: action-parser (compile) ( parser -- quot ) M: action-parser (compile) ( parser -- quot )
[ p1>> compiled-parser ] [ quot>> ] bi [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -485,9 +443,9 @@ M: action-parser (compile) ( parser -- quot )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot ) M: sp-parser (compile) ( parser -- quot )
[ p1>> compiled-parser 1quotation '[
\ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser , input-slice left-trim-slice input-from pos set @
] [ ] make ; ] ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
@ -495,11 +453,7 @@ M: delay-parser (compile) ( parser -- quot )
#! For efficiency we memoize the quotation. #! For efficiency we memoize the quotation.
#! This way it is run only once and the #! This way it is run only once and the
#! parser constructed once at run time. #! parser constructed once at run time.
[ quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
quot>> % \ compile ,
] [ ] make
{ } { "word" } <effect> memoize-quot
[ % \ execute , ] [ ] make ;
TUPLE: box-parser quot ; TUPLE: box-parser quot ;