[svn:parrot] r35645 - in trunk/languages/perl6/src: classes parser

Author: jonathan
Date: Fri Jan 16 12:31:12 2009
New Revision: 35645

Modified:
   trunk/languages/perl6/src/classes/ClassHOW.pir
   trunk/languages/perl6/src/parser/actions.pm

Log:
[rakudo] Refactor dispatch. This now calls .HOW.dispatch, where we have a custom dispatcher, which will be filled out with more functionality in the future. Contains support for submethods, which appears to work (need to find/enable/write some spectests).

Modified: trunk/languages/perl6/src/classes/ClassHOW.pir
==============================================================================
--- trunk/languages/perl6/src/classes/ClassHOW.pir	(original)
+++ trunk/languages/perl6/src/classes/ClassHOW.pir	Fri Jan 16 12:31:12 2009
@@ -14,7 +14,7 @@
 
 =over
 
-=item does(self, role)
+=item does(object, role)
 
 Tests role membership.
 
@@ -34,6 +34,71 @@
     .tailcall 'prefix:?'($I0)
 .end
 
+
+=item dispatch(obj, name, ...)
+
+Dispatches to method of the given name on this class or one of its parents.
+
+=cut
+
+.sub 'dispatch' :method
+    .param pmc obj
+    .param string name
+    .param pmc pos_args  :slurpy
+    .param pmc name_args :slurpy :named
+
+    # Get MRO and an interator on it.
+    .local pmc parrotclass, mro, mro_it, cur_class, methods, candidate
+    parrotclass = getattribute self, 'parrotclass'
+    mro = inspect parrotclass, 'all_parents'
+    mro_it = iter mro
+
+    # Iterate MRO and check it's methods.
+    .local int have_pmc_proxy
+    have_pmc_proxy = 0
+  mro_loop:
+    unless mro_it goto mro_loop_end
+    cur_class = shift mro_it
+    $S0 = typeof cur_class
+    if $S0 == 'PMCProxy' goto pmc_proxy
+    methods = cur_class.'methods'()
+    candidate = methods[name]
+    if null candidate goto check_handles
+
+    # If we're not in the current class, need a submethod check.
+    eq_addr cur_class, parrotclass, submethod_check_done
+    $I0 = isa candidate, 'Submethod'
+    if $I0 goto check_handles
+  submethod_check_done:
+
+    # Got a method that we can call. XXX Set up exception handlers for if we
+    # have to do auto-threading of junctional arguments, additionally if we
+    # get a control expection for callsame or nextsame etc. Won't be able to
+    # be tailcall then...
+    .tailcall obj.candidate(pos_args :flat, name_args :flat :named)
+
+  check_handles:
+    # XXX This is where we will insert logic to run any regex or more complex
+    # 'handles' things to try and find a handler.
+    goto mro_loop
+
+  pmc_proxy:
+    # If we inherit from a PMC, we'll try doing the call directly later on.
+    # XXX Odd issues if we try and do it by introspective methods...
+    have_pmc_proxy = 1
+    goto mro_loop
+
+  mro_loop_end:
+    # If we get here, we didn't find anything to dispatch to; error unless a
+    # PMC can provide it.
+    unless have_pmc_proxy goto error
+    ($P0 :slurpy, $P1 :slurpy :named) = obj.name(pos_args :flat, name_args :flat :named)
+    .return ($P0 :flat, $P1 :named :flat)
+  error:
+    $P0 = getattribute self, 'longname'
+    'die'("Could not locate a method '", name, "' to invoke on class '", $P0, "'.")
+.end
+
 =back
 
 =cut

Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm	(original)
+++ trunk/languages/perl6/src/parser/actions.pm	Fri Jan 16 12:31:12 2009
@@ -1300,6 +1300,9 @@
                     $past[0] := $term;
                     $past.unshift($meth);
             }
+            elsif $past<invocant_holder> {
+                $past<invocant_holder>.unshift($term);
+            }
             else {
                 $past.unshift($term);
             }
@@ -1366,6 +1369,30 @@
         );
     }
 
+    # We actually need to send dispatches for named method calls (other than .*)
+    # through .HOW.dispatch.
+    if $key ne '.*' && $past.pasttype() eq 'callmethod' && $past.name() ne "" {
+        $past.unshift($past.name());
+        $past.name('dispatch');
+        my $inv_var := PAST::Var.new( :scope('register') );
+        $past.unshift($inv_var);
+        $past.unshift(PAST::Op.new(
+            :pasttype('callmethod'),
+            :name('HOW'),
+            $inv_var
+        ));
+        my $inv_set_node := PAST::Op.new(
+            :pasttype('bind'),
+            $inv_var,
+            PAST::Stmts.new()
+        );
+        $past := PAST::Stmts.new( $inv_set_node, $past );
+        $past<invocant_holder> := $inv_set_node[1];
+    }
+    else {
+        $past<invocant_holder> := $past;
+    }
+
     make $past;
 }
 
@@ -1442,7 +1469,7 @@
     elsif $key eq 'dotty' {
         # Call on $_.
         $past := $( $/{$key} );
-        $past.unshift(PAST::Var.new(
+        $past<invocant_holder>.unshift(PAST::Var.new(
             :name('$_'),
             :scope('lexical'),
             :viviself('Failure'),