cvsuser 05/03/24 06:08:20
Modified: classes fixedpmcarray.pmc resizablepmcarray.pmc
scratchpad.pmc
imcc pbc.c pcc.c symreg.c
imcc/t/imcpasm optc.t
runtime/parrot/library parrotlib.imc
src global.c mmd.c
t/pmc mmd.t
Log:
first MMD call
* see note on p6i
Revision Changes Path
1.32 +1 -30 parrot/classes/fixedpmcarray.pmc
Index: fixedpmcarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/fixedpmcarray.pmc,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- fixedpmcarray.pmc 16 Mar 2005 14:21:33 -0000 1.31
+++ fixedpmcarray.pmc 24 Mar 2005 14:08:15 -0000 1.32
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: fixedpmcarray.pmc,v 1.31 2005/03/16 14:21:33 leo Exp $
+$Id: fixedpmcarray.pmc,v 1.32 2005/03/24 14:08:15 leo Exp $
=head1 NAME
@@ -102,35 +102,6 @@
/*
-=item C<void* invoke(void* next)>
-
-Pythonic object constructor. SELF is a FixedPMCArray Class object. Return a
new
-C<tuple> object according to 2.1. Built-in Functions.
-
-=cut
-
-*/
- void* invoke(void* next) {
- int argcP = REG_INT(3);
- PMC *res = pmc_new(INTERP, enum_class_FixedPMCArray);
- PMC *arg;
- if (argcP) {
- if (argcP > 1) {
- real_exception(INTERP, NULL, E_TypeError,
- "TypeError: tuple expected at most 1 arguments, got
%d",
- (int)argcP);
- }
- arg = REG_PMC(5);
- if (arg->vtable->base_type == enum_class_FixedPMCArray)
- res = arg; /* if a tuple is passed, return it */
- else
- Parrot_py_fill(INTERP, res, arg);
- }
- REG_PMC(5) = res;
- return next;
- }
-/*
-
=back
=head2 Methods
1.22 +1 -29 parrot/classes/resizablepmcarray.pmc
Index: resizablepmcarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/resizablepmcarray.pmc,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- resizablepmcarray.pmc 17 Mar 2005 11:45:25 -0000 1.21
+++ resizablepmcarray.pmc 24 Mar 2005 14:08:15 -0000 1.22
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: resizablepmcarray.pmc,v 1.21 2005/03/17 11:45:25 leo Exp $
+$Id: resizablepmcarray.pmc,v 1.22 2005/03/24 14:08:15 leo Exp $
=head1 NAME
@@ -27,34 +27,6 @@
/*
-=item C<void* invoke(void* next)>
-
-Pythonic object constructor. SELF is a ResizeablePMCArray Class object.
-Return a new C<list> object according to 2.1. Built-in Functions.
-
-=cut
-
-*/
- void* invoke(void* next) {
- int argcP = REG_INT(3);
- PMC *res = pmc_new(INTERP, enum_class_ResizablePMCArray);
- PMC *arg;
-
- if (argcP) {
- if (argcP > 1) {
- real_exception(INTERP, NULL, E_TypeError,
- "TypeError: list expected at most 1 arguments, got
%d",
- (int)argcP);
- }
- arg = REG_PMC(5);
- Parrot_py_fill(INTERP, res, arg);
- }
- REG_PMC(5) = res;
- return next;
- }
-
-/*
-
=item C<void set_integer_native(INTVAL size)>
Resizes the array to C<size> elements.
1.21 +4 -4 parrot/classes/scratchpad.pmc
Index: scratchpad.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/scratchpad.pmc,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- scratchpad.pmc 6 Mar 2005 11:18:37 -0000 1.20
+++ scratchpad.pmc 24 Mar 2005 14:08:15 -0000 1.21
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2005 The Perl Foundation. All Rights Reserved.
-$Id: scratchpad.pmc,v 1.20 2005/03/06 11:18:37 bernhard Exp $
+$Id: scratchpad.pmc,v 1.21 2005/03/24 14:08:15 leo Exp $
=head1 NAME
@@ -8,10 +8,10 @@
=head1 DESCRIPTION
-These are the vtable functions for the Scratchpad PMC.
+These are the vtable functions for the Scratchpad PMC.
A ScratchPad PMC is a FixedPMCArray of OrderedHashes. It is used in the
implementation
-of the opcodes in F<ops/var.ops>.
+of the opcodes in F<ops/var.ops>.
=head2 Methods
@@ -198,7 +198,7 @@
=head1 SEE ALSO
-F<ops/var.ops>
+F<ops/var.ops>
F<src/lexical.c>
=cut
1.110 +24 -10 parrot/imcc/pbc.c
Index: pbc.c
===================================================================
RCS file: /cvs/public/parrot/imcc/pbc.c,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -r1.109 -r1.110
--- pbc.c 19 Mar 2005 16:20:09 -0000 1.109
+++ pbc.c 24 Mar 2005 14:08:16 -0000 1.110
@@ -419,11 +419,18 @@
struct subs *s;
*pc = 0;
for (s = globals.cs->first; s; s = s->next) {
+#if 0
+ fprintf(stderr, "namespace %s\n", s->unit->namespace ?
+ s->unit->namespace->name : "(null");
+ debug_dump_sym_hash(s->labels);
+ fprintf(stderr, "\n");
+#endif
if (sym && (
- ((sym->unit->namespace && s->unit->namespace) &&
- sym->unit->namespace == s->unit->namespace)
- || (sym->unit->namespace && !s->unit->namespace)
- || (!sym->unit->namespace && s->unit->namespace)))
+ ((sym->unit->namespace && s->unit->namespace) &&
+ strcmp(sym->unit->namespace->name,
+ s->unit->namespace->name))
+ || (sym->unit->namespace && !s->unit->namespace)
+ || (!sym->unit->namespace && s->unit->namespace)))
continue;
if ( (r = _get_sym(s->labels, name)) ) {
*pc += r->color; /* here pc was stored */
@@ -469,15 +476,22 @@
* set_p_pc => find_name p_sc
*/
if (!lab) {
- int op =
interpreter->op_lib->op_code("find_name_p_sc", 1);
- int col;
+ int op, col;
+ SymReg *nam;
+ op = interpreter->op_lib->op_code("find_name_p_sc",
1);
assert(op);
interpreter->code->byte_code[addr] = op;
- col = add_const_str(interpreter, bsr);
+ nam = mk_const(interpreter, str_dup(bsr->name), 'S');
+ if (nam->color >= 0)
+ col = nam->color;
+ else {
+ col = nam->color = add_const_str(interpreter,
nam);
+ }
interpreter->code->byte_code[addr+2] = col;
- IMCC_debug(interpreter, DEBUG_PBC_FIXUP, "fixup
const PMC"
- " find_name sub '%s' const nr: %d\n",
bsr->name,
- col);
+ IMCC_debug(interpreter, DEBUG_PBC_FIXUP,
+ "fixup const PMC"
+ " find_name sub '%s' const nr: %d\n",
+ bsr->name, col);
continue;
}
pmc_const = s1->pmc_const;
1.89 +39 -3 parrot/imcc/pcc.c
Index: pcc.c
===================================================================
RCS file: /cvs/public/parrot/imcc/pcc.c,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -r1.88 -r1.89
--- pcc.c 20 Mar 2005 15:27:41 -0000 1.88
+++ pcc.c 24 Mar 2005 14:08:16 -0000 1.89
@@ -818,6 +818,27 @@
}
+static Instruction*
+pcc_insert_signature(Parrot_Interp interp, IMC_Unit * unit, Instruction *ins,
+ struct pcc_sub_t *pcc_sub)
+{
+ int i, n;
+ SymReg *regs[IMCC_MAX_REGS];
+ char buffer[20]; /* TODO is there a limit? */
+
+ n = pcc_sub->nargs;
+ buffer[0] = '"';
+ for (i = 0; i < n && i < 15; ++i) {
+ buffer[i + 1] = pcc_sub->args[i]->set;
+ }
+ buffer[i + 1] = '"';
+ buffer[i + 2] = '\0';
+ regs[0] = get_pasm_reg(interp, "S0");
+ regs[1] = mk_const(interp, str_dup(buffer), 'S');
+ ins = insINS(interp, unit, ins, "set", regs, 2);
+ return ins;
+}
+
/*
* Expand a PCC subroutine call (IMC) into its PASM instructions
* This is the nuts and bolts of pdd03 routine call style
@@ -828,12 +849,12 @@
{
SymReg *arg, *sub, *reg, *regs[IMCC_MAX_REGS];
int n;
- Instruction *tmp;
int need_cc;
int tail_call;
int proto;
int meth_call = 0;
SymReg *s0 = NULL;
+ Instruction *get_name;
tail_call = 0;
#ifdef CREATE_TAIL_CALLS
@@ -850,6 +871,7 @@
* See if we need to create a temporary sub object for the short
* function call syntax _f()
*/
+ get_name = NULL;
if (ins->type & ITCALL) {
SymReg * the_sub = sub->pcc_sub->sub;
if (!meth_call && the_sub->type == VTADDRESS) {
@@ -868,10 +890,13 @@
the_sub->type = VTCONST;
regs[0] = reg;
regs[1] = the_sub;
- tmp = INS(interp, unit, "set_p_pc", "", regs, 2, 0, 0);
+ /*
+ * set_p_pc gets replaced in imcc/pbc.c, if the
+ * function can't located in the current namespace
+ */
+ get_name = INS(interp, unit, "set_p_pc", "", regs, 2, 0, 0);
ins->type &= ~ITCALL;
- prepend_ins(unit, ins, tmp);
}
else
add_pcc_sub(sub, the_sub);
@@ -885,6 +910,17 @@
proto = sub->pcc_sub->pragma & P_PROTOTYPED;
ins = pcc_put_args(interp, unit, ins, sub->pcc_sub, n,
proto, sub->pcc_sub->args);
+ /*
+ * insert get_name after args have been setup, so that
+ * a possible MMD call can inspect the passed arguments
+ */
+ if (get_name) {
+ /* for now, put a call signature in S0 */
+ if (!meth_call)
+ ins = pcc_insert_signature(interp, unit, ins, sub->pcc_sub);
+ insert_ins(unit, ins, get_name);
+ ins = get_name;
+ }
/*
1.60 +14 -0 parrot/imcc/symreg.c
Index: symreg.c
===================================================================
RCS file: /cvs/public/parrot/imcc/symreg.c,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- symreg.c 28 Feb 2005 10:41:18 -0000 1.59
+++ symreg.c 24 Mar 2005 14:08:16 -0000 1.60
@@ -680,6 +680,20 @@
}
}
+void debug_dump_sym_hash(SymReg **hsh);
+
+void
+debug_dump_sym_hash(SymReg **hsh)
+{
+ int i;
+ SymReg * p;
+ for (i = 0; i < HASH_SIZE; i++) {
+ for (p = hsh[i]; p; p = p->next) {
+ fprintf(stderr, "%s ", p->name);
+ }
+ }
+}
+
/* Deletes all local symbols and clears life info */
void
clear_locals(IMC_Unit * unit)
1.13 +4 -3 parrot/imcc/t/imcpasm/optc.t
Index: optc.t
===================================================================
RCS file: /cvs/public/parrot/imcc/t/imcpasm/optc.t,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- optc.t 4 Mar 2005 17:49:01 -0000 1.12
+++ optc.t 24 Mar 2005 14:08:17 -0000 1.13
@@ -1,6 +1,6 @@
#!perl
# Copyright: 2005 The Perl Foundation. All Rights Reserved.
-# $Id: optc.t,v 1.12 2005/03/04 17:49:01 bernhard Exp $
+# $Id: optc.t,v 1.13 2005/03/24 14:08:17 leo Exp $
use strict;
use Parrot::Test tests => 6;
@@ -11,6 +11,9 @@
##############################
# prototyped calls, invokecc
+SKIP: {
+ skip("PCC changes", 6);
+
pir_2_pasm_like(<<'CODE', <<'OUT', "in P param");
.sub _main
$P0 = new PerlUndef
@@ -47,8 +50,6 @@
returncc/
OUT
-SKIP: {
- skip("PCC changes", 5);
pir_2_pasm_like(<<'CODE', <<'OUT', "in, out P param");
.sub _main
.local Sub sub
1.8 +12 -14 parrot/runtime/parrot/library/parrotlib.imc
Index: parrotlib.imc
===================================================================
RCS file: /cvs/public/parrot/runtime/parrot/library/parrotlib.imc,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- parrotlib.imc 11 Dec 2004 12:08:10 -0000 1.7
+++ parrotlib.imc 24 Mar 2005 14:08:18 -0000 1.8
@@ -46,7 +46,7 @@
store_global "_parrotlib", "include_paths", includes
# get the directory handler
- $P0 = find_global "_parrotlib::internal", "handle_directory"
+ $P0 = find_global "_parrotlib", "handle_directory"
# fill the includes array
LOOP:
@@ -65,6 +65,17 @@
set_signature( "dynext_location", "SSSP" )
.end
+.sub set_signature
+ .param string name
+ .param string sig
+
+ $P1 = new .PerlString
+ $P1 = sig
+ find_global $P0, "_parrotlib", name
+ setprop $P0, "signature", $P1
+ store_global "_parrotlib", name, $P0
+.end
+
=item STRING = include_file_location( STRING )
Is called by IMCC when it encounters an C<.include> statement.
@@ -147,8 +158,6 @@
.end
-.namespace ["_parrotlib::internal"]
-
.sub find_file_path
.param string name
.param pmc array
@@ -191,17 +200,6 @@
.pcc_end_return
.end
-.sub set_signature
- .param string name
- .param string sig
-
- $P1 = new .PerlString
- $P1 = sig
- find_global $P0, "_parrotlib", name
- setprop $P0, "signature", $P1
- store_global "_parrotlib", name, $P0
-.end
-
=back
=head1 AUTHOR
1.12 +21 -9 parrot/src/global.c
Index: global.c
===================================================================
RCS file: /cvs/public/parrot/src/global.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- global.c 19 Mar 2005 16:20:04 -0000 1.11
+++ global.c 24 Mar 2005 14:08:19 -0000 1.12
@@ -1,6 +1,6 @@
/*
Copyright: 2004 The Perl Foundation. All Rights Reserved.
-$Id: global.c,v 1.11 2005/03/19 16:20:04 leo Exp $
+$Id: global.c,v 1.12 2005/03/24 14:08:19 leo Exp $
=head1 NAME
@@ -141,6 +141,9 @@
*/
+/* XXX */
+PMC *Parrot_MMD_search_default_func(Interp *, STRING *meth, STRING
*signature);
+
PMC *
Parrot_get_name(Interp* interpreter, STRING *name)
{
@@ -148,14 +151,23 @@
pad = scratchpad_get_current(interpreter);
g = scratchpad_find(interpreter, pad, name);
- if (g)
- return g;
- g = Parrot_find_global(interpreter, NULL, name);
- if (g)
- return g;
- g = Parrot_find_builtin(interpreter, name);
- if (g)
- return g;
+ if (!g)
+ g = Parrot_find_global(interpreter, NULL, name);
+ if (!g)
+ g = Parrot_find_builtin(interpreter, name);
+ if (g) {
+ if (g->vtable->base_type == enum_class_MultiSub) {
+ /*
+ * signature is currently passed in S0
+ * see also imcc/pcc.c
+ */
+ g = Parrot_MMD_search_default_func(interpreter, name,
REG_STR(0));
+ if (g)
+ return g;
+ }
+ else
+ return g;
+ }
if (PARROT_ERRORS_test(interpreter, PARROT_ERRORS_GLOBALS_FLAG)) {
real_exception(interpreter, NULL, E_NameError,
"Name '%Ss' not found", name);
1.54 +13 -9 parrot/src/mmd.c
Index: mmd.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd.c,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- mmd.c 17 Mar 2005 11:45:27 -0000 1.53
+++ mmd.c 24 Mar 2005 14:08:19 -0000 1.54
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: mmd.c,v 1.53 2005/03/17 11:45:27 leo Exp $
+$Id: mmd.c,v 1.54 2005/03/24 14:08:19 leo Exp $
=head1 NAME
@@ -850,7 +850,7 @@
mmd_search_default(Interp *interpreter, STRING *meth, PMC *arg_tuple)
{
PMC *candidate_list, *pmc;
- INTVAL i, n;
+ INTVAL n;
STRING *_sub;
/*
@@ -862,13 +862,13 @@
* if the first found function is a plain Sub: finito
*/
n = VTABLE_elements(interpreter, candidate_list);
- if (!n)
- return NULL;
- pmc = VTABLE_get_pmc_keyed_int(interpreter, candidate_list, 0);
- _sub = CONST_STRING(interpreter, "Sub");
+ if (n) {
+ pmc = VTABLE_get_pmc_keyed_int(interpreter, candidate_list, 0);
+ _sub = CONST_STRING(interpreter, "Sub");
- if (VTABLE_isa(interpreter, pmc, _sub)) {
- return pmc;
+ if (VTABLE_isa(interpreter, pmc, _sub)) {
+ return pmc;
+ }
}
/*
* 4) first is a MultiSub - go through all found MultiSubs and check
@@ -876,10 +876,14 @@
* where the first argument matches
*/
mmd_search_classes(interpreter, meth, arg_tuple, candidate_list);
+ n = VTABLE_elements(interpreter, candidate_list);
+ if (!n)
+ return NULL;
/*
* 5) sort the list
*/
- mmd_sort_candidates(interpreter, arg_tuple, candidate_list);
+ if (n > 1)
+ mmd_sort_candidates(interpreter, arg_tuple, candidate_list);
/*
* 6) Uff, return first one
*/
1.15 +45 -2 parrot/t/pmc/mmd.t
Index: mmd.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/mmd.t,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- mmd.t 4 Mar 2005 17:49:11 -0000 1.14
+++ mmd.t 24 Mar 2005 14:08:20 -0000 1.15
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: mmd.t,v 1.14 2005/03/04 17:49:11 bernhard Exp $
+# $Id: mmd.t,v 1.15 2005/03/24 14:08:20 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 9;
+use Parrot::Test tests => 10;
pir_output_is(<<'CODE', <<'OUTPUT', "PASM divide");
@@ -309,3 +309,46 @@
1
7
OUTPUT
+
+pir_output_is(<<'CODE', <<'OUT', "first dynamic MMD call");
+
+.namespace ["Main"]
+.sub main @MAIN
+ .local pmc F, B, f, b, m, s
+ newclass F, "Foo"
+ f = F."instantiate"()
+ newclass B, "Bar"
+ b = B."instantiate"()
+ # create a multi the hard way
+ m = new MultiSub
+ s = find_global "Foo", "foo"
+ push m, s
+ s = find_global "Bar", "foo"
+ push m, s
+ global "foo" = m
+ print "calling foo(f, b)\n"
+ foo(f, b)
+ print "calling foo(b, f)\n"
+ foo(b, f)
+.end
+
+.namespace ["Foo"]
+.sub foo method
+ .param pmc x
+ .param pmc y
+ print " Foo::foo\n"
+.end
+
+.namespace ["Bar"]
+.sub foo method
+ .param pmc x
+ .param pmc y
+ print " Bar::foo\n"
+.end
+CODE
+calling foo(f, b)
+ Foo::foo
+calling foo(b, f)
+ Bar::foo
+OUT
+
