Author: jonathan
Date: Fri Aug 15 04:28:17 2008
New Revision: 30248
Added:
trunk/languages/perl6/t/pmc/perl6multisub-dispatch-type.t (contents, props
changed)
Modified:
trunk/languages/perl6/src/classes/Role.pir
trunk/languages/perl6/src/pmc/perl6multisub.pmc
Log:
[rakudo] Load types for parameters and use them to exclude candidates with
incompatible types. Add some tests for this.
Modified: trunk/languages/perl6/src/classes/Role.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Role.pir (original)
+++ trunk/languages/perl6/src/classes/Role.pir Fri Aug 15 04:28:17 2008
@@ -29,7 +29,8 @@
.sub 'ACCEPTS' :method
.param pmc topic
$I0 = does topic, self
- .return 'prefix:?'($I0)
+ $P0 = 'prefix:?'($I0)
+ .return ($P0)
.end
=back
Modified: trunk/languages/perl6/src/pmc/perl6multisub.pmc
==============================================================================
--- trunk/languages/perl6/src/pmc/perl6multisub.pmc (original)
+++ trunk/languages/perl6/src/pmc/perl6multisub.pmc Fri Aug 15 04:28:17 2008
@@ -60,6 +60,7 @@
PMC **types; /* Class or role type constraints for each
parameter. */
PMC **constraints; /* Refinement type constraints for each parameter
(if there
* are many, this will be a junction). */
+ INTVAL num_types; /* Number of entries in the above two arrays. */
} candidate_info;
@@ -276,6 +277,7 @@
info->types[j] = type;
info->constraints[j] = constraints;
}
+ info->num_types = sig_elems;
/* Add it to graph node, and initialize list of edges. */
graph[i] = mem_allocate_zeroed_typed(candidate_graph_node);
@@ -320,10 +322,13 @@
static PMC* do_dispatch(PARROT_INTERP, candidate_info** candidates, PMC *args,
int many,
int num_candidates, opcode_t *next) {
+ INTVAL i, type_check_count;
INTVAL num_args = VTABLE_elements(interp, args);
candidate_info **cur_candidate = candidates;
candidate_info **possibles = mem_allocate_n_typed(num_candidates,
candidate_info*);
INTVAL possibles_count = 0;
+ INTVAL type_mismatch;
+ STRING *ACCEPTS = CONST_STRING(interp, "ACCEPTS");
/* Iterate over the candidates and collect best ones; terminate
* when we see two nulls (may break out earlier). */
@@ -334,7 +339,25 @@
continue;
}
- /* XXX Check if it's admissable by type. */
+ /* Check if it's admissable by type. */
+ type_check_count = (*cur_candidate)->num_types > num_args ?
+ num_args : (*cur_candidate)->num_types;
+ type_mismatch = 0;
+ for (i = 0; i < type_check_count; i++) {
+ PMC *param = VTABLE_get_pmc_keyed_int(interp, args, i);
+ PMC *type_obj = (*cur_candidate)->types[i];
+ PMC *accepts_meth = VTABLE_find_method(interp, type_obj, ACCEPTS);
+ PMC *result = Parrot_run_meth_fromc_args(interp, accepts_meth,
type_obj,
+ ACCEPTS, "PP", param);
+ if (!VTABLE_get_integer(interp, result)) {
+ type_mismatch = 1;
+ break;
+ }
+ }
+ if (type_mismatch) {
+ cur_candidate++;
+ continue;
+ }
/* If we get here, it's an admissable candidate; add to list. */
possibles[possibles_count] = *cur_candidate;
@@ -466,8 +489,14 @@
VTABLE opcode_t *invoke(void *next) {
PMC *found;
- /* Need to make sure current continuation doesn't get destroyed. */
- PMC *saved_ccont = interp->current_cont;
+ /* Need to make sure a wobload of globals don't get destroyed. */
+ PMC *saved_ccont = interp->current_cont;
+ opcode_t *current_args = interp->current_args;
+ opcode_t *current_params = interp->current_params;
+ opcode_t *current_returns = interp->current_returns;
+ PMC *args_signature = interp->args_signature;
+ PMC *params_signature = interp->params_signature;
+ PMC *returns_signature = interp->returns_signature;
/* Make sure that we have a candidate list built. */
candidate_info **candidates = NULL;
@@ -486,8 +515,17 @@
found = do_dispatch(interp, candidates, get_args(interp), 0,
VTABLE_elements(interp, unsorted), next);
- /* Invoke what was found. */
+ /* Restore stuff that might have got overwriten by calls during the
+ * dispatch algorithm. */
interp->current_cont = saved_ccont;
+ interp->current_args = current_args;
+ interp->current_params = current_params;
+ interp->current_returns = current_returns;
+ interp->args_signature = args_signature;
+ interp->params_signature = params_signature;
+ interp->returns_signature = returns_signature;
+
+ /* Invoke the winner. */
return VTABLE_invoke(interp, found, next);
}
Added: trunk/languages/perl6/t/pmc/perl6multisub-dispatch-type.t
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/t/pmc/perl6multisub-dispatch-type.t Fri Aug 15
04:28:17 2008
@@ -0,0 +1,198 @@
+#! ../../parrot
+# Copyright (C) 2007-2008, The Perl Foundation.
+# $Id:$
+
+=head1 NAME
+
+t/pmc/perl6multisub-dispatch-type.t - Type based dispatch tests
+
+=head1 SYNOPSIS
+
+ % prove t/pmc/perl6multisub-dispatch-type.t
+
+=head1 DESCRIPTION
+
+Tests for type based dispatch using the Perl 6 MultiSub PMC.
+
+=cut
+
+.loadlib 'perl6_group'
+
+.sub main :main
+ .include 'include/test_more.pir'
+ load_bytecode "perl6.pbc"
+
+ plan(4)
+
+ 'basic_class'()
+ 'role'()
+ #'ordered_class'() # XXX Not passing until we do topological sort
+.end
+
+
+.sub 'basic_class'
+ $P0 = new "Perl6MultiSub"
+ $P1 = find_global 'basic_class_1'
+ 'attach_sig'($P1, 'Int')
+ push $P0, $P1
+ $P1 = find_global 'basic_class_2'
+ 'attach_sig'($P1, 'Junction')
+ push $P0, $P1
+
+ $P1 = new 'Int'
+ $P1 = 42
+ $I0 = $P0($P1)
+ is($I0, 1, 'dispatch on class')
+ $P1 = new 'Junction'
+ $I0 = $P0($P1)
+ is($I0, 2, 'dispatch on class')
+.end
+.sub 'basic_class_1'
+ .param pmc a
+ .return (1)
+.end
+.sub 'basic_class_2'
+ .param pmc a
+ .return (2)
+.end
+
+
+.sub 'role'
+ # Create a couple of roles.
+ .local pmc R1, R2
+ R1 = '!keyword_role'('R1')
+ R2 = '!keyword_role'('R2')
+
+ # Set up multis.
+ $P0 = new "Perl6MultiSub"
+ $P1 = find_global 'role_1'
+ 'attach_sig'($P1, 'R1')
+ push $P0, $P1
+ $P1 = find_global 'role_2'
+ 'attach_sig'($P1, 'R2')
+ push $P0, $P1
+
+ # Couple of classes that do the roles.
+ .local pmc C1, C2
+ C1 = new 'Class'
+ addrole C1, R1
+ C2 = new 'Class'
+ addrole C2, R2
+
+ # Tests
+ $P1 = new C1
+ $I0 = $P0($P1)
+ is($I0, 1, 'dispatch on a role')
+ $P1 = new C2
+ $I0 = $P0($P1)
+ is($I0, 2, 'dispatch on a role')
+.end
+.sub 'role_1'
+ .param pmc a
+ .return (1)
+.end
+.sub 'role_2'
+ .param pmc a
+ .return (2)
+.end
+
+
+.sub 'ordered_class'
+ # Create 3 classes.
+ .local pmc p6meta
+ p6meta = get_hll_global ['Perl6Object'], '$!P6META'
+ p6meta.'new_class'('Paper', 'parent'=>'Any')
+ p6meta.'new_class'('Scissors', 'parent'=>'Any')
+ p6meta.'new_class'('Stone', 'parent'=>'Any')
+
+ $P0 = new "Perl6MultiSub"
+ $P1 = find_global 'ordered_class_1'
+ 'attach_sig'($P1, 'Any', 'Any')
+ push $P0, $P1
+ $P1 = find_global 'ordered_class_2'
+ 'attach_sig'($P1, 'Paper', 'Stone')
+ push $P0, $P1
+ $P1 = find_global 'ordered_class_3'
+ 'attach_sig'($P1, 'Stone', 'Scissors')
+ push $P0, $P1
+ $P1 = find_global 'ordered_class_4'
+ 'attach_sig'($P1, 'Scissors', 'Paper')
+ push $P0, $P1
+
+ .local pmc paper, scissors, stone
+ paper = get_hll_global 'Paper'
+ paper = paper.'new'()
+ scissors = get_hll_global 'Scissors'
+ scissors = scissors.'new'()
+ stone = get_hll_global 'Stone'
+ stone = stone.'new'()
+
+ $I0 = $P0(paper, paper)
+ is($I0, 0, 'basic class')
+ $I0 = $P0(paper, scissors)
+ is($I0, 0, 'basic class')
+ $I0 = $P0(paper, stone)
+ is($I0, 1, 'basic class')
+ $I0 = $P0(scissors, paper)
+ is($I0, 1, 'basic class')
+ $I0 = $P0(scissors, scissors)
+ is($I0, 0, 'basic class')
+ $I0 = $P0(scissors, stone)
+ is($I0, 0, 'basic class')
+ $I0 = $P0(stone, paper)
+ is($I0, 0, 'basic class')
+ $I0 = $P0(stone, scissors)
+ is($I0, 1, 'basic class')
+ $I0 = $P0(stone, stone)
+ is($I0, 0, 'basic class')
+.end
+.sub 'ordered_class_1'
+ .param pmc a
+ .param pmc b
+ .return (0)
+.end
+.sub 'ordered_class_2'
+ .param pmc a
+ .param pmc b
+ .return (1)
+.end
+.sub 'ordered_class_3'
+ .param pmc a
+ .param pmc b
+ .return (1)
+.end
+.sub 'ordered_class_4'
+ .param pmc a
+ .param pmc b
+ .return (1)
+.end
+
+.sub 'attach_sig'
+ .param pmc sub
+ .param pmc types :slurpy
+
+ # Make signature.
+ $P0 = new 'Signature'
+ $P1 = new 'Perl6Array'
+ setattribute $P0, "@!params", $P1
+ .local pmc it, type
+ it = iter types
+ param_loop:
+ unless it goto param_loop_end
+ $P3 = shift it
+ $S0 = $P3
+ type = get_hll_global $S0
+ $P2 = new 'Perl6Hash'
+ $P2["type"] = type
+ push $P1, $P2
+ goto param_loop
+ param_loop_end:
+
+ setprop sub, '$!signature', $P0
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
