86 lines
3.0 KiB
Perl
86 lines
3.0 KiB
Perl
# Changes! /usr/local/bin/perl -w
|
|
|
|
use Parse::RecDescent;
|
|
|
|
local $/;
|
|
my $parse = Parse::RecDescent->new(<DATA>);
|
|
|
|
my $grammar = <>;
|
|
|
|
$tree = parse->grammar($grammar) or die "Bad grammar! No biscuit!";
|
|
|
|
print Data::Dumper->Dump([$tree]);
|
|
|
|
|
|
|
|
__DATA__
|
|
|
|
<autotree>
|
|
|
|
grammar : prerule(s?) components(s?) /\Z/
|
|
|
|
component : rule
|
|
| comment
|
|
|
|
rule : <skip:""> "\n" <skip: '[ \t]'> identifier ":"
|
|
<skip: $item[1]> production(s? /|/)
|
|
|
|
production : items(s)
|
|
|
|
item : lookahead(s?) simpleitem
|
|
| directive
|
|
| comment
|
|
|
|
lookahead : '...' | '...!' # +'ve or -'ve lookahead
|
|
|
|
simpleitem : subrule args(?) rep(?) # match another rule
|
|
| terminal # match the next input
|
|
| bracket args(?) # match alternative items
|
|
| action # do something
|
|
|
|
subrule : identifier # the name of the rule
|
|
|
|
args : {extract_codeblock($_[0],'[]')} # just like a [...] array ref
|
|
|
|
rep : '(' repspec ')'
|
|
|
|
repspec : '?' # 0 or 1 times
|
|
| 's?' # 0 or more times
|
|
| 's' # 1 or more times
|
|
| /(\d+)[.][.](/\d+)/ # $1 to $2 times
|
|
| /[.][.](/\d*)/ # at most $1 times
|
|
| /(\d*)[.][.])/ # at least $1 times
|
|
|
|
terminal : /[/]([\][/]|[^/])*[/]/ # interpolated pattern
|
|
| /"([\]"|[^"])*"/ # interpolated literal
|
|
| /'([\]'|[^'])*'/ # uninterpolated literal
|
|
|
|
action : <perl_codeblock> # embedded Perl code
|
|
|
|
bracket : '(' production(s? /|/) ')' # alternative subrules
|
|
|
|
directive : '<commit>' # commit to production
|
|
| '<uncommit>' # cancel commitment
|
|
| '<resync>' # skip to newline
|
|
| '<resync:' pattern '>' # skip <pattern>
|
|
| '<reject>' # fail this production
|
|
| '<reject:' condition '>' # fail if <condition>
|
|
| '<error>' # report an error
|
|
| '<error:' string '>' # report error as "<string>"
|
|
| '<error?>' # error only if committed
|
|
| '<error?:' string '>' # " " " "
|
|
| '<rulevar:' /[^>]+/ '>' # define rule-local variable
|
|
| '<matchrule:' string '>' # invoke rule named in string
|
|
|
|
identifier : /[a-z]\w*/i # must start with alpha
|
|
|
|
comment : /#[^\n]*/ # same as Perl
|
|
|
|
pattern : {extract_bracketed($text,'<')} # allow embedded "<..>"
|
|
|
|
condition : {extract_codeblock($text,'{<')} # full Perl expression
|
|
|
|
string : {extract_variable($text)} # any Perl variable
|
|
| {extract_quotelike($text)} # or quotelike string
|
|
| {extract_bracketed($text,'<')} # or balanced brackets
|