Author: jonathan
Date: Sat Aug 16 09:51:54 2008
New Revision: 30270
Added:
trunk/languages/perl6/t/pmc/perl6multisub-dispatch-tiebreak.t (contents,
props changed)
Modified:
trunk/languages/perl6/src/pmc/perl6multisub.pmc
Log:
[rakudo] Tie-break on constraints, plus a test for this.
Modified: trunk/languages/perl6/src/pmc/perl6multisub.pmc
==============================================================================
--- trunk/languages/perl6/src/pmc/perl6multisub.pmc (original)
+++ trunk/languages/perl6/src/pmc/perl6multisub.pmc Sat Aug 16 09:51:54 2008
@@ -382,7 +382,7 @@
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 i, j, 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*);
@@ -435,7 +435,60 @@
cur_candidate++;
}
- /* XXX Loooooads of other disambiguation logic comes here. */
+ /* If we have multiple candidates left, tie-break on any constraints. */
+ if (possibles_count > 1) {
+ candidate_info **matching = mem_allocate_n_typed(possibles_count,
candidate_info*);
+ candidate_info **constraint_free =
mem_allocate_n_typed(possibles_count, candidate_info*);
+ INTVAL matching_count = 0;
+ INTVAL constraint_free_count = 0;
+ for (i = 0; i < possibles_count; i++) {
+ /* Check if we match any constraints. */
+ INTVAL constraint_checked = 0;
+ INTVAL constraint_failed = 0;
+ for (j = 0; j < possibles[i]->num_types; j++) {
+ PMC *type_obj = possibles[i]->constraints[j];
+ if (!PMC_IS_NULL(type_obj)) {
+ PMC *param = VTABLE_get_pmc_keyed_int(interp, args, j);
+ PMC *result = Parrot_runops_fromc_args(interp, type_obj,
+ "PP", param);
+ constraint_checked = 1;
+ if (!VTABLE_get_integer(interp, result)) {
+ constraint_failed = 1;
+ break;
+ }
+ }
+ }
+ if (!constraint_failed) {
+ if (constraint_checked) {
+ matching[matching_count] = possibles[i];
+ matching_count++;
+ }
+ else {
+ constraint_free[constraint_free_count] = possibles[i];
+ constraint_free_count++;
+ }
+ }
+ }
+
+ /* If we did find constraints to check, choose the matching over the
+ * ones without any constraints. */
+ if (matching_count) {
+ mem_sys_free(possibles);
+ mem_sys_free(constraint_free);
+ possibles = matching;
+ possibles_count = matching_count;
+ }
+ else if (constraint_free_count) {
+ mem_sys_free(possibles);
+ mem_sys_free(matching);
+ possibles = constraint_free;
+ possibles_count = constraint_free_count;
+ }
+ }
+
+ /* XXX Check is default trait */
+
+ /* XXX If still none/ambiguous, try and find a proto to call. */
if (!many) {
/* Need a unique candidate. */
Added: trunk/languages/perl6/t/pmc/perl6multisub-dispatch-tiebreak.t
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/t/pmc/perl6multisub-dispatch-tiebreak.t Sat Aug
16 09:51:54 2008
@@ -0,0 +1,93 @@
+#! ../../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(2)
+
+ 'constraint_tiebreak'()
+.end
+
+
+.sub 'constraint_tiebreak'
+ $P0 = new "Perl6MultiSub"
+ $P1 = find_global 'constraint_tiebreak_1'
+ $P2 = null
+ 'attach_sig'($P1, $P2)
+ push $P0, $P1
+ $P1 = find_global 'constraint_tiebreak_2'
+ $P2 = find_global 'constraint_tiebreak_2_con'
+ 'attach_sig'($P1, $P2)
+ push $P0, $P1
+
+ $P1 = new 'Int'
+ $P1 = 42
+ $I0 = $P0($P1)
+ is($I0, 2, 'constraint tie-breaks')
+ $P1 = 13
+ $I0 = $P0($P1)
+ is($I0, 1, 'constraint tie-breaks')
+.end
+.sub 'constraint_tiebreak_1'
+ .param pmc a
+ .return (1)
+.end
+.sub 'constraint_tiebreak_2'
+ .param pmc a
+ .return (2)
+.end
+.sub 'constraint_tiebreak_2_con'
+ .param int i
+ $I0 = i == 42
+ .return ($I0)
+.end
+
+.sub 'attach_sig'
+ .param pmc sub
+ .param pmc constraints :slurpy
+
+ # Make signature.
+ .local pmc any
+ any = get_hll_global 'Any'
+ $P0 = new 'Signature'
+ $P1 = new 'Perl6Array'
+ setattribute $P0, "@!params", $P1
+ .local pmc it, con
+ it = iter constraints
+ param_loop:
+ unless it goto param_loop_end
+ con = shift it
+ $P2 = new 'Perl6Hash'
+ $P2["type"] = any
+ $P2["constraints"] = con
+ 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:
