Merge branch 'master' of git://double.co.nz/git/factor
commit
d64921e8a2
|
@ -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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue