Merge branch 'master' of git://factorcode.org/git/factor
commit
309ffc53ef
|
@ -168,6 +168,18 @@ IN: peg.ebnf.tests
|
||||||
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
|
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
{ 10 } [
|
||||||
|
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ f } [
|
||||||
|
{ "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ 3 } [
|
||||||
|
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
{ V{ V{ 49 } "+" V{ 49 } } } [
|
{ V{ V{ 49 } "+" V{ 49 } } } [
|
||||||
#! Test direct left recursion.
|
#! Test direct left recursion.
|
||||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||||
|
|
|
@ -20,6 +20,7 @@ TUPLE: ebnf-optional group ;
|
||||||
TUPLE: ebnf-rule symbol elements ;
|
TUPLE: ebnf-rule symbol elements ;
|
||||||
TUPLE: ebnf-action parser code ;
|
TUPLE: ebnf-action parser code ;
|
||||||
TUPLE: ebnf-var parser name ;
|
TUPLE: ebnf-var parser name ;
|
||||||
|
TUPLE: ebnf-semantic parser code ;
|
||||||
TUPLE: ebnf rules ;
|
TUPLE: ebnf rules ;
|
||||||
|
|
||||||
C: <ebnf-non-terminal> ebnf-non-terminal
|
C: <ebnf-non-terminal> ebnf-non-terminal
|
||||||
|
@ -36,6 +37,7 @@ C: <ebnf-optional> ebnf-optional
|
||||||
C: <ebnf-rule> ebnf-rule
|
C: <ebnf-rule> ebnf-rule
|
||||||
C: <ebnf-action> ebnf-action
|
C: <ebnf-action> ebnf-action
|
||||||
C: <ebnf-var> ebnf-var
|
C: <ebnf-var> ebnf-var
|
||||||
|
C: <ebnf-semantic> ebnf-semantic
|
||||||
C: <ebnf> ebnf
|
C: <ebnf> ebnf
|
||||||
|
|
||||||
: syntax ( string -- parser )
|
: syntax ( string -- parser )
|
||||||
|
@ -156,6 +158,7 @@ DEFER: 'choice'
|
||||||
: 'factor-code' ( -- parser )
|
: 'factor-code' ( -- parser )
|
||||||
[
|
[
|
||||||
"]]" token ensure-not ,
|
"]]" token ensure-not ,
|
||||||
|
"]?" token ensure-not ,
|
||||||
[ drop t ] satisfy ,
|
[ drop t ] satisfy ,
|
||||||
] seq* [ first ] action repeat0 [ >string ] action ;
|
] seq* [ first ] action repeat0 [ >string ] action ;
|
||||||
|
|
||||||
|
@ -193,14 +196,15 @@ DEFER: 'choice'
|
||||||
: 'action' ( -- parser )
|
: 'action' ( -- parser )
|
||||||
"[[" 'factor-code' "]]" syntax-pack ;
|
"[[" 'factor-code' "]]" syntax-pack ;
|
||||||
|
|
||||||
|
: 'semantic' ( -- parser )
|
||||||
|
"?[" 'factor-code' "]?" syntax-pack ;
|
||||||
|
|
||||||
: 'sequence' ( -- parser )
|
: 'sequence' ( -- parser )
|
||||||
#! A sequence of terminals and non-terminals, including
|
#! A sequence of terminals and non-terminals, including
|
||||||
#! groupings of those.
|
#! groupings of those.
|
||||||
[
|
[
|
||||||
[
|
[ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
|
||||||
('sequence') ,
|
[ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
|
||||||
'action' ,
|
|
||||||
] seq* [ first2 <ebnf-action> ] action ,
|
|
||||||
('sequence') ,
|
('sequence') ,
|
||||||
] choice* repeat1 [
|
] choice* repeat1 [
|
||||||
dup length 1 = [ first ] [ <ebnf-sequence> ] if
|
dup length 1 = [ first ] [ <ebnf-sequence> ] if
|
||||||
|
@ -295,6 +299,10 @@ M: ebnf-action (transform) ( ast -- parser )
|
||||||
[ parser>> (transform) ] keep
|
[ parser>> (transform) ] keep
|
||||||
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
|
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
|
||||||
|
|
||||||
|
M: ebnf-semantic (transform) ( ast -- parser )
|
||||||
|
[ parser>> (transform) ] keep
|
||||||
|
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
|
||||||
|
|
||||||
M: ebnf-var (transform) ( ast -- parser )
|
M: ebnf-var (transform) ( ast -- parser )
|
||||||
[ parser>> (transform) ] [ name>> ] bi
|
[ parser>> (transform) ] [ name>> ] bi
|
||||||
dup vars get push [ dupd set ] curry action ;
|
dup vars get push [ dupd set ] curry action ;
|
||||||
|
|
|
@ -95,6 +95,19 @@ HELP: optional
|
||||||
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
|
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
|
||||||
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
|
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
|
||||||
|
|
||||||
|
HELP: semantic
|
||||||
|
{ $values
|
||||||
|
{ "parser" "a parser" }
|
||||||
|
{ "quot" "a quotation with stack effect ( object -- bool )" }
|
||||||
|
}
|
||||||
|
{ $description
|
||||||
|
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
||||||
|
"the AST produced by 'p1' on the stack returns true." }
|
||||||
|
{ $examples
|
||||||
|
{ $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" }
|
||||||
|
{ $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" }
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: ensure
|
HELP: ensure
|
||||||
{ $values
|
{ $values
|
||||||
{ "parser" "a parser" }
|
{ "parser" "a parser" }
|
||||||
|
@ -124,7 +137,7 @@ HELP: action
|
||||||
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
|
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
|
||||||
"from that parse. The result of the quotation is then used as the final AST. This can be used "
|
"from that parse. The result of the quotation is then used as the final AST. This can be used "
|
||||||
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
|
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
|
||||||
"the default AST." }
|
"the default AST. If the quotation returns " { $link fail } " then the parser fails." }
|
||||||
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
|
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
|
||||||
|
|
||||||
HELP: sp
|
HELP: sp
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007 Chris Double.
|
! Copyright (C) 2007 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
!
|
!
|
||||||
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ;
|
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
|
||||||
IN: peg.tests
|
IN: peg.tests
|
||||||
|
|
||||||
{ f } [
|
{ f } [
|
||||||
|
@ -182,4 +182,13 @@ IN: peg.tests
|
||||||
[ f , "a" token , ] seq*
|
[ f , "a" token , ] seq*
|
||||||
dup parsers>>
|
dup parsers>>
|
||||||
dupd 0 swap set-nth compile word?
|
dupd 0 swap set-nth compile word?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
{ f } [
|
||||||
|
"A" [ drop t ] satisfy [ 66 >= ] semantic parse
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ CHAR: B } [
|
||||||
|
"B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
|
||||||
M: optional-parser (compile) ( parser -- quot )
|
M: optional-parser (compile) ( parser -- quot )
|
||||||
p1>> compiled-parser \ ?quot optional-pattern match-replace ;
|
p1>> compiled-parser \ ?quot optional-pattern match-replace ;
|
||||||
|
|
||||||
|
TUPLE: semantic-parser p1 quot ;
|
||||||
|
|
||||||
|
MATCH-VARS: ?parser ;
|
||||||
|
|
||||||
|
: semantic-pattern ( -- quot )
|
||||||
|
[
|
||||||
|
?parser [
|
||||||
|
dup parse-result-ast ?quot call [ drop f ] unless
|
||||||
|
] [
|
||||||
|
f
|
||||||
|
] if*
|
||||||
|
] ;
|
||||||
|
|
||||||
|
M: semantic-parser (compile) ( parser -- quot )
|
||||||
|
[ p1>> compiled-parser ] [ quot>> ] bi
|
||||||
|
2array { ?parser ?quot } semantic-pattern match-replace ;
|
||||||
|
|
||||||
TUPLE: ensure-parser p1 ;
|
TUPLE: ensure-parser p1 ;
|
||||||
|
|
||||||
: ensure-pattern ( -- quot )
|
: ensure-pattern ( -- quot )
|
||||||
|
@ -546,6 +563,9 @@ PRIVATE>
|
||||||
: optional ( parser -- parser )
|
: optional ( parser -- parser )
|
||||||
optional-parser construct-boa init-parser ;
|
optional-parser construct-boa init-parser ;
|
||||||
|
|
||||||
|
: semantic ( parser quot -- parser )
|
||||||
|
semantic-parser construct-boa init-parser ;
|
||||||
|
|
||||||
: ensure ( parser -- parser )
|
: ensure ( parser -- parser )
|
||||||
ensure-parser construct-boa init-parser ;
|
ensure-parser construct-boa init-parser ;
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: random.mersenne-twister
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: curry2 ( w quot1 quot2 -- quot1 quot2 )
|
: curry2 ( w quot1 quot2 -- quot1 quot2 )
|
||||||
>r over r> [ curry ] 2bi@ ;
|
>r over r> [ curry ] 2bi@ ; inline
|
||||||
|
|
||||||
TUPLE: mersenne-twister seq i ;
|
TUPLE: mersenne-twister seq i ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue