use v6-alpha;
grammar KindaPerl6::Grammar {
use KindaPerl6::Grammar::Regex;
use KindaPerl6::Grammar::Mapping;
use KindaPerl6::Grammar::Control;
use KindaPerl6::Grammar::Parameters;
use KindaPerl6::Grammar::Term;
use KindaPerl6::Grammar::Statements;
use KindaPerl6::Grammar::Quote;
use KindaPerl6::Grammar::Sub;
use KindaPerl6::Grammar::Token;
my $Class_name; # for diagnostic messages
sub get_class_name { $Class_name };
token ident_digit {
[ [ <?word> | _ | <?digit> ] <?ident_digit>
| <''>
]
};
token ident {
| [ <!before \d> <?word> | _ ] <?ident_digit>
[ ':<' <angle_quoted> '>' | '' ]
| ยข
};
token full_ident {
<?ident>
[ <'::'> <?full_ident>
| <''>
]
};
token namespace {
| <ident> '::'
[
| <namespace>
{ return [ $$<ident>, @( $$<namespace> ) ] }
|
{ return [ $$<ident> ] }
]
|
{ return [ ] }
};
token to_line_end {
| \N <?to_line_end>
| <''>
};
token pod_begin {
| \n <'=end'> <?to_line_end>
| . <?to_line_end> <?pod_begin>
};
token pod_other {
| \n <'=cut'> <?to_line_end>
| . <?to_line_end> <?pod_other>
};
token ws {
[
| <'#'> <?to_line_end>
| \n [
| <'=begin'> <?pod_begin>
| <'=kwid'> <?pod_other>
| <'=pod'> <?pod_other>
| <'=for'> <?pod_other>
| <'=head1'> <?pod_other>
| <''>
]
| \s
]
[ <?ws> | <''> ]
};
token opt_ws { <?ws> | <''> };
token opt_ws2 { <?ws> | <''> };
token opt_ws3 { <?ws> | <''> };
token parse {
| <comp_unit>
[
| <parse>
{ return [ $$<comp_unit>, @( $$<parse> ) ] }
| { return [ $$<comp_unit> ] }
]
| { return [] }
};
token unit_type {
<'class'> | <'grammar'> | <'role'> | <'module'>
};
token trait_auxiliary {
is | does | meta
};
token class_trait {
<trait_auxiliary> <?ws> <full_ident>
{ return [ $$<trait_auxiliary>, $$<full_ident> ] }
};
token class_traits {
| <class_trait>
[
| <?ws> <class_traits>
{ return [ $$<class_trait>, @( $$<class_traits> ) ] }
| { return [ $$<class_trait> ] }
]
| { return [] }
};
token comp_unit {
<?opt_ws> [\; <?opt_ws> | <''> ]
[ <'use'> <?ws> <'v6-'> <ident> <?opt_ws> \; <?ws> | <''> ]
[
<unit_type> <?opt_ws> <full_ident> <?opt_ws>
<class_traits> <?opt_ws>
<'{'>
{ $Class_name := ~$<full_ident> }
<?opt_ws>
{
COMPILER::add_pad( $Class_name );
}
<exp_stmts>
<?opt_ws>
<'}'>
<?opt_ws> [\; <?opt_ws> | <''> ]
{
my $env := @COMPILER::PAD[0];
COMPILER::drop_pad();
return ::CompUnit(
'unit_type' => $$<unit_type>,
'name' => $$<full_ident>,
'traits' => $$<class_traits>,
'attributes' => { },
'methods' => { },
'body' => ::Lit::Code(
pad => $env,
state => { },
sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ),
body => $$<exp_stmts>,
),
)
}
] | [
<?opt_ws>
{
$Class_name := 'Main';
COMPILER::add_pad( $Class_name );
}
<exp_stmts2>
{
my $env := @COMPILER::PAD[0];
COMPILER::drop_pad();
return ::CompUnit(
'unit_type' => 'module',
'name' => 'Main',
'traits' => [],
'attributes' => { },
'methods' => { },
'body' => ::Lit::Code(
pad => $env,
state => { },
sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ),
body => $$<exp_stmts2>,
),
)
}
]
};
token infix_op {
<'+'> | <'-'> | <'*'> | <'/'> | eq | ne | <'=='> | <'!='> | <'&&'> | <'||'> | <'~~'> | <'~'>
| '<=>'
| '<=' | '>='
| '<' | '>'
| '&' | '^' | '|'
| '..'
};
token hyper_op {
<'>>'> | <''>
};
token prefix_op {
[ '$' | '@' | '%' | '?' | '!' | '++' | '--' | '+' | '-' | '~' | '|' ]
<before '$' | '@' | '%'
| '(' | '{' | '['
>
};
token declarator {
<'my'> | <'state'> | <'has'> | <'our'>
};
token opt_declarator {
<declarator> <?ws> {return $$<declarator>;} | {return '';}
};
token exp2 { <exp> { return $$<exp> } };
token exp {
# { say 'exp: going to match <term_meth> at ', $/.to; }
<term_meth>
[
<?opt_ws>
<'??'>
[
<?opt_ws> <exp>
<?opt_ws> <'!!'>
<?opt_ws>
<exp2>
{
# XXX TODO - expand macro
# is &ternary:<?? !!> a macro?
my $macro_ast := ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'ternary:<?? !!>', namespace => [ ] );
my $macro := COMPILER::get_var( $macro_ast );
if defined($macro) {
# fetch the macro
my $sub := ( @COMPILER::PAD[0] ).eval_ast( $macro_ast );
Main::expand_macro( $sub, $$<term_meth>, $$<exp>, $$<exp2> );
# say "# ternary macro = ", $sub.perl;
}
return ::Apply(
'code' => ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'ternary:<?? !!>', namespace => [ ] ),
'arguments' => [ $$<term_meth>, $$<exp>, $$<exp2> ],
);
}
| { say '*** Syntax error in ternary operation' }
]
|
<?opt_ws>
<infix_op>
<?opt_ws>
<exp>
{ return ::Apply(
'code' => ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'infix:<' ~ $<infix_op> ~ '>', namespace => [ ] ),
'arguments' => [ $$<term_meth>, $$<exp> ],
) }
| <?opt_ws> <'::='> <?opt_ws> <exp>
{
my $bind := ::Bind( 'parameters' => $$<term_meth>, 'arguments' => $$<exp>);
COMPILER::begin_block( $bind ); # ::= compile-time
return $bind; # := run-time
}
| <?opt_ws> <':='> <?opt_ws> <exp>
{ return ::Bind( 'parameters' => $$<term_meth>, 'arguments' => $$<exp>) }
| <?opt_ws> <'='> <?opt_ws> <exp>
{ return ::Assign( 'parameters' => $$<term_meth>, 'arguments' => $$<exp>) }
| { return $$<term_meth> }
]
};
token opt_ident {
| <ident> { return $$<ident> }
| <''> { return 'postcircumfix:<( )>' }
};
token term_meth {
<full_ident>
[ \.
<hyper_op>
<ident>
[ \( <?opt_ws> <exp_parameter_list> <?opt_ws> \)
# { say 'found parameter list: ', $<exp_parameter_list>.perl }
| \: <?ws> <exp_parameter_list> <?opt_ws>
|
{
return ::Call(
'invocant' => ::Proto( 'name' => ~$<full_ident> ),
'method' => $$<ident>,
'arguments' => undef,
'hyper' => $$<hyper_op>,
)
}
]
{
return ::Call(
'invocant' => ::Proto( 'name' => ~$<full_ident> ),
'method' => $$<ident>,
'arguments' => $$<exp_parameter_list>,
'hyper' => $$<hyper_op>,
)
}
]
|
<term>
[ \.
<hyper_op>
<opt_ident> # $obj.(42)
[ \(
# { say 'testing exp_parameter_list at ', $/.to }
<?opt_ws> <exp_parameter_list> <?opt_ws> \)
# { say 'found parameter list: ', $<exp_parameter_list>.perl }
| \: <?ws> <exp_parameter_list> <?opt_ws>
|
{
return ::Call(
'invocant' => $$<term>,
'method' => $$<opt_ident>,
'arguments' => undef,
'hyper' => $$<hyper_op>,
)
}
]
{
return ::Call(
'invocant' => $$<term>,
'method' => $$<opt_ident>,
'arguments' => $$<exp_parameter_list>,
'hyper' => $$<hyper_op>,
)
}
| \[ <?opt_ws> <exp> <?opt_ws> \]
{ return ::Index( 'obj' => $$<term>, 'index' => $$<exp> ) } # $a[exp]
| \{ <?opt_ws> <exp> <?opt_ws> \}
{ return ::Lookup( 'obj' => $$<term>, 'index' => $$<exp> ) } # $a{exp}
| \< <angle_quoted> \>
{ return ::Lookup(
'obj' => $$<term>,
'index' => ::Val::Buf( 'buf' => ~$<angle_quoted> ),
)
} # $a<lit>
| { return $$<term> }
]
};
token sub_or_method_name {
<full_ident> [ \. <ident> | <''> ]
};
token opt_type {
| [ <'::'> | <''> ] <full_ident> { return $$<full_ident> }
| <''> { return '' }
};
token use_from_perl5 {
':from<perl5>' {return 1} | {return 0}
}
#token index { XXX }
#token lookup { XXX }
token sigil { \$ |\% |\@ |\& };
token twigil { [ \. | \! | \^ | \* ] | <''> };
# XXX unused?
# token var_name { <ident> | <'/'> | <digit> };
# used in Term.pm
token undeclared_var {
<sigil> <twigil> <namespace> <ident>
{
# no pre-declaration checks
return ::Var(
sigil => ~$<sigil>,
twigil => ~$<twigil>,
name => ~$<ident>,
namespace => $$<namespace>,
)
}
};
token var {
<sigil> '/'
{
return
::Var(
sigil => ~$<sigil>,
twigil => '',
name => '/',
namespace => [ ],
)
}
|
<sigil> <twigil> <namespace> <ident>
{
# check for pre-declaration
return COMPILER::get_var(
::Var(
sigil => ~$<sigil>,
twigil => ~$<twigil>,
name => ~$<ident>,
namespace => $$<namespace>,
)
)
}
};
token val {
| <val_undef> { return $$<val_undef> } # undef
# | $<exp> := <val_object> # (not exposed to the outside)
| <val_int> { return $$<val_int> } # 123
| <val_bit> { return $$<val_bit> } # True, False
| <val_num> { return $$<val_num> } # 123.456
| <val_buf> { return $$<val_buf> } # 'moose'
};
token val_bit {
| True { return ::Val::Bit( 'bit' => 1 ) }
| False { return ::Val::Bit( 'bit' => 0 ) }
};
token val_undef {
undef <!before \w >
{ return ::Val::Undef( ) }
};
token val_num {
XXX { return 'TODO: val_num' }
};
token digits { \d [ <digits> | <''> ] };
token val_int {
<digits>
{ return ::Val::Int( 'int' => ~$/ ) }
};
# XXX obsolete?
token exp_seq {
| <exp>
# { say 'exp_seq: matched <exp>' }
[
| <?opt_ws> \, <?opt_ws> <exp_seq>
<?opt_ws> [ \, <?opt_ws> | <''> ]
{ return [ $$<exp>, @( $$<exp_seq> ) ] }
| <?opt_ws> [ \, <?opt_ws> | <''> ]
{ return [ $$<exp> ] }
]
|
# { say 'exp_seq: end of match' }
{ return [] }
};
token lit {
#| <lit_seq> { return $$<lit_seq> } # (a, b, c)
#| <lit_array> { return $$<lit_array> } # [a, b, c]
#| <lit_hash> { return $$<lit_hash> } # {a => x, b => y}
#| <lit_code> { return $$<lit_code> } # sub $x {...}
| <lit_object> { return $$<lit_object> } # ::Tree(a => x, b => y);
};
token lit_seq { XXX { return 'TODO: lit_seq' } };
token lit_array { XXX { return 'TODO: lit_array' } };
token lit_hash { XXX { return 'TODO: lit_hash' } };
token lit_code { XXX { return 'TODO - Lit::Code' } };
token lit_object {
<'::'>
<full_ident>
\(
[
<?opt_ws> <exp_mapping> <?opt_ws> \)
{
# say 'Parsing Lit::Object ', $$<full_ident>, ($$<exp_mapping>).perl;
return ::Lit::Object(
'class' => $$<full_ident>,
'fields' => $$<exp_mapping>
)
}
| { say '*** Syntax Error parsing Constructor ',$$<full_ident>; die() }
]
};
#token bind {
# <exp> <?opt_ws> <':='> <?opt_ws> <exp2>
# {
# return ::Bind(
# 'parameters' => $$<exp>,
# 'arguments' => $$<exp2>,
# )
# }
#};
token call {
<exp> \. <ident> \( <?opt_ws> <exp_parameter_list> <?opt_ws> \)
{
return ::Call(
'invocant' => $$<exp>,
'method' => $$<ident>,
'arguments' => $$<exp_parameter_list>,
)
}
};
token apply {
<namespace> <ident>
[
[ \( <?opt_ws> <exp_parameter_list> <?opt_ws> \)
| <?ws> <exp_parameter_list> <?opt_ws>
]
{
return ::Apply(
'code' => COMPILER::get_var(
::Var(
sigil => '&',
twigil => '',
name => $$<ident>,
namespace => $$<namespace>,
) ),
'arguments' => $$<exp_parameter_list>,
)
}
|
{
return ::Apply(
'code' => COMPILER::get_var(
::Var(
sigil => '&',
twigil => '',
name => $$<ident>,
namespace => $$<namespace>,
) ),
'arguments' => [],
)
}
]
};
token opt_name { <ident> | '' };
token invocant {
| <var> \: { return $$<var> }
| { return undef }
};
token capture {
# TODO - exp_seq / exp_mapping == positional / named
# XXX use exp_parameter_list instead
| <exp>\: <?opt_ws> <exp_parameter_list>
{ return ::Capture( 'invocant' => $$<exp>, 'array' => $$<exp_parameter_list>, 'hash' => [ ] ); }
| <exp_mapping>
{ return ::Capture( 'invocant' => undef, 'array' => [ ], 'hash' => $$<exp_mapping> ); }
# ??? doesn't work here
#| <exp_parameter_list>
# { return ::Capture( 'invocant' => undef, 'array' => $$<exp_parameter_list>, 'hash' => [ ] ); }
};
token sig {
<invocant>
<?opt_ws>
# TODO - exp_seq / exp_mapping == positional / named
# ??? exp_parameter_list
<exp_seq>
{
# say ' invocant: ', ($$<invocant>).perl;
# say ' positional: ', ($$<exp_seq>).perl;
return ::Sig( 'invocant' => $$<invocant>, 'positional' => $$<exp_seq>, 'named' => { } );
}
};
token base_class { <full_ident> }
token subset {
# example: subset Not_x of Str where { $_ ne 'x' }
subset <?ws>
<full_ident> <?ws>
of <?ws>
<base_class> <?ws>
where
<?opt_ws> \{ <?opt_ws>
# { say ' parsing statement list ' }
{
COMPILER::add_pad();
}
<exp_stmts>
<?opt_ws>
[ \} | { say '*** Syntax Error in subset \'', get_class_name(), '.', $$<name>, '\' near pos=', $/.to; die 'error in Block'; } ]
{
# say ' block: ', ($$<exp_stmts>).perl;
my $env := @COMPILER::PAD[0];
COMPILER::drop_pad();
return ::Subset(
'name' => $$<full_ident>,
'base_class' =>
::Proto( name => $$<base_class> ),
'block' =>
::Sub(
'name' => undef,
'block' => ::Lit::Code(
pad => $env,
state => { },
sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ),
body => $$<exp_stmts>,
),
),
);
}
}
token begin_block {
BEGIN
<?opt_ws> \{ <?opt_ws>
{
COMPILER::add_pad();
}
<exp_stmts>
<?opt_ws>
[ \} | { say '*** Syntax Error in BEGIN near pos=', $/.to; die 'error in Block'; } ]
{
# say ' block: ', ($$<exp_stmts>).perl;
my $env := @COMPILER::PAD[0];
#print " grammar: dropping pad\n";
COMPILER::drop_pad();
#say "BEGIN block";
#print " grammar: entering begin block\n";
return COMPILER::begin_block(
# $env,
::Lit::Code(
pad => $env,
state => { },
sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ),
body => $$<exp_stmts>,
),
);
}
};
token check_block {
CHECK
<?opt_ws> \{ <?opt_ws>
<exp_stmts> <?opt_ws>
[ \} | { say '*** Syntax Error in CHECK block'; die 'error in Block'; } ]
{
#say "CHECK block";
return COMPILER::check_block( $$<exp_stmts> );
}
};
}
=begin
=head1 NAME
KindaPerl6::Grammar - Grammar for KindaPerl6
=head1 SYNOPSIS
my $match := $source.parse;
($$match).perl; # generated KindaPerl6 AST
=head1 DESCRIPTION
This module generates a syntax tree for the KindaPerl6 compiler.
=head1 AUTHORS
The Pugs Team E<lt>perl6-compiler@perl.orgE<gt>.
=head1 SEE ALSO
The Perl 6 homepage at L<http://dev.perl.org/perl6>.
The Pugs homepage at L<http://pugscode.org/>.
=head1 COPYRIGHT
Copyright 2006, 2007 by Flavio Soibelmann Glock, Audrey Tang and others.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=end