cvsuser 05/03/30 03:12:36
Modified: include/parrot global.h
ops var.ops
src global.c mmd.c
t/pmc mmd.t
Log:
MMD 8 - dispatch on argument count
* see note on p6i
* implement Parrot_find_global_p function that
searches in a namespace (key) PMC or in a Hash
Revision Changes Path
1.7 +3 -1 parrot/include/parrot/global.h
Index: global.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/global.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- global.h 30 Mar 2005 09:07:28 -0000 1.6
+++ global.h 30 Mar 2005 11:12:32 -0000 1.7
@@ -1,7 +1,7 @@
/* global.h
* Copyright: 2004 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: global.h,v 1.6 2005/03/30 09:07:28 leo Exp $
+ * $Id: global.h,v 1.7 2005/03/30 11:12:32 leo Exp $
* Overview:
* Contains accessor functions for globals
* Data Structure and Algorithms:
@@ -15,6 +15,8 @@
PMC *Parrot_find_global(Interp *, STRING *class, STRING *name);
PMC *Parrot_get_global(Interp *, STRING *class, STRING *name, void *next);
+PMC *Parrot_find_global_p(Interp *, PMC *ns, STRING *name);
+PMC *Parrot_get_global_p(Interp *, PMC *ns, STRING *name);
PMC *Parrot_global_namespace(Interp *, PMC *globals, STRING *ns);
void Parrot_store_global(Interp *, STRING *class, STRING *globalname, PMC
*pmc);
void Parrot_store_sub_in_namespace(Interp*, PMC* sub_pmc);
1.28 +3 -16 parrot/ops/var.ops
Index: var.ops
===================================================================
RCS file: /cvs/public/parrot/ops/var.ops,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- var.ops 19 Mar 2005 16:20:11 -0000 1.27
+++ var.ops 30 Mar 2005 11:12:34 -0000 1.28
@@ -311,27 +311,14 @@
}
op find_global(out PMC, in PMC, in STR) {
- /* XXX: All globals should go through an API */
opcode_t * next;
- PMC * stash = $2;
- if (!$2)
+ if (PMC_IS_NULL($2))
internal_exception(1, "Tried to get from null namespace.");
- if (!$3)
+ if (PMC_IS_NULL($3))
internal_exception(1, "Tried to get null global.");
next = expr NEXT();
- if (!VTABLE_exists_keyed_str(interpreter, stash, $3)) {
- if (PARROT_ERRORS_test(interpreter, PARROT_ERRORS_GLOBALS_FLAG)) {
- real_exception(interpreter, next, GLOBAL_NOT_FOUND,
- "Global '%Ss' not found\n", $3);
- }
- else {
- $1 = pmc_new(interpreter, enum_class_Undef);
- }
- }
- else {
- $1 = VTABLE_get_pmc_keyed_str(interpreter, stash, $3);
- }
+ $1 = Parrot_get_global_p(interpreter, $2, $3);
goto NEXT();
}
1.16 +112 -7 parrot/src/global.c
Index: global.c
===================================================================
RCS file: /cvs/public/parrot/src/global.c,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- global.c 30 Mar 2005 09:07:29 -0000 1.15
+++ global.c 30 Mar 2005 11:12:35 -0000 1.16
@@ -1,6 +1,6 @@
/*
Copyright: 2004 The Perl Foundation. All Rights Reserved.
-$Id: global.c,v 1.15 2005/03/30 09:07:29 leo Exp $
+$Id: global.c,v 1.16 2005/03/30 11:12:35 leo Exp $
=head1 NAME
@@ -113,6 +113,43 @@
}
PMC *
+Parrot_find_global_p(Parrot_Interp interpreter, PMC *ns, STRING *name)
+{
+ PMC *stash;
+ STRING *class, *ns_name;
+
+ if (PMC_IS_NULL(ns))
+ return Parrot_find_global(interpreter, NULL, name);
+ switch (ns->vtable->base_type) {
+ case enum_class_String:
+ return Parrot_find_global(interpreter, PMC_str_val(ns), name);
+ case enum_class_Key:
+ stash = interpreter->globals->stash_hash;
+ while (1) {
+ class = key_string(interpreter, ns);
+ ns_name = string_concat(interpreter,
+ string_from_cstring(interpreter, "\0", 1),
+ class, 0);
+ if (!VTABLE_exists_keyed_str(interpreter, stash, ns_name)) {
+ return NULL;
+ }
+ stash = VTABLE_get_pmc_keyed_str(interpreter, stash,
ns_name);
+ ns = key_next(interpreter, ns);
+ if (!ns)
+ break;
+ }
+ assert(ns->vtable->base_type == enum_class_Hash);
+ /* fall through */
+ case enum_class_Hash:
+ if (!VTABLE_exists_keyed_str(interpreter, ns, name)) {
+ return NULL;
+ }
+ return VTABLE_get_pmc_keyed_str(interpreter, ns, name);
+ }
+ return NULL;
+}
+
+PMC *
Parrot_get_global(Parrot_Interp interpreter, STRING *class,
STRING *name, void *next)
{
@@ -126,7 +163,22 @@
"Global '%Ss' not found",
name);
}
+ return pmc_new(interpreter, enum_class_Undef);
+}
+PMC *
+Parrot_get_global_p(Parrot_Interp interpreter, PMC *ns, STRING *name)
+{
+ PMC *g = Parrot_find_global_p(interpreter, ns, name);
+ if (g)
+ return g;
+ if (PARROT_ERRORS_test(interpreter, PARROT_ERRORS_GLOBALS_FLAG)) {
+ real_exception(interpreter, NULL, E_NameError,
+ Interp_flags_TEST(interpreter, PARROT_PYTHON_MODE) ?
+ "global name '%Ss' is not defined" :
+ "Global '%Ss' not found",
+ name);
+ }
return pmc_new(interpreter, enum_class_Undef);
}
@@ -242,16 +294,13 @@
Parrot_invalidate_method_cache(interpreter, class);
}
-void
-Parrot_store_sub_in_namespace(Parrot_Interp interpreter, PMC* sub_pmc)
+static void
+store_sub_in_namespace(Parrot_Interp interpreter, PMC* sub_pmc,
+ PMC *name_space, STRING *sub_name)
{
PMC *globals = interpreter->globals->stash_hash;
INTVAL type, class_type;
- STRING* sub_name;
- PMC *name_space;
- sub_name = PMC_sub(sub_pmc)->name;
- name_space = PMC_sub(sub_pmc)->name_space;
#if DEBUG_GLOBAL
fprintf(stderr, "PMC_CONST: store_global: name '%s' ns %s\n",
(char*)sub_name->strstart,
@@ -315,6 +364,62 @@
}
}
+/* XXX in mmd.c ? */
+STRING* Parrot_multi_long_name(Parrot_Interp interpreter, PMC* sub_pmc);
+
+STRING*
+Parrot_multi_long_name(Parrot_Interp interpreter, PMC* sub_pmc)
+{
+ PMC *multi_sig;
+ STRING* sub_name, *sig;
+ INTVAL i, n;
+
+ sub_name = PMC_sub(sub_pmc)->name;
+ multi_sig = PMC_sub(sub_pmc)->multi_signature;
+ n = VTABLE_elements(interpreter, multi_sig);
+ /*
+ * foo @MULTI(STRING, Integer) =>
+ *
+ * [EMAIL PROTECTED]@Integer
+ */
+ for (i = 0; i < n; ++i) {
+ sig = VTABLE_get_string_keyed_int(interpreter, multi_sig, i);
+ sub_name = string_concat(interpreter, sub_name,
+ const_string(interpreter, "_@"), 0);
+ sub_name = string_concat(interpreter, sub_name, sig, 0);
+ }
+ return sub_name;
+}
+
+void
+Parrot_store_sub_in_namespace(Parrot_Interp interpreter, PMC* sub_pmc)
+{
+ STRING* sub_name;
+ PMC *multi_sig;
+ PMC *name_space;
+
+ sub_name = PMC_sub(sub_pmc)->name;
+ name_space = PMC_sub(sub_pmc)->name_space;
+ multi_sig = PMC_sub(sub_pmc)->multi_signature;
+ if (PMC_IS_NULL(multi_sig)) {
+ store_sub_in_namespace(interpreter, sub_pmc, name_space, sub_name);
+ }
+ else {
+ STRING *long_name;
+ PMC *multi_sub;
+
+ multi_sub = Parrot_find_global_p(interpreter, name_space, sub_name);
+ if (!multi_sub) {
+ multi_sub = pmc_new(interpreter, enum_class_MultiSub);
+ store_sub_in_namespace(interpreter, multi_sub,
+ name_space, sub_name);
+ }
+ VTABLE_push_pmc(interpreter, multi_sub, sub_pmc);
+ long_name = Parrot_multi_long_name(interpreter, sub_pmc);
+ store_sub_in_namespace(interpreter, sub_pmc, name_space, long_name);
+ }
+}
+
/*
=back
1.55 +33 -9 parrot/src/mmd.c
Index: mmd.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd.c,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- mmd.c 24 Mar 2005 14:08:19 -0000 1.54
+++ mmd.c 30 Mar 2005 11:12:35 -0000 1.55
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: mmd.c,v 1.54 2005/03/24 14:08:19 leo Exp $
+$Id: mmd.c,v 1.55 2005/03/30 11:12:35 leo Exp $
=head1 NAME
@@ -862,7 +862,7 @@
* if the first found function is a plain Sub: finito
*/
n = VTABLE_elements(interpreter, candidate_list);
- if (n) {
+ if (n == 1) {
pmc = VTABLE_get_pmc_keyed_int(interpreter, candidate_list, 0);
_sub = CONST_STRING(interpreter, "Sub");
@@ -871,7 +871,7 @@
}
}
/*
- * 4) first is a MultiSub - go through all found MultiSubs and check
+ * 4) first was a MultiSub - go through all found MultiSubs and check
* the first arguments MRO, add all MultiSubs and plain methods,
* where the first argument matches
*/
@@ -914,6 +914,7 @@
*/
type1 = VTABLE_get_integer_keyed_int(interpreter, arg_tuple, 0);
if (type1 < 0) {
+ return;
internal_exception(1, "unimplemted native MMD type");
/* TODO create some class namespace */
}
@@ -942,7 +943,7 @@
{
short da = a & 0xffff;
short db = b & 0xffff;
- return da > db ? -1 : da < db ? 1 : 0;
+ return da > db ? 1 : da < db ? -1 : 0;
}
extern void Parrot_FixedPMCArray_sort(Interp* , PMC* pmc, PMC *cmp_func);
@@ -958,13 +959,33 @@
*/
+#define MMD_BIG_DISTANCE 0x7fff
+
static UINTVAL
mmd_distance(Interp *interpreter, PMC *pmc, PMC *arg_tuple)
{
+ PMC *multi_sig;
+ INTVAL n, args, dist;
+
+ multi_sig = PMC_sub(pmc)->multi_signature;
+ if (!multi_sig) {
+ /* some method */
+ return 0;
+ }
+ n = VTABLE_elements(interpreter, multi_sig);
+ args = VTABLE_elements(interpreter, arg_tuple);
/*
- * TODO need a signaute in the sub pmc
+ * arg_tuple may have more arguments - only the
+ * n multi_sig invocants are counted
*/
- return 0;
+ if (args < n)
+ return MMD_BIG_DISTANCE;
+ dist = 0;
+ if (args > n)
+ dist = 1;
+ /*
+ * TODO run through arg types */
+ return dist;
}
/*
@@ -980,7 +1001,7 @@
static void
mmd_sort_candidates(Interp *interpreter, PMC *arg_tuple, PMC *cl)
{
- INTVAL i, n, d;
+ INTVAL i, n, d, i3;
PMC *nci, *pmc, *sort;
INTVAL *helper;
PMC **data;
@@ -997,7 +1018,7 @@
for (i = 0; i < n; ++i) {
pmc = VTABLE_get_pmc_keyed_int(interpreter, cl, i);
d = mmd_distance(interpreter, pmc, arg_tuple);
- helper[i] = i << 16 | d;
+ helper[i] = i << 16 | (d & 0xffff);
}
/*
* need an NCI function pointer
@@ -1007,7 +1028,10 @@
/*
* sort it
*/
+ i3 = REG_INT(3);
+ REG_INT(3) = 1;
Parrot_FixedPMCArray_sort(interpreter, sort, nci);
+ REG_INT(3) = i3;
/*
* now helper has a sorted list of indices in the upper 16 bits
* fill helper with sorted candidates
@@ -1099,7 +1123,7 @@
INTVAL i, n;
_sub = CONST_STRING(interpreter, "Sub");
- _multi_sub = CONST_STRING(interpreter, "Multi_Sub");
+ _multi_sub = CONST_STRING(interpreter, "MultiSub");
if (VTABLE_isa(interpreter, pmc, _sub)) {
/* a plain sub stops outer searches */
1.16 +31 -2 parrot/t/pmc/mmd.t
Index: mmd.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/mmd.t,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- mmd.t 24 Mar 2005 14:08:20 -0000 1.15
+++ mmd.t 30 Mar 2005 11:12:36 -0000 1.16
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: mmd.t,v 1.15 2005/03/24 14:08:20 leo Exp $
+# $Id: mmd.t,v 1.16 2005/03/30 11:12:36 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 10;
+use Parrot::Test tests => 11;
pir_output_is(<<'CODE', <<'OUTPUT', "PASM divide");
@@ -352,3 +352,32 @@
Bar::foo
OUT
+pir_output_is(<<'CODE', <<'OUT', "MMD on argument count");
+.namespace ["main"]
+.sub main @MAIN
+ p("ok 1\n")
+ p("-twice", "ok 2\n")
+.end
+
+.namespace [""]
+
+.sub p @MULTI(string)
+ .param string s
+ print s
+.end
+
+.sub p @MULTI(string, string)
+ .param string opt
+ .param string s
+ if opt != '-twice' goto no_twice
+ print s
+ print s
+ .return()
+no_twice:
+ print s
+.end
+CODE
+ok 1
+ok 2
+ok 2
+OUT
