From c10f66da9f740eb52c290e7d83ad9c17a73cafd9 Mon Sep 17 00:00:00 2001
From: jnthn <jnthn@jnthn.net>
Date: Thu, 6 Aug 2009 15:23:13 +0200
Subject: [PATCH] Make implementing a method postcircumfix:<( )> work so you
 can make an object invokable. This bumps required Parrot version.

---
 build/PARROT_REVISION |  2 +-
 src/builtins/guts.pir | 32 +++++++++++++++++++++++++++++
 src/parser/actions.pm |  5 ++++-
 src/pmc/p6opaque.pmc  | 47 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 84 insertions(+), 2 deletions(-)

diff --git a/build/PARROT_REVISION b/build/PARROT_REVISION
index 4bca7f73b2f..f356a6ba280 100644
--- a/build/PARROT_REVISION
+++ b/build/PARROT_REVISION
@@ -1 +1 @@
-40294
+40428
diff --git a/src/builtins/guts.pir b/src/builtins/guts.pir
index be11f87f036..8c159c9c9db 100644
--- a/src/builtins/guts.pir
+++ b/src/builtins/guts.pir
@@ -615,6 +615,10 @@ and creating the protoobjects.
     goto roles_it_loop
   roles_it_loop_end:
 
+    # We may need to set up invoke vtable if postcircumfix:<( )>
+    # is implemented.
+    '!setup_invoke_vtable'(metaclass)
+
     # Create proto-object with default parent being Any or Grammar, unless
     # there already is a parent.
     .local pmc proto
@@ -639,6 +643,34 @@ and creating the protoobjects.
 .end
 
 
+=item !setup_invoke_vtable
+
+If we override postcircumfix:<( )> then also add a
+vtable override for invoke.
+
+=cut
+
+.sub '!setup_invoke_vtable'
+    .param pmc metaclass
+    .local pmc parrotclass
+    parrotclass = getattribute metaclass, 'parrotclass'
+    $P0 = parrotclass.'methods'()
+    $P0 = $P0['postcircumfix:( )']
+    if null $P0 goto no_invoke
+    .const 'Sub' $P1 = '!invoke_vtable_override_helper'
+    parrotclass.'add_vtable_override'('invoke', $P1)
+  no_invoke:
+.end
+.sub '' :subid('!invoke_vtable_override_helper')
+    .param pmc pos_args    :slurpy
+    .param pmc named_args  :slurpy :named
+    $P0 = getinterp
+    $P0 = $P0['sub']
+    $P0 = getprop '$!self', $P0
+    .tailcall $P0.'postcircumfix:( )'(pos_args :flat, named_args :flat :named)
+.end
+
+
 =item !get_flattened_roles_list
 
 Flattens out the list of roles.
diff --git a/src/parser/actions.pm b/src/parser/actions.pm
index 0bb4286e48c..39081093c6d 100644
--- a/src/parser/actions.pm
+++ b/src/parser/actions.pm
@@ -1649,6 +1649,9 @@ method package_def($/, $key) {
     elsif !$block<isalso> {
         $block[0].push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) );
     }
+    else {
+        $block[0].push( PAST::Op.new( :name('!setup_invoke_vtable'), $?METACLASS) );
+    }
 
     make $block;
 }
@@ -3205,7 +3208,7 @@ sub make_sigparam($var) {
 sub add_optoken($block, $match) {
     my $category := ~$match<category>;
     my $name := $category ~ ':' ~ ~$match[0];
-    if $category ne 'trait_mod' {
+    if $category ne 'trait_mod' && $name ne 'postcircumfix:( )' {
         my $equiv := 'infix:+';
         if $category eq 'prefix' { $equiv := 'prefix:+' }
         elsif $category eq 'postfix' { $equiv := 'postfix:++' }
diff --git a/src/pmc/p6opaque.pmc b/src/pmc/p6opaque.pmc
index 3f436a6633c..1dfe09a2a85 100644
--- a/src/pmc/p6opaque.pmc
+++ b/src/pmc/p6opaque.pmc
@@ -18,6 +18,7 @@ end up containing various object behaviors that are specific to Perl 6.
 */
 
 #include "parrot/parrot.h"
+#include "parrot/oo.h"
 #include "parrot/oo_private.h"
 #include "pmc_class.h"
 #include "pmc_object.h"
@@ -316,4 +317,50 @@ back some kind of iterator to let us get all of the possible candidates.
 
         return method;
     }
+
+/*
+
+=item C<opcode_t *invoke(void *next)>
+
+Invokes the object (if this vtable function is overridden).
+
+=cut
+
+*/
+    opcode_t * invoke(void *next) {
+        Parrot_Object_attributes * const obj    = PARROT_OBJECT(pmc);
+        Parrot_Class_attributes  * const _class = PARROT_CLASS(obj->_class);
+
+        /* Walk and search for the vtable method. */
+        const int num_classes = VTABLE_elements(interp, _class->all_parents);
+        int i;
+
+        for (i = 0; i < num_classes; i++) {
+            /* Get the class. */
+            STRING * const meth_name = CONST_STRING(interp, "invoke");
+            STRING * const proxy     = CONST_STRING(interp, "proxy");
+            PMC * const cur_class =
+                VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
+
+            PMC * meth =
+                Parrot_oo_find_vtable_override_for_class(interp, cur_class,
+                                                         meth_name);
+            if (!PMC_IS_NULL(meth)) {
+                meth = VTABLE_clone(interp, meth);
+                VTABLE_setprop(interp, meth, CONST_STRING(interp, "$!self"), SELF);
+                return VTABLE_invoke(interp, meth, next);
+            }
+
+            if (cur_class->vtable->base_type == enum_class_PMCProxy) {
+                /* Get the PMC instance and call the vtable method on that. */
+                PMC * const del_object =
+                    VTABLE_get_attr_keyed(interp, pmc, cur_class, proxy);
+
+                if (!PMC_IS_NULL(del_object))
+                    return VTABLE_invoke(interp, del_object, next);
+            }
+        }
+
+        return (opcode_t *)interp->vtables[enum_class_default]->invoke(interp, pmc, next);
+    }
 }