Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
added primitive support for subroutine signatures 
It can basically handle only $ and @-tokens, where $-tokens are (wrongly)
treated as optionals. Calling a $$-sub with three args will die already.
  • Loading branch information
@FROGGS
FROGGS committed May 29, 2013
1 parent 7673bed commit ebdb97d
Show file tree
Hide file tree
Showing 3 changed files with 76 additions and 96 deletions.
30 changes: 10 additions & 20 deletions STATUS.md
View file
Expand Up @@ -1151,7 +1151,7 @@ No such symbol '&skip_all_without_config'
</td></tr>
<tr align=center><td align=left rowspan=2>op/utftaint.v5</td><td>0</td><td>3</td><td>0</td><td>0</td><td>3</td></tr>
<tr><td colspan=5>===SORRY!===
Placeholder variable H^ash[0x12643a08] may not be used here because the surrounding block takes no signature
Placeholder variable H^ash[0x10f8fb70] may not be used here because the surrounding block takes no signature
at t/spec/op/utftaint.v5:15
------> not eval { join("",@_), kill 0; 1 }⏏;</td></tr>
<tr align=center><td align=left rowspan=2>run/noswitch.v5</td><td>0</td><td>3</td><td>0</td><td>0</td><td>3</td></tr>
Expand Down Expand Up @@ -2061,21 +2061,10 @@ Unrecognized Perl 5 regex backslash sequence
at t/spec/op/die.v5:86
------> like( $@, qr/Global symbol "\$\⏏x{3b1}"/, 'utf8 symbol names show up in</td></tr>
<tr align=center><td align=left rowspan=2>op/die_keeperr.v5</td><td>0</td><td>20</td><td>0</td><td>0</td><td>20</td></tr>
<tr><td colspan=5>WARNINGS:
Useless use of constant integer 1 in sink context (line 46)
No such symbol '&sub'
in method <anon> at src/gen/CORE.setting:10070
in any at src/gen/Metamodel.nqp:2504
in any find_method_fallback at src/gen/Metamodel.nqp:2492
in any find_method at src/gen/Metamodel.nqp:939
in block at t/spec/op/die_keeperr.v5:20
in method reify at src/gen/CORE.setting:5775
in method reify at src/gen/CORE.setting:5670
in method gimme at src/gen/CORE.setting:6101
in method eager at src/gen/CORE.setting:6080
in block at t/spec/op/die_keeperr.v5:17

</td></tr>
<tr><td colspan=5>===SORRY!===
Two terms in a row
at t/spec/op/die_keeperr.v5:23
------> my $e = end ⏏{ die $inx if $inx };</td></tr>
<tr align=center><td align=left rowspan=2>comp/redef.v5</td><td>0</td><td>20</td><td>0</td><td>0</td><td>20</td></tr>
<tr><td colspan=5>===SORRY!===
No such symbol '&sub'
Expand Down Expand Up @@ -2307,8 +2296,9 @@ Could not find vars in any of: ../lib
</td></tr>
<tr align=center><td align=left rowspan=2>comp/uproto.v5</td><td>0</td><td>43</td><td>0</td><td>0</td><td>43</td></tr>
<tr><td colspan=5>===SORRY!===
No such symbol '&sub'
</td></tr>
Unable to parse expression in argument list; couldn't find final ')'
at t/spec/comp/uproto.v5:58
------> f("FOO xy", $foo, ⏏"xy");</td></tr>
<tr align=center><td align=left rowspan=2>io/perlio.v5</td><td>0</td><td>45</td><td>0</td><td>0</td><td>45</td></tr>
<tr><td colspan=5>===SORRY!===
No such symbol '&Config'
Expand Down Expand Up @@ -2420,7 +2410,7 @@ at t/spec/op/localref.v5:20
at t/spec/op/loopctl.v5:964
------> for ($i = 1; my $x ⏏= $i; ) {
===SORRY!===
Could not find sub cuid_97_1369502765.67695
Could not find sub cuid_97_1369819366.93229
</td></tr>
<tr align=center><td align=left rowspan=2>op/time.v5</td><td>0</td><td>66</td><td>0</td><td>0</td><td>66</td></tr>
<tr><td colspan=5>No such symbol '&watchdog'
Expand Down Expand Up @@ -2677,7 +2667,7 @@ Could not find Tie::Array in any of: /home/froggs/dev/nqp/install/lib/parrot/5.2
</td></tr>
<tr align=center><td align=left rowspan=2>op/substr.v5</td><td>0</td><td>387</td><td>0</td><td>0</td><td>387</td></tr>
<tr><td colspan=5>===SORRY!===
Method 'ast' not found for invocant of class 'NQPMu'
get_iter() not implemented in class 'NQPMu'
</td></tr>
<tr align=center><td align=left rowspan=2>re/pat_re_eval.v5</td><td>0</td><td>463</td><td>0</td><td>0</td><td>463</td></tr>
<tr><td colspan=5>===SORRY!===
Expand Down
78 changes: 23 additions & 55 deletions lib/Perl5/Actions.nqp
View file
Expand Up @@ -3110,10 +3110,10 @@ class Perl5::Actions is HLL::Actions does STDActions {
%info<is_multi_invocant> := $multi_invocant;
@parameter_infos.push(%info);
}
%signature<parameters> := @parameter_infos;
if $<typename> {
%signature<returns> := $<typename>.ast;
}
}
%signature<parameters> := @parameter_infos;
if $<typename> {
%signature<returns> := $<typename>.ast;
}

