Front page | perl.perl6.internals |
Postings from June 2002
Re: Perl6 grammar
Thread Previous
|
Thread Next
From:
Sean O'Rourke
Date:
June 18, 2002 18:48
Subject:
Re: Perl6 grammar
Message ID:
Pine.GSO.4.33.0206181831350.21937-100000@beowulf.ucsd.edu
Based on perlop(1) and the note at the end of apocalypse 3, here's a start
on a Parse::RecDescent grammar for Perl 6 expressions. It does not handle
some variables; in particular, qq/${"foo"}/ won't fly. It should handle
precedence and hyping when adding new operators in the "right way". To
add a new operator with the same precedence as binary '+', you can do
something like
addsub_op: '=#$%'
and get the hyped '^=#$%' operator for free. If you don't want it to be
hyped, you can do this:
_addsub_op: '=#$%'
If you want it to be unary prefix, but with the same precedence, you can
do this:
addsub: '=#$%' muldiv
Fire away!
/s
use Parse::RecDescent;
use Data::Dumper;
use strict;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 1;
use Term::ReadLine;
my $grammar = <<'END';
{
use Regexp::Common;
}
<autotree>
# Literals:
literal: lit_int | lit_real | lit_string
lit_int: /$RE{num}{int}/
lit_real: /$RE{num}{real}/
lit_string: <perl_quotelike>
# Variables:
variable: sv | av | hv
sv: '$' name
av: '@' name
hv: '%' name
cv: '&' name
name: '{' name '}'
| sv
| /[\/\\^%&*\$\#@!_0-9]/
| ('::')(?) <leftop: /[\w_]+/ '::' /[\w_]+/>
# operators/expressions
hype: ('^')(?)
term: '(' expr ')'
| literal
| variable
left_list: left_list_op(?) term
left_list_op: 'left_list'
apply: <leftop: left_list _apply_op left_list>
_apply_op: hype apply_op
apply_op: '.'
incr: apply _incr_op
| _incr_op apply
| apply
_incr_op: hype incr_op
incr_op: '++' | '--'
pow: <rightop: incr _pow_op incr>
_pow_op: hype pow_op
pow_op: '**'
misc_unary: _misc_unary_op(?) pow
_misc_unary_op: hype misc_unary_op
misc_unary_op: '!' | '~' | '\\' | '+' | '-'
match: <leftop: misc_unary _match_op misc_unary>
_match_op: hype match_op
match_op: '=~' | '!~'
muldiv: <leftop: match _muldiv_op match>
_muldiv_op: hype muldiv_op
muldiv_op: '*' | '/' | '%' | 'x'
addsub: <leftop: muldiv _addsub_op muldiv>
_addsub_op: hype addsub_op
addsub_op: '+' | '-' | '_'
bitshift: <leftop: addsub _bitshift_op addsub>
_bitshift_op: hype bitshift_op
bitshift_op: '<<' | '>>'
named_unary: named_unary_op(s?) bitshift
named_unary_op: 'named_unary'
compare: <leftop: named_unary _compare_op named_unary>
_compare_op: hype compare_op
compare_op: '==' | '!=' | '<' | '>' | '<=' | '>=' | '<=>'
| 'eq' | 'ne' | 'lt' | 'gt' | 'le' | 'ge' | 'cmp'
bitand: <leftop: compare _bitand_op compare>
_bitand_op: hype bitand_op
bitand_op: '&'
bitor: <leftop: bitand _bitor_op bitand>
_bitor_op: hype bitor_op
bitor_op: '|' | '^'
logand: <leftop: bitor _logand_op bitor>
_logand_op: hype logand_op
logand_op: '&'
logor: <leftop: logand _logor_op logand>
_logor_op: hype logor_op
logor_op: '|' | '^'
range: logor (range_op logor)(?)
range_op: '...' | '..'
ternary: range ('?' ternary ':' ternary)(?)
assign: <rightop: ternary _assign_op ternary>
_assign_op: '^' assign_op
assign_op: assignable_op(?) '='
assignable_op: logand_op | logor_op
| bitand_op | bitor_op | bitshift_op
| addsub_op | muldiv_op | pow_op
| '!'
comma: <leftop: assign comma_op assign>
comma_op: ',' | '=>'
right_list: right_list_op(s?) comma
right_list_op: 'not' | 'right_list'
log_AND: <leftop: right_list _log_AND_op right_list>
_log_AND_op: hype log_AND_op
log_AND_op: 'and'
log_OR: <leftop: log_AND _log_OR_op log_AND>
_log_OR_op: hype log_OR_op
log_OR_op: 'or' | 'xor'
expr: log_OR
END
my $parser = new Parse::RecDescent $grammar or die $!;
sub simplify {
my $self = shift;
if (!ref $self) {
return $self;
} elsif (ref $self eq 'ARRAY') {
return join ' ', map { simplify($_) } @$self;
} elsif (exists $self->{__done__}) {
return '';
} else {
$self->{__done__} = 1;
if (exists $self->{__VALUE__}) {
return $self->{__VALUE__};
}
if ($self->{__RULE__} eq 'hype') {
return $self->{"'^'"}[0];
}
my @things = grep /\S/, map { simplify($self->{$_}) }
grep !/__(?:RULE|done)__/, keys %$self;
if (@things == 1) {
return $things[0];
} else {
return "($self->{__RULE__} ".(join ' ', @things).')';
}
}
}
my $term = new Term::ReadLine;
while (defined(local $_ = $term->readline('> '))) {
if (/^:(.*)/) {
print eval $1;
} else {
my $result = $parser->expr($_);
if ($::USE_DUMPER) {
print Dumper $result;
} else {
if ($result) {
print simplify($result), "\n";
} else {
print "parse error\n";
}
}
}
print "\n";
}
Thread Previous
|
Thread Next