Author: jonathan
Date: Wed Dec 17 04:43:28 2008
New Revision: 34020
Added:
trunk/languages/perl6/src/classes/Callable.pir (contents, props changed)
Modified:
trunk/MANIFEST
trunk/languages/perl6/config/makefiles/root.in
trunk/languages/perl6/src/classes/Code.pir
trunk/languages/perl6/src/classes/Role.pir
trunk/languages/perl6/src/parser/actions.pm
Log:
[rakudo] Add Callable role, make Code do it and make sure parameters with the &
sigil require it.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Wed Dec 17 04:43:28 2008
@@ -2127,6 +2127,7 @@
languages/perl6/src/classes/Associative.pir [perl6]
languages/perl6/src/classes/Block.pir [perl6]
languages/perl6/src/classes/Bool.pir [perl6]
+languages/perl6/src/classes/Callable.pir [perl6]
languages/perl6/src/classes/Capture.pir [perl6]
languages/perl6/src/classes/Code.pir [perl6]
languages/perl6/src/classes/Complex.pir [perl6]
Modified: trunk/languages/perl6/config/makefiles/root.in
==============================================================================
--- trunk/languages/perl6/config/makefiles/root.in (original)
+++ trunk/languages/perl6/config/makefiles/root.in Wed Dec 17 04:43:28 2008
@@ -55,6 +55,7 @@
src/classes/Protoobject.pir \
src/classes/Positional.pir \
src/classes/Associative.pir \
+ src/classes/Callable.pir \
src/classes/Any.pir \
src/classes/Bool.pir \
src/classes/Str.pir \
Added: trunk/languages/perl6/src/classes/Callable.pir
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/src/classes/Callable.pir Wed Dec 17 04:43:28 2008
@@ -0,0 +1,27 @@
+## $Id$
+
+=head1 NAME
+
+src/classes/Callable.pir - Callable Role
+
+=head1 DESCRIPTION
+
+=cut
+
+.namespace []
+
+.sub '' :anon :load :init
+ .local pmc callable
+ callable = '!keyword_role'('Callable')
+.end
+
+=back
+
+=cut
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Modified: trunk/languages/perl6/src/classes/Code.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Code.pir (original)
+++ trunk/languages/perl6/src/classes/Code.pir Wed Dec 17 04:43:28 2008
@@ -17,6 +17,8 @@
.local pmc p6meta, codeproto
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
codeproto = p6meta.'new_class'('Code', 'parent'=>'Any')
+ $P0 = get_hll_global 'Callable'
+ p6meta.'add_role'($P0, 'to'=>codeproto)
codeproto.'!IMMUTABLE'()
p6meta.'register'('Sub', 'parent'=>codeproto, 'protoobject'=>codeproto)
.end
Modified: trunk/languages/perl6/src/classes/Role.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Role.pir (original)
+++ trunk/languages/perl6/src/classes/Role.pir Wed Dec 17 04:43:28 2008
@@ -28,6 +28,14 @@
.sub 'ACCEPTS' :method
.param pmc topic
+
+ # Since we aren't re-blessing code objects yet, need to get and test their
+ # proto-object instead.
+ $I0 = topic.'isa'('Code')
+ unless $I0 goto no_proto
+ topic = topic.'WHAT'()
+ no_proto:
+
$I0 = does topic, self
$P0 = 'prefix:?'($I0)
.return ($P0)
Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm (original)
+++ trunk/languages/perl6/src/parser/actions.pm Wed Dec 17 04:43:28 2008
@@ -1189,13 +1189,15 @@
my $separator := $_[0];
my $is_invocant := 0;
+ # If it has & sigil, strip it off, but record it was a sub.
+ my $is_callable := 0;
+ if substr($parameter.name(), 0, 1) eq '&' {
+ $parameter.name(substr($parameter.name(), 1));
+ $is_callable := 1;
+ }
+
# Add parameter declaration to the block, if we're producing one.
unless $?SIG_BLOCK_NOT_NEEDED {
- # If it has & sigil, strip it off.
- if substr($parameter.name(), 0, 1) eq '&' {
- $parameter.name(substr($parameter.name(), 1));
- }
-
# Register symbol and put parameter PAST into the node.
$block_past.symbol($parameter.name(), :scope('lexical'));
$params.push($parameter);
@@ -1339,6 +1341,19 @@
$cur_param_types.push($type_obj);
}
+ # Also any constraint from the sigil.
+ if $is_callable {
+ $cur_param_types.push(PAST::Op.new(
+ :pasttype('call'),
+ :name('!TYPECHECKPARAM'),
+ PAST::Var.new( :name('Callable'), :scope('package') ),
+ PAST::Var.new(
+ :name($parameter.name()),
+ :scope('lexical')
+ )
+ ));
+ }
+
# For blocks, we just collect the check into the list of all checks.
unless $?SIG_BLOCK_NOT_NEEDED {
$type_check.push($cur_param_types);
