develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r34020 - in trunk: . languages/perl6/config/makefiles languages/perl6/src/classes languages/perl6/src/parser

From:
jonathan
Date:
December 17, 2008 04:43
Subject:
[svn:parrot] r34020 - in trunk: . languages/perl6/config/makefiles languages/perl6/src/classes languages/perl6/src/parser
Message ID:
20081217124329.9D5AECBA12@x12.develooper.com
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);



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