# Mark current block as having a signature.
Expand Down Expand Up @@ -4040,6 +4040,7 @@ class Perl5::Actions is HLL::Actions does STDActions {
if nqp::substr($final, 0, 1) ne '&' {
@name[+@name - 1] := '&' ~ $final;
}
# XXX do we have macros?
my $macro := find_macro_routine(@name);
if $macro {
$past := expand_macro($macro, $*longname.text, $/, sub () {
Expand All @@ -4051,9 +4052,9 @@ class Perl5::Actions is HLL::Actions does STDActions {
}
}
}
elsif $<args><arglist> {
if $<args><arglist><EXPR> {
add_macro_arguments($<args><arglist><EXPR>.ast, @argument_asts);
elsif $<args><arglist><arg> {
if $<args><arglist><arg>[0]<EXPR> {
add_macro_arguments($<args><arglist><arg>[0]<EXPR>.ast, @argument_asts);
}
}
return @argument_asts;
Expand All @@ -4079,9 +4080,11 @@ class Perl5::Actions is HLL::Actions does STDActions {

# Do we know all the arguments at compile time?
my int $all_compile_time := 1;
for @($<arglist>.ast) {
unless $_.has_compile_time_value {
$all_compile_time := 0;
if $<arglist><arg> {
for @($<arglist><arg>.ast) {
unless $_.has_compile_time_value {
$all_compile_time := 0;
}
}
}
if $all_compile_time {
Expand Down Expand Up @@ -4213,53 +4216,18 @@ class Perl5::Actions is HLL::Actions does STDActions {

method arglist($/) {
$V5DEBUG && say("arglist($/)");
my $Pair := $*W.find_symbol(['Pair']);
my $past := QAST::Op.new( :op('call'), :node($/) );
if $<EXPR> {
# Make first pass over arguments, finding any duplicate named
# arguments.
my $expr := $<EXPR>.ast;
my @args := nqp::istype($expr, QAST::Op) && $expr.name eq '&infix:<,>'
?? $expr.list
!! [$expr];
my %named_counts;
for @args {
if nqp::istype($_, QAST::Op) && istype($_.returns, $Pair) {
my $name := compile_time_value_str($_[1], 'LHS of pair', $/);
%named_counts{$name} := +%named_counts{$name} + 1;
$_[2].named($name);
}
}

# Make result.
for @args {
if nqp::istype($_, QAST::Op) && istype($_.returns, $Pair) {
my $name := $_[2].named();
if %named_counts{$name} == 1 {
$past.push($_[2]);
$_[2]<before_promotion> := $_;
}
else {
%named_counts{$name} := %named_counts{$name} - 1;
my $past := QAST::Op.new( :op('call'), :node($/) );
if $<arg> {
for $<arg> -> $arg {
if $arg<EXPR> {
my $expr := $arg<EXPR>.ast;
my @args := nqp::istype($expr, QAST::Op) && $expr.name eq '&infix:<,>'
?? $expr.list
!! [$expr];
for @args {
$past.push($_);
}
}
elsif nqp::istype($_, QAST::Op) && $_.name eq '&prefix:<|>' {
my $reg := $past.unique('flattening_');
$past.push(QAST::Op.new(
:op('callmethod'), :name('FLATTENABLE_LIST'),
QAST::Op.new(
:op('bind'),
QAST::Var.new( :name($reg), :scope('local'), :decl('var') ),
$_[0]),
:flat(1) ));
$past.push(QAST::Op.new(
:op('callmethod'), :name('FLATTENABLE_HASH'),
QAST::Var.new( :name($reg), :scope('local') ),
:flat(1), :named(1) ));
}
else {
$past.push($_);
}
}
}

Expand Down
64 changes: 43 additions & 21 deletions lib/Perl5/Grammar.nqp
View file
Expand Up @@ -1399,14 +1399,14 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
$*MAIN := 'MAIN';
} ]?
|| <module_name> <version=versionish>?
[ <.spacey> <arglist> <?{ $<arglist><EXPR> }> ]?
[ <.spacey> <arglist> <?{ $<arglist><arg>[0]<EXPR> }> ]?
{
my $longname := ~$<module_name><longname>;
my $arglist;

if $<arglist> {
if $<arglist><arg>[0]<EXPR> {
$arglist := $*W.compile_time_evaluate($/,
$<arglist><EXPR>.ast);
$<arglist><arg>[0]<EXPR>.ast);
$arglist := nqp::getattr($arglist.list.eager,
$*W.find_symbol(['List']), '$!items');
}
Expand Down Expand Up @@ -1488,14 +1488,14 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
token statement_control:sym<no> {
<sym> <.ws>
<module_name>
[ <.spacey> <arglist> <?{ $<arglist><EXPR> }> ]?
[ <.spacey> <arglist> <?{ $<arglist><arg>[0]<EXPR> }> ]?
{
my $longname := ~$<module_name><longname>;
my $arglist;

if $<arglist> {
if $<arglist><arg>[0]<EXPR> {
$arglist := $*W.compile_time_evaluate($/,
$<arglist><EXPR>.ast);
$<arglist><arg>[0]<EXPR>.ast);
$arglist := nqp::getattr($arglist.list.eager,
$*W.find_symbol(['List']), '$!items');
}
Expand Down Expand Up @@ -1948,7 +1948,7 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {

rule parensig {
:dba('signature')
'(' ~ ')' <signature(1)>
'(' ~ ')' <signature>
}

method checkyada () {
Expand Down Expand Up @@ -1989,17 +1989,18 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
# <.getsig>
# ] || <.panic: "Malformed routine">
# }
my %prototype;
rule routine_def {
:my $*IN_DECL := 'sub';
:my $*METHODTYPE;
:my $*IMPLICIT := 0;
:my $*DOC := $*DECLARATOR_DOCS;
:my $*DOCEE;
:my $*DECLARAND := $*W.stub_code_object('Sub');
:my $*PROTOTYPE;
<deflongname>
<.newlex>
<parensig>?
#[ '(' <multisig> ')' ]?
[ <parensig> { %prototype{ ~$<deflongname> } := ~$*PROTOTYPE } ]?
<trait>*
{ $*IN_DECL := 0; }
<blockoid>
Expand Down Expand Up @@ -2902,9 +2903,13 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {

rule param_sep { [','|':'|';'|';;'] }

token signature($*PROTOTYPE = 0) {
|| <?{ $*PROTOTYPE }> $<params>=['$'|'@'|'%'|'&'|'*'|'+'|';'|'_']*
|| <!{ $*PROTOTYPE }> <variable_declarator>+ % [ <.ws> ',' <.ws> ]
token proto_arg {
$<arg>=['$'|'@'|'%'|'&'|'*'|'+'|';'|'_']
}

token signature {
|| <?{ $*IN_DECL eq 'sub' }> $<params>=['$'|'@'|'%'|'&'|'*'|'+'|';'|'_']* { $*PROTOTYPE := ~$<params> }
|| <?{ $*IN_DECL ne 'sub' }> <variable_declarator>+ % [ <.ws> ',' <.ws> ]
}

token type_constraint {
Expand Down Expand Up @@ -3093,8 +3098,8 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
]?
}

token semiarglist {
<arglist> +% ';'
token semiarglist($prototype = '@') {
<arglist($prototype)> +% ';'
<.ws>
}

Expand All @@ -3118,14 +3123,29 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
# }}
# ]
# }
token arglist {

token arg($*PROTOTYPE = '@') {
:dba('argument')
[
#| <?stdstopper>
| <?{ $*PROTOTYPE eq '@' }> <EXPR('f=')>
| <?{ $*PROTOTYPE eq '$' }> <EXPR('h=')> { $*ARGUMENT_HAVE := $*ARGUMENT_HAVE + 1 }
| <?{ $*PROTOTYPE eq ';' }> # TODO last arg has lower prec (to allow lvalue sub call)
#| <?>
]
}

token arglist($prototype = '@') {
:my $*GOAL := 'endargs';
:my $*QSIGIL := '';
:my $s := $prototype;
:my $n := '';
:my $i := 0;
<.ws>
:dba('argument list')
[
| <?stdstopper>
| <EXPR('f=')>
| [ <?{ $n := nqp::substr($s, $i, 1); $i := $i + 1; $n }> <arg($n)> ]+ % [ <.ws> ',' <.ws> ]
#| <?>
]
}
Expand Down Expand Up @@ -3688,10 +3708,12 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
# }
token term:sym<identifier> {
:my $name;
:my $*ARGUMENT_WANT := 0;
:my $*ARGUMENT_HAVE := 0;
<identifier> <!{ ~$<identifier> ~~ /^ [ 'm' || 'q' || 'qq' || 'qr' || 'qw' || 'my' ] $/; }>
{ $name := ~$<identifier>; }
{ $name := ~$<identifier>; %prototype{$name} := '@' unless nqp::defined(%prototype{$name}) }
[\h+ <?[(]>]?
<args( $*W.is_type($name) )>
<args(%prototype{$name})>
# no compile-time checking for subs
# { self.add_mystery($<identifier>, $<args>.from, nqp::substr(~$<args>, 0, 1)) unless $<args><invocant>; }
}
Expand All @@ -3710,14 +3732,14 @@ grammar Perl5::Grammar is HLL::Grammar does STD5 {
# ]
# { $<invocant> := $*INVOCANT_IS; }
# }
token args($istype = 0) {
token args($prototype = '@') {
:my $*GOAL := '';
:dba('argument list')
[
| '(' ~ ')' <semiarglist>
| '(' ~ ')' <semiarglist($prototype)>
#| <.unsp> '(' ~ ')' <semiarglist>
#| [<?before \s> <!{ $istype }> <.ws> <!infixstopper> <arglist>]?
| [ \s <arglist> ]
| \s <arglist($prototype)>
| <?>
]
}
Expand Down

0 comments on commit ebdb97d

Please sign in to comment.