# New Ticket Created by Stephane Payrard
# Please include the string: [perl #51658]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=51658 >
# use v6-alpha;
# use Test;
# plan 3;
# test for lexical self.
# and for some pair parsing and printing.
# should print :
# hi
# :a
# :!a
# :a(1)
# :a<1>
# :a(" > ")
class A { method h { "hi" }; method g { if (1) { self.h(); } } };
my $o = A.new;
# ok 'hi' eq $o.g()
say $o.h;
## See S02 for pair semantic
# note the test are dependant on the choice of the perl representation.
say :a.value; # Method 'perl' not found for invocant of class 'Boolean'
# should print True or Bool::True
say :a.perl;
# ok :a.perl eq ':a'
say :!a.perl;
# ok :!a.perl eq ':!a'
# not that the printing representation does not yet parse
# for the next two examples.
my $a = 1 ;
say :$a.perl;
# ok :$a.perl eq ':a(1)'
my $a = "1";
say :$a.perl;
# ok :$a.perl eq ':a<1>'
my $a = " > ";
say :$a.perl;
# ok :$a.perl eq ':a<1>'
# TBD; parse, but does not yet print
# my @a; @a[0]=1;
# say :@a.perl;
-----------------------
affected files :
languages/perl6/src/parser/actions.pm
languages/perl6/src/parser/grammar.pg
languages/perl6/src/classes/Pair.pir
Index: languages/perl6/src/parser/actions.pm
===================================================================
--- languages/perl6/src/parser/actions.pm (revision 26310)
+++ languages/perl6/src/parser/actions.pm (working copy)
@@ -30,10 +30,12 @@
our $?BLOCK;
our @?BLOCK;
our $?BLOCK_SIGNATURED;
+ our $?IS_METHOD;
+ our $?IN_METHOD;
## when entering a block, use any $?BLOCK_SIGNATURED if it exists,
## otherwise create an empty block with an empty first child to
## hold any parameters we might encounter inside the block.
- if ($key eq 'open') {
+ if $key eq 'open' {
if $?BLOCK_SIGNATURED {
$?BLOCK := $?BLOCK_SIGNATURED;
$?BLOCK_SIGNATURED := 0;
@@ -62,8 +64,18 @@
unless $?BLOCK.symbol('$!') {
$init.push( PAST::Var.new( :name('$!'), :isdecl(1) ) );
$?BLOCK.symbol( '$!', :scope('lexical') ); }
+ if $?IS_METHOD {
+ $init.push(PAST::Var.new(
+ :name('self'),
+ :isdecl(1)
+ ));
+ $?BLOCK.symbol('self', :scope('lexical'));
+ $?IS_METHOD := 0;
+ $init.push( PAST::Op.new( :inline( " store_lex 'self', self")));
+ }
+
}
- if ($key eq 'close') {
+ if $key eq 'close' {
my $past := @?BLOCK.shift();
$?BLOCK := @?BLOCK[0];
$past.push($($<statementlist>));
@@ -122,12 +134,12 @@
:pasttype('if'),
:node( $/ )
);
- if ( $<else> ) {
+ if $<else> {
my $else := $( $<else>[0] );
$else.blocktype('immediate');
$past.push( $else );
}
- while ($count != 0) {
+ while $count != 0 {
$count := $count - 1;
$expr := $( $<EXPR>[$count] );
$then := $( $<block>[$count] );
@@ -294,12 +306,12 @@
method statement_prefix($/) {
my $past := $($<statement>);
my $sym := ~$<sym>;
- if ($sym eq 'do') {
+ if $sym eq 'do' {
# fall through, just use the statement itself
}
## after the code in the try block is executed, bind $! to Undef,
## and set up the code to catch an exception, in case one is thrown
- elsif ($sym eq 'try') {
+ elsif $sym eq 'try' {
## Set up code to execute <statement> as a try node, and
## set $! to Undef if successful.
my $exitpir := " new %r, 'Undef'\n store_lex '$!', %r";
@@ -319,62 +331,58 @@
}
-method plurality_declarator($/) {
- my $past := $( $<routine_declarator> );
- if $<sym> eq 'multi' {
- my $pirflags := ~ $past.pirflags();
- my $arity := $past.arity();
- if $arity == 0 { $pirflags := $pirflags ~ ' :multi()'; }
- elsif $arity == 1 { $pirflags := $pirflags ~ ' :multi(_)'; }
- else {
- $pirflags := $pirflags ~ ' :multi(_';
- my $count := 1;
- while $count != $arity {
- $pirflags := $pirflags ~ ',_';
- $count := $count + 1;
+method routine($/, $key) {
+ our $?IS_METHOD;
+ our $?IN_METHOD;
+ if $key eq 'decls' {
+ $?IS_METHOD := 0;
+ $?IN_METHOD := 0;
+ if (~$<meth> eq 'method') {
+ $?IS_METHOD := 1; # reset in inner blocks
+ $?IN_METHOD := 1; # not reset in inner blocks
+ }
+ } else {
+ my $past := $($<routine_def>);
+ if $<decl> eq 'multi' {
+ my $pirflags := ~ $past.pirflags();
+ my $arity := $past.arity();
+ if $arity == 0 { $pirflags := $pirflags ~ ' :multi()'; }
+ elsif $arity == 1 { $pirflags := $pirflags ~ ' :multi(_)'; }
+ else {
+ $pirflags := $pirflags ~ ' :multi(_';
+ my $count := 1;
+ while $count != $arity {
+ $pirflags := $pirflags ~ ',_';
+ $count := $count + 1;
+ }
+ $pirflags := $pirflags ~ ')';
}
- $pirflags := $pirflags ~ ')';
+ $past.pirflags($pirflags);
}
- $past.pirflags($pirflags);
- }
- make $past;
-}
-
-method routine_declarator($/, $key) {
- if $key eq 'sub' {
- my $past := $($<routine_def>);
$past.blocktype('declaration');
+ if $?IN_METHOD {
+ $past.pirflags(':method');
+ }
$past.node($/);
make $past;
+
}
- elsif $key eq 'method' {
- my $past := $($<method_def>);
- $past.blocktype('declaration');
- $past.pirflags(':method');
- $past.node($/);
- make $past;
- }
}
-
method routine_def($/) {
+ our $?IS_METHOD;
my $past := $( $<block> );
if $<ident> {
$past.name( ~$<ident>[0] );
- our $?BLOCK;
- $?BLOCK.symbol(~$<ident>[0], :scope('package'));
+ if $?IS_METHOD {
+ our $?BLOCK;
+ $?BLOCK.symbol(~$<ident>[0], :scope('package'));
+ }
}
make $past;
}
-method method_def($/) {
- my $past := $( $<block> );
- if $<ident> {
- $past.name( ~$<ident>[0] );
- }
- make $past;
-}
method signature($/) {
my $params := PAST::Stmts.new( :node($/) );
@@ -468,7 +476,7 @@
method methodop($/, $key) {
my $past;
- if ($key eq 'null') {
+ if $key eq 'null' {
$past := PAST::Op.new();
}
else {
@@ -535,8 +543,12 @@
method noun($/, $key) {
my $past;
+ our $?IN_METHOD;
if $key eq 'self' {
- $past := PAST::Stmts.new( PAST::Op.new( :inline('%r = self'),
:node( $/ ) ) );
+ unless $?IN_METHOD {
+ $/.panic("can't use 'self' outside a method");
+ }
+ $past := PAST::Stmts.new( PAST::Op.new( :inline(" %r =
find_lex 'self'"), :node( $/ ) ) );
}
elsif $key eq 'undef' {
$past := PAST::Op.new(
@@ -781,6 +793,9 @@
method scoped($/) {
+ if $<typename> {
+ $/.panic('statically typed variables are not yet implemented');
+ }
my $past := $( $<variable_decl> );
make $past;
}
@@ -966,13 +981,13 @@
method circumfix($/, $key) {
my $past;
- if ($key eq '( )') {
+ if $key eq '( )' {
$past := $( $<statementlist> );
}
- if ($key eq '[ ]') {
+ if $key eq '[ ]' {
$past := $( $<statementlist> );
}
- elsif ($key eq '{ }') {
+ elsif $key eq '{ }' {
$past := $( $<pblock> );
}
make $past;
@@ -1048,15 +1063,15 @@
method quote_expression($/, $key) {
my $past;
- if ($key eq 'quote_regex') {
+ if $key eq 'quote_regex' {
$past := PAST::Block.new( $<quote_regex>,
:compiler('PGE::Perl6Regex'),
:blocktype('declaration'),
:node( $/ )
)
}
- elsif ($key eq 'quote_concat') {
- if ( +$<quote_concat> == 1 ) {
+ elsif $key eq 'quote_concat' {
+ if +$<quote_concat> == 1 {
$past := $( $<quote_concat>[0] );
}
else {
@@ -1090,10 +1105,10 @@
method quote_term($/, $key) {
my $past;
- if ($key eq 'literal') {
+ if $key eq 'literal' {
$past := PAST::Val.new( :value( ~$<quote_literal> ),
:returns('Perl6Str'), :node($/) );
}
- if ($key eq 'variable') {
+ if $key eq 'variable' {
$past := $( $<variable> );
}
make $past;
@@ -1127,9 +1142,9 @@
method semilist($/) {
my $past := PAST::Op.new( :node($/) );
- if ($<EXPR>) {
+ if $<EXPR> {
my $expr := $($<EXPR>[0]);
- if ($expr.name() eq 'infix:,') {
+ if $expr.name() eq 'infix:,' {
for @($expr) {
$past.push( $_ );
}
@@ -1144,10 +1159,10 @@
method listop($/, $key) {
my $past;
- if ($key eq 'arglist') {
+ if $key eq 'arglist' {
$past := $( $<arglist> );
}
- if ($key eq 'noarg') {
+ if $key eq 'noarg' {
$past := PAST::Op.new( );
}
$past.name( ~$<sym> );
@@ -1160,7 +1175,7 @@
method arglist($/) {
my $past := PAST::Op.new( :node($/) );
my $expr := $($<EXPR>);
- if ($expr.name() eq 'infix:,') {
+ if $expr.name() eq 'infix:,' {
for @($expr) {
$past.push( $_ );
}
@@ -1173,7 +1188,7 @@
method EXPR($/, $key) {
- if ($key eq 'end') {
+ if $key eq 'end' {
make $($<expr>);
}
else {
@@ -1239,13 +1254,12 @@
make $past;
}
-
method colonpair($/, $key) {
my $pair_key;
my $pair_val;
if $key eq 'false' {
- my $pair_key := PAST::Val.new( :value(~$<key>) );
+ $pair_key := PAST::Val.new( :value(~$<ident>) );
$pair_val := PAST::Var.new(
:name('False'),
:namespace('Bool'),
@@ -1253,10 +1267,9 @@
);
}
elsif $key eq 'value' {
- my $pair_key := PAST::Val.new( :value(~$<key>) );
+ $pair_key := PAST::Val.new( :value(~$<ident>) );
if $<postcircumfix> {
- # XXX TODO
- $/.panic('postcircumfix on colonpair not yet implemented');
+ $pair_val := PAST::Val.new( :value($<postcircumfix>))
}
else {
$pair_val := PAST::Var.new(
@@ -1266,7 +1279,12 @@
);
}
}
- else {
+ elsif $key eq 'varname' {
+ my $nm := $<variable><name>;
+ my $idx := $<variable><matchidx>;
+ $pair_key := PAST::Val.new( :value( ~$nm || ~$idx) );
+ $pair_val := $( $<variable> );
+ } else {
$/.panic($key ~ " pairs not yet implemented.");
}
Index: languages/perl6/src/parser/grammar.pg
===================================================================
--- languages/perl6/src/parser/grammar.pg (revision 26310)
+++ languages/perl6/src/parser/grammar.pg (working copy)
@@ -299,15 +299,11 @@
#### Subroutine and method definitions ####
-rule plurality_declarator {
- $<sym>=[multi|proto|only] <routine_declarator> {*}
+rule routine {
+ $<decl>=[multi|proto|only|''] $<meth>=[sub|method] {*} #= decls
+ <routine_def> {*} #= def
}
-token routine_declarator {
- | $<sym>='sub' <routine_def> {*} #= sub
- | $<sym>='method' <method_def> {*} #= method
-}
-
rule routine_def {
<ident>? <multisig>?
<trait>*
@@ -315,13 +311,6 @@
{*}
}
-rule method_def {
- <ident>? <multisig>?
- <trait>*
- <block>
- {*}
-}
-
rule trait {
| <trait_auxiliary>
| <trait_verb>
@@ -431,8 +420,7 @@
token noun {
| <package_declarator> {*} #= package_declarator
| <scope_declarator> {*} #= scope_declarator
- | <plurality_declarator> {*} #= plurality_declarator
- | <routine_declarator> {*} #= routine_declarator
+ | <routine> {*} #= routine
| <circumfix> {*} #= circumfix
| <variable> {*} #= variable
| <subcall> {*} #= subcall
@@ -479,7 +467,7 @@
rule scoped {
- <variable_decl> {*}
+ <typename>? <variable_decl> {*}
}
rule scope_declarator {
@@ -657,10 +645,10 @@
token colonpair {
':'
[
- | '!' <ident> {*} #= false
+ || '!' <ident> {*} #= false
| <ident> [ <.unsp>? <postcircumfix> ]? {*} #= value
| <postcircumfix> {*} #= structural
- | <sigil> <twigil>? <desigilname> {*} #= varname
+ | <variable> {*} #= varname
]
}
Index: languages/perl6/src/classes/Pair.pir
===================================================================
--- languages/perl6/src/classes/Pair.pir (revision 26310)
+++ languages/perl6/src/classes/Pair.pir (working copy)
@@ -17,6 +17,84 @@
$P1('Pair', 'Pair')
.end
+
+.sub get_string :method
+ $S0 = self.'perl'()
+ return ( $S0 )
+.end
+
+# should be pedagogical and gives the smartest representation of a pair
+.sub perl :method
+ $P0 = self.'key'()
+ $P1 = self.'value'()
+ $S0 = $P0.'WHAT'()
+ $S1 = $P1.'WHAT'()
+ if $S0 != 'Str' goto keyisnotstring
+ $S2 = $P0
+ $S3 = escape $S2
+ if $S3 != $S2 goto keyescaped
+ if $S1 != 'Bool' goto valnobool
+ $S5 = ":"
+ if $P1 goto trueval
+ concat $S5, "!"
+trueval:
+ concat $S5, $S2
+ .return ($S5)
+valnobool:
+ if $S1 == 'Str' goto valliteral
+ if $S1 == 'Int' goto valnum
+ if $S1 == 'Num' goto valnum
+ die "TBD"
+
+valliteral:
+ $S1 = $P1
+ $I0 = index $S1, '>'
+ if $I0 != -1 goto esc_val_litteral
+ $I0 = index $S1, '<'
+ if $I0 != -1 goto esc_val_litteral
+ $S6 = ":"
+ $S7 = $P0
+ concat $S6, $S7
+ concat $S6, '<'
+ $S7 = $P1
+ concat $S6, $S7
+ concat $S6, '>'
+ .return ( $S6 )
+
+esc_val_litteral:
+ $S1 = escape $S1
+ $S1 = concat '"', $S1
+ $S1 = concat $S1, '"'
+ $P1 = $S1 # fall-thru
+valnum:
+ $S6 = ":"
+ $S7 = $P0
+ concat $S6, $S7
+ concat $S6, '('
+ $S7 = $P1
+ concat $S6, $S7
+ concat $S6, ')'
+ .return ( $S6 )
+
+
+keyescaped:
+ die "TBD"
+
+keyisnotstring:
+ # ugly, probably not correct, certainly not yet supported
+ $S2 = "{ (my $p=Pair.new()), "
+ concat $S2, "$p[ "
+ $S3 = $P0.perl()
+ concat $S2, $S3
+ concat $S2, "] = "
+ $S3 = $P1.perl()
+ concat $S2, $S3
+ concat $S3, "}"
+keyissnottring:
+ die "TBD"
+.end
+
+
=back
=cut
bash-3.2$
