cvsuser 05/04/02 08:54:55
Modified: classes bigint.pmc complex.pmc
include/parrot mmd.h pmc.h
lib/Parrot Pmc2c.pm
src global_setup.c mmd.c pmc.c
t/op lexicals.t
Log:
MMD 12 - MMD_table creation
The creation of the MMD_table is now a two step process:
1) put direct implementations into table for all classes
2) run through MRO and install inherited functions
This is an intermediate step to get dynamic inheritance too.
* remove inherited BigInt_PerlInt MMDs
* create minimal MMD_init structure
--
* lex pad depth test
Revision Changes Path
1.28 +1 -22 parrot/classes/bigint.pmc
Index: bigint.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/bigint.pmc,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- bigint.pmc 18 Mar 2005 08:29:25 -0000 1.27
+++ bigint.pmc 2 Apr 2005 16:54:51 -0000 1.28
@@ -615,9 +615,6 @@
MMD_BigInt: {
bigint_add_bigint(INTERP, SELF, value, dest);
}
-MMD_PerlInt: {
- bigint_add_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
- }
MMD_Integer: {
bigint_add_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
}
@@ -630,9 +627,6 @@
MMD_BigInt: {
bigint_sub_bigint(INTERP, SELF, value, dest);
}
-MMD_PerlInt: {
- bigint_sub_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
- }
MMD_Integer: {
bigint_sub_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
}
@@ -654,9 +648,6 @@
MMD_BigInt: {
bigint_mul_bigint(INTERP, SELF, value, dest);
}
-MMD_PerlInt: {
- bigint_mul_bigint_int(INTERP, SELF, PMC_int_val(value), dest);
- }
MMD_Integer: {
bigint_mul_bigint_int(INTERP, SELF, PMC_int_val(value), dest);
}
@@ -673,9 +664,6 @@
MMD_BigInt: {
bigint_div_bigint(INTERP, SELF, value, dest);
}
-MMD_PerlInt: {
- bigint_div_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
- }
MMD_Integer: {
bigint_div_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
}
@@ -691,9 +679,6 @@
MMD_BigInt: {
bigint_fdiv_bigint(INTERP, SELF, value, dest);
}
-MMD_PerlInt: {
- bigint_fdiv_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
- }
MMD_Integer: {
bigint_fdiv_bigint_int(INTERP, SELF, PMC_int_val(value),
dest);
}
@@ -734,9 +719,6 @@
MMD_BigInt: {
return bigint_cmp(INTERP, SELF, value);
}
-MMD_PerlInt: {
- return bigint_cmp_int(INTERP, SELF, PMC_int_val(value));
- }
MMD_Integer: {
return bigint_cmp_int(INTERP, SELF, PMC_int_val(value));
}
@@ -750,9 +732,6 @@
MMD_BigInt: {
return bigint_cmp(INTERP, SELF, value) == 0;
}
-MMD_PerlInt: {
- return bigint_cmp_int(INTERP, SELF, PMC_int_val(value)) == 0;
- }
MMD_Integer: {
return bigint_cmp_int(INTERP, SELF, PMC_int_val(value)) == 0;
}
1.19 +3 -3 parrot/classes/complex.pmc
Index: complex.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/complex.pmc,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- complex.pmc 12 Jan 2005 11:42:06 -0000 1.18
+++ complex.pmc 2 Apr 2005 16:54:51 -0000 1.19
@@ -682,7 +682,7 @@
*/
void multiply (PMC* value, PMC* dest) {
-MMD_PerlInt: {
+MMD_Integer: {
FLOATVAL re = RE(SELF) * PMC_int_val(value);
FLOATVAL im = IM(SELF) * PMC_int_val(value);
VTABLE_morph(INTERP, dest, enum_class_Complex);
@@ -802,7 +802,7 @@
}
MMD_Float: {
/*
- XXX: the above really should be MMD_DEFAULT, but that causes
+ XXX: the above really should be MMD_DEFAULT, but that causes
t/dynclass/pycomplex.t to fail.
*/
if(IM(SELF) != 0.0)
1.24 +10 -7 parrot/include/parrot/mmd.h
Index: mmd.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/mmd.h,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- mmd.h 9 Dec 2004 16:12:46 -0000 1.23
+++ mmd.h 2 Apr 2005 16:54:52 -0000 1.24
@@ -27,6 +27,15 @@
void mmd_destroy(Parrot_Interp);
PMC *mmd_vtfind(Parrot_Interp, INTVAL, INTVAL, INTVAL);
+typedef struct _MMD_init {
+ INTVAL func_nr;
+ INTVAL left, right;
+ funcptr_t func_ptr;
+} MMD_init;
+
+void Parrot_mmd_register_table(Interp*, INTVAL, const MMD_init *, INTVAL);
+void Parrot_mmd_rebuild_table(Interp*, INTVAL class_enum, INTVAL func_nr);
+
funcptr_t get_mmd_dispatch_type(Interp *interpreter,
INTVAL function, UINTVAL left_type, UINTVAL right_type, int *is_pmc);
@@ -40,12 +49,6 @@
in question */
} MMD_table;
-typedef struct _MMD_init {
- INTVAL func_nr;
- INTVAL left, right;
- funcptr_t func_ptr;
-} MMD_init;
-
/* Need this for add, subtract, multiply, divide, mod, cmod, bitwise
(and, or, xor, lshift, rshift), concat, logical (and, or, xor),
repeat, eq, cmp */
1.71 +1 -2 parrot/include/parrot/pmc.h
Index: pmc.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc.h,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- pmc.h 9 Mar 2005 20:31:25 -0000 1.70
+++ pmc.h 2 Apr 2005 16:54:52 -0000 1.71
@@ -37,7 +37,6 @@
INTVAL pmc_register(Interp *, STRING *);
INTVAL pmc_type(Interp *, STRING *);
-void Parrot_mmd_register_parents(Interp*, INTVAL, const MMD_init *, INTVAL);
/*
* DOD registry interface
1.67 +13 -6 parrot/lib/Parrot/Pmc2c.pm
Index: Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- Pmc2c.pm 1 Apr 2005 08:56:10 -0000 1.66
+++ Pmc2c.pm 2 Apr 2005 16:54:53 -0000 1.67
@@ -738,27 +738,34 @@
foreach my $method (@{ $self->{vtable}{methods}} ) {
my $meth = $method->{meth};
my $meth_name;
+ my $defaulted = 0;
+ my $class = '';
if ($self->implements($meth)) {
$meth_name = "Parrot_${classname}_$meth";
}
elsif (exists $self->{super}{$meth}) {
- my $class = $self->{super}{$meth};
+ $class = $self->{super}{$meth};
$meth_name = "Parrot_${class}_$meth";
}
else {
$meth_name = "Parrot_default_$meth";
}
+ # normal vtable method}
unless ($method->{mmd} =~ /MMD_/) {
- push @meths, $meth_name; # for now push even MMDs
- # except BXOR for testing
+ push @meths, $meth_name;
}
- if ($method->{mmd} =~ /MMD_/) {
+ $defaulted = 1 if $meth_name =~ /_default_/;
+ $defaulted = 1 if $class =~ /^[A-Z]/;
+ # MMD method
+ if ($method->{mmd} =~ /MMD_/ && !$defaulted) {
my ($func, $left, $right);
$func = $method->{mmd};
# dynamic classes need the runtime type
# which is passed in entry to class_init
$left = 0; # set to 'entry' below in initialization loop.
$right = 0;
+ $right = 'enum_type_INTVAL' if ($func =~ /_INT$/);
+ $right = 'enum_type_FLOATVAL' if ($func =~ /_FLOAT$/);
push @mmds, [ $func, $left, $right, $meth_name ];
foreach my $variant (@{ $self->{mmd_variants}{$meth} }) {
if ($self->pmc_is_dynpmc($variant->[0])) {
@@ -915,7 +922,7 @@
}
$cout .= <<"EOC";
#define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
- Parrot_mmd_register_parents(interp, entry,
+ Parrot_mmd_register_table(interp, entry,
_temp_mmd_init, N_MMD_INIT);
}
} /* Parrot_${classname}_class_init */
1.60 +3 -1 parrot/src/global_setup.c
Index: global_setup.c
===================================================================
RCS file: /cvs/public/parrot/src/global_setup.c,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- global_setup.c 29 Mar 2005 08:25:54 -0000 1.59
+++ global_setup.c 2 Apr 2005 16:54:54 -0000 1.60
@@ -68,6 +68,8 @@
/* Call base vtable class constructor methods */
Parrot_initialize_core_pmcs(interpreter);
+ /* Create MMD_table for all MMD functions */
+ Parrot_mmd_rebuild_table(interpreter, -1, -1);
/* init the interpreter globals array */
iglobals = pmc_new(interpreter, enum_class_SArray);
1.58 +141 -4 parrot/src/mmd.c
Index: mmd.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd.c,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- mmd.c 30 Mar 2005 16:05:33 -0000 1.57
+++ mmd.c 2 Apr 2005 16:54:54 -0000 1.58
@@ -542,7 +542,7 @@
=item C<void
mmd_register(Interp *interpreter,
- INTVAL type,
+ INTVAL func_num,
INTVAL left_type, INTVAL right_type,
funcptr_t funcptr)>
@@ -1324,13 +1324,150 @@
/*
+=item C<void Parrot_mmd_register_table(Interp*, INTVAL type,
+ MMD_init *, INTVAL)>
+
+Register MMD functions for this PMC type.
+
+=cut
+
+*/
+
+
+void
+Parrot_mmd_register_table(Interp* interpreter, INTVAL type,
+ const MMD_init *mmd_table, INTVAL n)
+{
+ INTVAL i;
+ /*
+ * register default mmds for this type
+ */
+ for (i = 0; i < n; ++i) {
+ if (mmd_table[i].right <= 0)
+ mmd_register(interpreter,
+ mmd_table[i].func_nr, type,
+ type, mmd_table[i].func_ptr);
+ }
+ /*
+ * register specific mmds for this type
+ */
+ for (i = 0; i < n; ++i) {
+ INTVAL r = mmd_table[i].right < 0 ? 0 : mmd_table[i].right;
+ mmd_register(interpreter,
+ mmd_table[i].func_nr, type, r, mmd_table[i].func_ptr);
+ }
+}
+
+static void
+mmd_rebuild_1(Interp* interpreter, UINTVAL type, INTVAL func_nr)
+{
+ PMC *mro, *parent;
+ INTVAL c, nc;
+ UINTVAL offset, x_funcs, y_funcs, other, parent_type;
+ MMD_table *table;
+ funcptr_t func;
+
+ mro = Parrot_base_vtables[type]->mro;
+ nc = VTABLE_elements(interpreter, mro);
+
+ /*
+ * if class has no parents, nothing todo
+ */
+ if (nc <= 1)
+ return;
+ /*
+ * if the class doesn't provide func_nr, nothing can be
+ * inherited
+ */
+ table = interpreter->binop_mmd_funcs + func_nr;
+ x_funcs = table->x;
+ y_funcs = table->y;
+ if (type >= x_funcs)
+ return;
+ /*
+ * go through MRO and install functions
+ */
+ for (c = 1; c < nc; ++c) {
+ parent = VTABLE_get_pmc_keyed_int(interpreter, mro, c);
+ parent_type = parent->vtable->base_type;
+ for (other = 0; other < (UINTVAL)enum_class_max; ++other) {
+ if (other >= y_funcs)
+ break;
+ /* (other, parent) */
+ offset = x_funcs * other + parent_type;
+ func = table->mmd_funcs[offset];
+ if (func == table->default_func)
+ continue;
+ if (table->mmd_funcs[x_funcs * other + type] ==
+ table->default_func) {
+ if (other == parent_type)
+ mmd_register(interpreter, func_nr, type, type, func);
+ mmd_register(interpreter, func_nr, type, other, func);
+ }
+ /* now for (parent, other) */
+ offset = x_funcs * parent_type + other;
+ func = table->mmd_funcs[offset];
+ if (func == table->default_func)
+ continue;
+ if (table->mmd_funcs[x_funcs * type + other] ==
+ table->default_func) {
+ mmd_register(interpreter, func_nr, other, type, func);
+ }
+ }
+ }
+}
+
+/*
+
+=item C<void Parrot_mmd_rebuild_table(Interp*, INTVAL type, INTVAL func_nr)>
+
+Rebuild the static MMD_table for the given class type and MMD function
+number. If C<type> is negative all classes are rebuilt. If C<func_nr> is
+negative all MMD functions are rebuilt.
+
+=cut
+
+*/
+
+void
+Parrot_mmd_rebuild_table(Interp* interpreter, INTVAL type, INTVAL func_nr)
+{
+ INTVAL first_type, last_type, t;
+ INTVAL first_func, last_func, f;
+
+ if (type < 0) {
+ first_type = 1;
+ last_type = enum_class_max;
+ }
+ else {
+ first_type = type;
+ last_type = type + 1;
+ }
+ if (func_nr < 0) {
+ first_func = 0;
+ last_func = MMD_USER_FIRST;
+ }
+ else {
+ first_func = func_nr;
+ last_func = func_nr + 1;
+ }
+
+ for (f = first_func; f < last_func; ++f)
+ for (t = first_type; t < last_type; ++t) {
+ mmd_rebuild_1(interpreter, (UINTVAL)t, f);
+ }
+
+}
+
+/*
+
=back
=head1 SEE ALSO
F<include/parrot/mmd.h>,
-F<$perl6/doc/trunk/design/apo/A12.pod>,
-F<$perl6/doc/trunk/design/syn/S12.pod>
+F<http://svn.perl.org/perl6/doc/trunk/design/apo/A12.pod>,
+F<http://svn.perl.org/perl6/doc/trunk/design/syn/S12.pod>
=cut
1.100 +3 -103 parrot/src/pmc.c
Index: pmc.c
===================================================================
RCS file: /cvs/public/parrot/src/pmc.c,v
retrieving revision 1.99
retrieving revision 1.100
diff -u -r1.99 -r1.100
--- pmc.c 22 Mar 2005 14:29:21 -0000 1.99
+++ pmc.c 2 Apr 2005 16:54:54 -0000 1.100
@@ -447,16 +447,14 @@
/*
-=item C<void Parrot_mmd_register_parents(Interp*, INTVAL type,
- MMD_init *, INTVAL)>
+=item C<void Parrot_create_mro(Interp *interpreter, INTVAL type)>
-Register MMD functions for this PMC type and for its parent
+Create the MRO (method resolution order) array for this type.
=cut
*/
-
void
Parrot_create_mro(Interp *interpreter, INTVAL type)
{
@@ -492,104 +490,6 @@
}
}
-void
-Parrot_mmd_register_parents(Interp* interpreter, INTVAL type,
- const MMD_init *mmd_table, INTVAL n)
-{
- INTVAL i, j;
- VTABLE *vtable = Parrot_base_vtables[type];
- STRING *class_name;
- INTVAL pos, len, parent_type;
- PMC *class;
- UINTVAL func_nr;
- /*
- * register default mmds for this type
- */
- for (i = 0; i < n; ++i) {
- if (!mmd_table[i].right)
- mmd_register(interpreter,
- mmd_table[i].func_nr, type,
- type, mmd_table[i].func_ptr);
- }
- /*
- * check if this PMC has parents
- */
- class_name = vtable->whoami;
- assert(string_str_index(interpreter, vtable->isa_str,
- class_name, 0) == 0);
- for (pos = 0; ;) {
- len = string_length(interpreter, class_name);
- pos += len+1;
- if (pos >= (INTVAL)string_length(interpreter, vtable->isa_str))
- break;
- len = string_str_index(interpreter, vtable->isa_str,
- CONST_STRING(interpreter, " "), pos);
- if (len == -1)
- break;
- class_name = string_substr(interpreter, vtable->isa_str, pos,
- len - pos, NULL, 0);
- /* abstract class? */
- if (((char*)class_name->strstart)[0] >= 'a')
- break;
- /*
- * parent_type = pmc_type(interpreter, class_name);
- * the classname_hash isn't created yet
- */
- for (parent_type = -1, i = 1; i < enum_class_max; ++i)
- if (string_equal(interpreter, class_name,
- Parrot_base_vtables[i]->whoami) == 0) {
- parent_type = i;
- break;
- }
- assert(parent_type > 0);
- /*
- * ok, we have the parent type
- * remember the parent in TODO vtable->parent
- */
- /*
- * register mmds for parent
- */
- for (func_nr = 0; func_nr < MMD_USER_FIRST; ++func_nr) {
- funcptr_t f;
- int is_pmc;
- MMD_table *table = interpreter->binop_mmd_funcs + func_nr;
-
- if (table && parent_type < type) {/* XXX */
- int has_entry = 0;
- for (i = 0; i < n; ++i) {
- if (mmd_table[i].func_nr == (int)func_nr) {
- if (mmd_table[i].right)
- has_entry = 1;
- break;
- }
- }
- for (j = enum_class_Float; j < type; ++j) {
- if (j > parent_type)
- continue;
- if (j >= enum_class_core_max || j <= enum_class_Boolean)
{
- f = get_mmd_dispatch_type(interpreter,
- func_nr, parent_type, j, &is_pmc);
- if (f != table->default_func) {
- mmd_register(interpreter,
- func_nr, type, j, f);
- if (!has_entry)
- mmd_register(interpreter,
- func_nr, type, type, f);
- }
- }
- }
- }
- }
- }
- /*
- * register specific mmds for this type
- */
- for (i = 0; i < n; ++i) {
- mmd_register(interpreter,
- mmd_table[i].func_nr, type,
- mmd_table[i].right, mmd_table[i].func_ptr);
- }
-}
/*
=item C<static size_t
1.11 +19 -3 parrot/t/op/lexicals.t
Index: lexicals.t
===================================================================
RCS file: /cvs/public/parrot/t/op/lexicals.t,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- lexicals.t 5 Jan 2005 14:38:02 -0000 1.10
+++ lexicals.t 2 Apr 2005 16:54:55 -0000 1.11
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 13;
+use Parrot::Test tests => 14;
output_is(<<CODE, <<OUTPUT, "simple store and fetch");
new_pad 0
@@ -444,5 +444,21 @@
/Lexical 'Wibble' not found/
OUTPUT
-1;
+pir_output_is(<<'CODE', <<'OUTPUT', "current pad depth");
+.sub main @MAIN
+ new_pad 0
+ new_pad -1
+ $P0 = peek_pad
+ $I0 = elements $P0
+ print $I0
+ new_pad -1
+ $P0 = peek_pad
+ $I0 = elements $P0
+ print $I0
+ print "\n"
+.end
+CODE
+23
+OUTPUT
+
