cvsuser 05/03/30 08:05:34
Modified: imcc imcc.y pbc.c
src global.c mmd.c
t/pmc mmd.t
Log:
MMD 11 - dispatch on PMC types
Revision Changes Path
1.160 +10 -2 parrot/imcc/imcc.y
Index: imcc.y
===================================================================
RCS file: /cvs/public/parrot/imcc/imcc.y,v
retrieving revision 1.159
retrieving revision 1.160
diff -u -r1.159 -r1.160
--- imcc.y 30 Mar 2005 09:07:27 -0000 1.159
+++ imcc.y 30 Mar 2005 16:05:31 -0000 1.160
@@ -620,8 +620,16 @@
| FLOATV { $$ = mk_const(interp, str_dup("FLOATVAL"), 'S'); }
| PMCV { $$ = mk_const(interp, str_dup("PMC"), 'S'); }
| STRINGV { $$ = mk_const(interp, str_dup("STRING"), 'S'); }
- | '_' { $$ = mk_const(interp, str_dup("PMC"), 'S'); }
- | IDENTIFIER { $$ = mk_const(interp, $1, 'S'); }
+ | IDENTIFIER {
+ SymReg *r;
+ if (strcmp($1, "_"))
+ r = mk_const(interp, $1, 'S');
+ else {
+ free($1),
+ r = mk_const(interp, str_dup("PMC"), 'S');
+ }
+ $$ = r;
+ }
;
sub_body:
1.116 +15 -0 parrot/imcc/pbc.c
Index: pbc.c
===================================================================
RCS file: /cvs/public/parrot/imcc/pbc.c,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -r1.115 -r1.116
--- pbc.c 30 Mar 2005 09:07:27 -0000 1.115
+++ pbc.c 30 Mar 2005 16:05:31 -0000 1.116
@@ -467,6 +467,9 @@
}
addr = jumppc + bsr->color;
if (bsr->set == 'p') {
+ Instruction *ins;
+ SymReg *r1;
+ struct pcc_sub_t *pcc_sub;
/*
* check in matching namespace
*/
@@ -474,7 +477,19 @@
/*
* if failed change opcode:
* set_p_pc => find_name p_sc
+ * the the sub is a multi too
*/
+ assert(s1->unit);
+ if (lab && (s1->unit->type & IMC_PCCSUB)) {
+ ins = s1->unit->instructions;
+ assert(ins);
+ r1 = ins->r[1];
+ assert(r1);
+ pcc_sub = r1->pcc_sub;
+ assert(pcc_sub);
+ if (pcc_sub->nmulti)
+ lab = NULL;
+ }
if (!lab) {
int op, col;
SymReg *nam;
1.17 +9 -2 parrot/src/global.c
Index: global.c
===================================================================
RCS file: /cvs/public/parrot/src/global.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- global.c 30 Mar 2005 11:12:35 -0000 1.16
+++ global.c 30 Mar 2005 16:05:33 -0000 1.17
@@ -1,6 +1,6 @@
/*
Copyright: 2004 The Perl Foundation. All Rights Reserved.
-$Id: global.c,v 1.16 2005/03/30 11:12:35 leo Exp $
+$Id: global.c,v 1.17 2005/03/30 16:05:33 leo Exp $
=head1 NAME
@@ -200,10 +200,17 @@
PMC *
Parrot_get_name(Interp* interpreter, STRING *name)
{
- PMC *g, *pad;
+ PMC *g, *pad, *current_sub, *name_space;
pad = scratchpad_get_current(interpreter);
g = scratchpad_find(interpreter, pad, name);
+ if (!g) {
+ current_sub = interpreter->ctx.current_sub;
+ if (current_sub &&
+ (name_space = PMC_sub(current_sub)->name_space))
+
+ g = Parrot_find_global_p(interpreter, name_space, name);
+ }
if (!g)
g = Parrot_find_global(interpreter, NULL, name);
if (!g)
1.57 +45 -8 parrot/src/mmd.c
Index: mmd.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd.c,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- mmd.c 30 Mar 2005 12:54:34 -0000 1.56
+++ mmd.c 30 Mar 2005 16:05:33 -0000 1.57
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: mmd.c,v 1.56 2005/03/30 12:54:34 leo Exp $
+$Id: mmd.c,v 1.57 2005/03/30 16:05:33 leo Exp $
=head1 NAME
@@ -884,6 +884,9 @@
*/
if (n > 1)
mmd_sort_candidates(interpreter, arg_tuple, candidate_list);
+ n = VTABLE_elements(interpreter, candidate_list);
+ if (!n)
+ return NULL;
/*
* 6) Uff, return first one
*/
@@ -982,8 +985,8 @@
static UINTVAL
mmd_distance(Interp *interpreter, PMC *pmc, PMC *arg_tuple)
{
- PMC *multi_sig;
- INTVAL i, n, args, dist;
+ PMC *multi_sig, *mro;
+ INTVAL i, n, args, dist, j, m;
INTVAL type_sig, type_call;
multi_sig = PMC_sub(pmc)->multi_signature;
@@ -1014,12 +1017,33 @@
type_call = VTABLE_get_integer_keyed_int(interpreter, arg_tuple, i);
if (type_sig == type_call)
continue;
- /* different native types are very different */
- if (type_sig <= 0 || type_call <= 0) {
+ /*
+ * different native types are very different, except a PMC
+ * which matches any PMC
+ */
+ if ((type_sig <= 0 && type_sig != enum_type_PMC) || type_call <= 0) {
dist = MMD_BIG_DISTANCE;
break;
}
- /* TODO now consider MRO of types */
+ /*
+ * now consider MRO of types the signature type has to be somewhere
+ * int the MRO of the type_call
+ */
+ mro = Parrot_base_vtables[type_call]->mro;
+ m = VTABLE_elements(interpreter, mro);
+ for (j = 0; j < m; ++j) {
+ PMC *cl = VTABLE_get_pmc_keyed_int(interpreter, mro, j);
+ if (cl->vtable->base_type == type_sig)
+ break;
+ ++dist;
+ }
+ /*
+ * if the type wasn't in MRO check, if any PMC matches
+ * in that case use the distance + 1 (of an any PMC parent)
+ */
+ if (j == m && type_sig != enum_type_PMC)
+ return MMD_BIG_DISTANCE;
+ ++dist;
}
return dist;
}
@@ -1075,6 +1099,13 @@
data = PMC_data(cl);
for (i = 0; i < n; ++i) {
INTVAL idx = helper[i] >> 16;
+ /*
+ * if the distance is big stop
+ */
+ if ((helper[i] & 0xffff) == MMD_BIG_DISTANCE) {
+ PMC_int_val(cl) = i;
+ break;
+ }
LVALUE_CAST(PMC*, helper[i]) = data[idx];
}
/*
@@ -1231,12 +1262,18 @@
static int
mmd_search_package(Interp *interpreter, STRING *meth, PMC *arg_tuple, PMC
*cl)
{
- STRING *name_space = interpreter->ctx.current_package;
+ /* STRING *name_space = interpreter->ctx.current_package; */
PMC *pmc;
+ PMC *current_sub;
+ PMC *name_space;
+ current_sub = interpreter->ctx.current_sub;
+ if (!current_sub)
+ return 0;
+ name_space = PMC_sub(current_sub)->name_space;
if (!name_space)
return 0;
- pmc = Parrot_find_global(interpreter, name_space, meth);
+ pmc = Parrot_find_global_p(interpreter, name_space, meth);
if (pmc) {
if (mmd_maybe_candidate(interpreter, pmc, arg_tuple, cl))
return 1;
1.19 +262 -2 parrot/t/pmc/mmd.t
Index: mmd.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/mmd.t,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- mmd.t 30 Mar 2005 14:04:40 -0000 1.18
+++ mmd.t 30 Mar 2005 16:05:34 -0000 1.19
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: mmd.t,v 1.18 2005/03/30 14:04:40 leo Exp $
+# $Id: mmd.t,v 1.19 2005/03/30 16:05:34 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 12;
+use Parrot::Test tests => 18;
pir_output_is(<<'CODE', <<'OUTPUT', "PASM divide");
@@ -405,3 +405,263 @@
ok 1
42
OUT
+
+pir_output_is(<<'CODE', <<'OUT', "MMD on PMC types");
+.namespace ["main"]
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = subclass "PerlString", "Xstring"
+ $P0 = new "Xstring"
+ $P0 = "ok 3\n"
+ $P1 = subclass "String", "Ystring"
+ $P1 = new "Ystring"
+ $P1 = "ok 4\n"
+ p($P0)
+ p($P1)
+.end
+
+.namespace [""]
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+CODE
+String ok 1
+PerlSt ok 2
+PerlSt ok 3
+String ok 4
+OUT
+
+pir_output_like(<<'CODE', <<'OUT', "MMD on PMC types, invalid");
+.namespace ["main"]
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = subclass "PerlString", "Xstring"
+ $P0 = new "Xstring"
+ $P0 = "ok 3\n"
+ $P1 = subclass "String", "Ystring"
+ $P1 = new "Ystring"
+ $P1 = "ok 4\n"
+ p($P0)
+ p($P1)
+ $P0 = new Integer
+ p($P0)
+.end
+
+.namespace [""]
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+CODE
+/String ok 1
+PerlSt ok 2
+PerlSt ok 3
+String ok 4
+Name 'p' not found/
+OUT
+
+pir_output_is(<<'CODE', <<'OUT', "MMD on PMC types 3");
+.namespace ["main"]
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = subclass "PerlString", "Xstring"
+ $P0 = new "Xstring"
+ $P0 = "ok 3\n"
+ $P1 = subclass "String", "Ystring"
+ $P1 = new "Ystring"
+ $P1 = "ok 4\n"
+ p($P0)
+ p($P1)
+ $P0 = new PerlInt
+ $P0 = 42
+ p($P0)
+.end
+
+.namespace [""]
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+
+.sub p @MULTI(Integer)
+ .param pmc p
+ print "Intege "
+ print p
+ print "\n"
+.end
+
+CODE
+String ok 1
+PerlSt ok 2
+PerlSt ok 3
+String ok 4
+Intege 42
+OUT
+
+pir_output_is(<<'CODE', <<'OUT', "MMD on PMC types, global namespace");
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = subclass "PerlString", "Xstring"
+ $P0 = new "Xstring"
+ $P0 = "ok 3\n"
+ $P1 = subclass "String", "Ystring"
+ $P1 = new "Ystring"
+ $P1 = "ok 4\n"
+ p($P0)
+ p($P1)
+.end
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+CODE
+String ok 1
+PerlSt ok 2
+PerlSt ok 3
+String ok 4
+OUT
+
+pir_output_is(<<'CODE', <<'OUT', "MMD on PMC types, package namespace");
+
+.namespace ["Some"]
+
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = subclass "PerlString", "Xstring"
+ $P0 = new "Xstring"
+ $P0 = "ok 3\n"
+ $P1 = subclass "String", "Ystring"
+ $P1 = new "Ystring"
+ $P1 = "ok 4\n"
+ p($P0)
+ p($P1)
+.end
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+CODE
+String ok 1
+PerlSt ok 2
+PerlSt ok 3
+String ok 4
+OUT
+
+pir_output_is(<<'CODE', <<'OUT', "MMD on PMC types - Any");
+
+.sub main @MAIN
+ $P0 = new String
+ $P0 = "ok 1\n"
+ $P1 = new PerlString
+ $P1 = "ok 2\n"
+ p($P0)
+ p($P1)
+ $P0 = new PerlInt
+ $P0 = 42
+ p($P0)
+ $P0 = new PerlInt
+ $P0 = 43
+ q($P0)
+.end
+
+.namespace [""]
+
+.sub p @MULTI(String)
+ .param pmc p
+ print "String "
+ print p
+.end
+
+.sub p @MULTI(PerlString)
+ .param pmc p
+ print "PerlSt "
+ print p
+.end
+
+.sub p @MULTI(_)
+ .param pmc p
+ print "Any "
+ print p
+ print "\n"
+.end
+
+.sub q @MULTI(pmc)
+ .param pmc p
+ print "Any "
+ print p
+ print "\n"
+.end
+
+CODE
+String ok 1
+PerlSt ok 2
+Any 42
+Any 43
+OUT
+
