develooper 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


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About