cvsuser 04/06/27 08:29:58
Modified: classes default.pmc float.pmc integer.pmc perlint.pmc
string.pmc
config/gen core_pmcs.pl
include/parrot mmd.h pmc.h
lib/Parrot Pmc2c.pm
ops cmp.ops
src mmd.c mmd_fallback.c pmc.c
t/pmc objects.t
Log:
mmd-fixes 2
* fix mmd_falback and default functions
* reverse the eq_str and eq_num result
* improve mmd table setup
* add (cut&paste) some missing functions
* tests pass again
Revision Changes Path
1.91 +3 -5 parrot/classes/default.pmc
Index: default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -w -r1.90 -r1.91
--- default.pmc 23 Jun 2004 07:14:30 -0000 1.90
+++ default.pmc 27 Jun 2004 15:29:40 -0000 1.91
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: default.pmc,v 1.90 2004/06/23 07:14:30 leo Exp $
+$Id: default.pmc,v 1.91 2004/06/27 15:29:40 leo Exp $
=head1 NAME
@@ -601,8 +601,6 @@
/*
-/*
-
=item C<INTVAL is_equal_num(PMC *value)>
Returns whether the PMC is numerically equal to C<*value>.
@@ -612,7 +610,7 @@
*/
INTVAL is_equal_num (PMC* value) {
- return (VTABLE_get_number(INTERP, SELF) != VTABLE_get_number(INTERP,
value));
+ return (VTABLE_get_number(INTERP, SELF) == VTABLE_get_number(INTERP,
value));
}
/*
@@ -626,7 +624,7 @@
*/
INTVAL is_equal_str (PMC* value) {
- return (string_compare(INTERP, VTABLE_get_string(INTERP, SELF),
+ return (0 == string_equal(INTERP, VTABLE_get_string(INTERP, SELF),
VTABLE_get_string(INTERP, value)));
}
1.10 +402 -1 parrot/classes/float.pmc
Index: float.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/float.pmc,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -w -r1.9 -r1.10
--- float.pmc 27 Jun 2004 11:14:01 -0000 1.9
+++ float.pmc 27 Jun 2004 15:29:40 -0000 1.10
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: float.pmc,v 1.9 2004/06/27 11:14:01 leo Exp $
+$Id: float.pmc,v 1.10 2004/06/27 15:29:40 leo Exp $
=head1 NAME
@@ -135,6 +135,407 @@
STRING* get_string() {
return string_from_num(INTERP, PMC_num_val(SELF));
}
+/*
+
+=item C<void add(PMC *value, PMC *dest)>
+
+Adds C<*value> to the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void add (PMC* value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) +
+ VTABLE_get_number(INTERP, value)
+ );
+ }
+
+/*
+
+=item C<void add_int(INTVAL value, PMC *dest)>
+
+Adds C<value> to the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void add_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) + value);
+ }
+/*
+
+=item C<void add_float(FLOATVAL value, PMC *dest)>
+
+Adds C<value> to the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void add_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) + value);
+ }
+
+/*
+
+=item C<void subtract(PMC *value, PMC *dest)>
+
+Subtracts C<*value> from the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void subtract (PMC* value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) -
+ VTABLE_get_number(INTERP, value)
+ );
+ }
+
+/*
+
+=item C<void subtract_int(INTVAL value, PMC *dest)>
+
+Subtracts C<value> from the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void subtract_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) - (FLOATVAL)value
+ );
+ }
+/*
+
+=item C<void subtract_float(FLOATVAL value, PMC *dest)>
+
+Subtracts C<value> from the number and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void subtract_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) - value);
+ }
+
+/*
+
+=item C<void multiply(PMC *value, PMC *dest)>
+
+Multiplies the number by C<*value> and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void multiply (PMC* value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) *
+ VTABLE_get_number(INTERP, value)
+ );
+ }
+
+/*
+
+=item C<void multiply_int(INTVAL value, PMC *dest)>
+
+Multiplies the number by C<value> and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void multiply_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) * value
+ );
+ }
+/*
+
+=item C<void multiply_float(FLOATVAL value, PMC *dest)>
+
+Multiplies the number by C<value> and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void multiply_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) * value);
+ }
+
+/*
+
+=item C<void divide(PMC *value, PMC *dest)>
+
+Divides the number by C<*value> and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void divide (PMC* value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) /
+ VTABLE_get_number(INTERP, value)
+ );
+ }
+
+/*
+
+=item C<void divide_int(INTVAL value, PMC *dest)>
+
+=cut
+
+*/
+
+ void divide_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) / value
+ );
+ }
+
+/*
+
+=item C<void divide_float(FLOATVAL value, PMC *dest)>
+
+Divides the number by C<value> and returns the result in C<*dest>.
+
+=cut
+
+*/
+
+ void divide_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_num_val(SELF) / value
+ );
+ }
+
+/*
+
+=item C<void cmodulus(PMC *value, PMC *dest)>
+
+Calculates the value of the number C-style C<mod> C<*value> and returns
+the result in C<*dest>.
+
+=cut
+
+*/
+
+ void cmodulus (PMC* value, PMC* dest) {
+ FLOATVAL f = VTABLE_get_number(INTERP, value);
+ VTABLE_set_number_native(INTERP, dest,
+ fmod(PMC_num_val(SELF), f));
+ }
+
+/*
+
+=item C<void cmodulus_float(FLOATVAL value, PMC *dest)>
+
+=cut
+
+*/
+
+ void cmodulus_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ fmod(PMC_num_val(SELF), value));
+ }
+
+/*
+
+=item C<void cmodulus_int(INTVAL value, PMC *dest)>
+
+Calculates the value of the number C-style C<mod> C<value> and returns
+the result in C<*dest>.
+
+=cut
+
+*/
+
+ void cmodulus_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ fmod(PMC_num_val(SELF), value));
+ }
+
+/*
+
+=item C<void modulus(PMC *value, PMC *dest)>
+
+Calculates the value of the number C<mod> C<*value> and returns the
+result in C<*dest>.
+
+=cut
+
+*/
+
+ void modulus (PMC* value, PMC* dest) {
+ FLOATVAL f = VTABLE_get_number(INTERP, value);
+ VTABLE_set_number_native(INTERP, dest,
+ floatval_mod(PMC_num_val(SELF), f));
+ }
+
+/*
+
+=item C<void modulus_float(FLOATVAL value, PMC *dest)>
+
+=cut
+
+*/
+
+ void modulus_float (FLOATVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ floatval_mod(PMC_num_val(SELF), value));
+ }
+
+/*
+
+=item C<void modulus_int(INTVAL value, PMC *dest)>
+
+Calculates the value of the number C<mod> C<value> and returns the
+result in C<*dest>.
+
+=cut
+
+*/
+
+ void modulus_int (INTVAL value, PMC* dest) {
+ VTABLE_set_number_native(INTERP, dest,
+ floatval_mod(PMC_num_val(SELF), value));
+ }
+
+/*
+
+=item C<void neg(PMC *dest)>
+
+If C<dest> is true, then the negation of the number is returned in
+C<*dest>. Otherwise the number itself is negated.
+
+=cut
+
+*/
+
+ void neg (PMC * dest) {
+ if (!dest)
+ PMC_num_val(SELF) = -PMC_num_val(SELF);
+ else
+ VTABLE_set_number_native(INTERP, dest, -PMC_num_val(SELF));
+ }
+
+/*
+
+=item C<INTVAL is_equal(PMC* value)>
+
+The C<==> operation.
+
+=cut
+
+*/
+
+ INTVAL is_equal (PMC* value) {
+ return (INTVAL)(PMC_num_val(SELF) == VTABLE_get_number(INTERP, value));
+ }
+
+/*
+
+=item C<INTVAL cmp(PMC* value)>
+
+
+
+=cut
+
+*/
+
+ INTVAL cmp(PMC* value) {
+ FLOATVAL diff;
+ diff = PMC_num_val(SELF) - VTABLE_get_number(INTERP, value);
+ return diff > 0 ? 1 : diff < 0 ? -1 : 0;
+ }
+
+/*
+
+=item C<INTVAL cmp_num(PMC *value)>
+
+Returns the result of comparing the number with C<*value>.
+
+=cut
+
+*/
+
+ INTVAL cmp_num(PMC* value) {
+ FLOATVAL diff;
+ diff = PMC_num_val(SELF) - VTABLE_get_number(INTERP, value);
+ return diff > 0 ? 1 : diff < 0 ? -1 : 0;
+ }
+
+/*
+
+=item C<void increment()>
+
+Increments the number.
+
+=cut
+
+*/
+
+ void increment () {
+ PMC_num_val(SELF) ++;
+ }
+
+/*
+
+=item C<void decrement()>
+
+Decrements the number.
+
+=cut
+
+*/
+
+ void decrement () {
+ PMC_num_val(SELF) --;
+ }
+/*
+
+=item C<void freeze(visit_info *info)>
+
+Used to archive the number.
+
+=cut
+
+*/
+ void freeze(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ SUPER(info);
+ io->vtable->push_float(INTERP, io, PMC_num_val(SELF));
+ }
+
+/*
+
+=item C<void thaw(visit_info *info)>
+
+Used to unarchive the number.
+
+=cut
+
+*/
+ void thaw(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ SUPER(info);
+ if (info->extra_flags == EXTRA_IS_NULL)
+ PMC_num_val(SELF) = io->vtable->shift_float(INTERP, io);
+ }
+
}
/*
1.16 +117 -4 parrot/classes/integer.pmc
Index: integer.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/integer.pmc,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- integer.pmc 27 Jun 2004 11:14:01 -0000 1.15
+++ integer.pmc 27 Jun 2004 15:29:40 -0000 1.16
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: integer.pmc,v 1.15 2004/06/27 11:14:01 leo Exp $
+$Id: integer.pmc,v 1.16 2004/06/27 15:29:40 leo Exp $
=head1 NAME
@@ -22,6 +22,28 @@
#include "parrot/parrot.h"
+static void
+overflow(Interp *interpreter, PMC *self, INTVAL b, PMC *dest, int mmd)
+{
+ PMC *temp;
+ INTVAL a = PMC_int_val(self);
+
+ if (PARROT_ERRORS_test(interpreter,PARROT_ERRORS_OVERFLOW_FLAG)) {
+ real_exception(interpreter, NULL, ERR_OVERFLOW,
+ "Integer overflow");
+ }
+ if (self == dest) {
+ VTABLE_morph(interpreter, self, enum_class_BigInt);
+ VTABLE_set_integer_native(interpreter, self, a);
+ mmd_dispatch_v_pip(interpreter, self, b, dest, mmd);
+ }
+ else {
+ temp = pmc_new(interpreter, enum_class_BigInt);
+ VTABLE_set_integer_native(interpreter, temp, a);
+ mmd_dispatch_v_pip(interpreter, temp, b, dest, mmd);
+ }
+}
+
/*
=item C<static void
@@ -63,10 +85,12 @@
*/
void class_init() {
+ if (pass) {
mmd_register(INTERP, MMD_DIVIDE,
enum_class_Integer, enum_class_Integer,
(funcptr_t)integer_divide);
}
+ }
/*
@@ -76,6 +100,10 @@
*/
+ void init () {
+ PMC_int_val(SELF) = 0;
+ }
+
void set_integer_native(INTVAL value) {
PMC_int_val(SELF) = value;
}
@@ -181,6 +209,57 @@
/*
+=item C<void add(PMC *value, PMC *dest)>
+
+Adds C<*value> to the integer and returns the result in C<*dest>.
+
+Please note: the label syntax I<MMD_type:> denote the behavior, if
+the right hand value is of that type. The part inside the braces is
+converted to a distinct function and gets I<mmd_register>ed for these
+two types.
+
+=cut
+
+*/
+ void add_int (INTVAL b, PMC* dest) {
+ INTVAL a = PMC_int_val(SELF);
+ INTVAL c = a + b;
+ if ((c^a) >= 0 || (c^b) >= 0)
+ VTABLE_set_integer_native(INTERP, dest, c);
+ else
+ overflow(INTERP, SELF, b, dest, MMD_ADD_INT);
+ }
+
+ void add (PMC* value, PMC* dest) {
+MMD_PerlInt: {
+ INTVAL a = PMC_int_val(SELF);
+ INTVAL b = PMC_int_val(value);
+ INTVAL c = a + b;
+ if ((c^a) >= 0 || (c^b) >= 0)
+ VTABLE_set_integer_native(INTERP, dest, c);
+ else
+ overflow(INTERP, SELF, b, dest, MMD_ADD_INT);
+ }
+MMD_Integer: {
+ VTABLE_set_integer_native(INTERP, dest,
+ PMC_int_val(SELF) + PMC_int_val(value));
+ }
+MMD_PerlUndef: {
+ Parrot_warn(INTERP, PARROT_WARNINGS_UNDEF_FLAG,
+ "Use of uninitialized value in integer context");
+ VTABLE_set_integer_native(INTERP, dest, PMC_int_val(SELF));
+ }
+MMD_PerlNum: {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_int_val(SELF) + PMC_num_val(value));
+ }
+MMD_DEFAULT: {
+ VTABLE_set_number_native(INTERP, dest,
+ PMC_int_val(SELF) + VTABLE_get_number(INTERP, value));
+ }
+ }
+/*
+
=item C<void increment()>
Increments the integer.
@@ -206,6 +285,40 @@
void decrement() {
PMC_int_val(SELF)--;
}
+/*
+
+=item C<INTVAL cmp(PMC *value)>
+
+Returns the result of comparing the integer with C<*value>.
+
+=cut
+
+*/
+ INTVAL cmp(PMC* value) {
+MMD_PerlString: {
+ FLOATVAL fdiff = PMC_int_val(SELF)
+ - VTABLE_get_number(INTERP, value);
+ if (fdiff == 0) {
+ INTVAL idiff = PMC_int_val(SELF)
+ - VTABLE_get_integer(INTERP, value);
+ return idiff > 0 ? 1 : idiff < 0 ? -1 : 0;
+ } else {
+ return fdiff > 0 ? 1 : -1;
+ }
+ }
+MMD_PerlNum: {
+ FLOATVAL diff;
+ diff = (FLOATVAL)PMC_int_val(SELF)
+ - VTABLE_get_number(INTERP, value);
+ return diff > 0 ? 1 : diff < 0 ? -1 : 0;
+ }
+MMD_DEFAULT: {
+ /* int or undef */
+ INTVAL diff = PMC_int_val(SELF)
+ - VTABLE_get_integer(INTERP, value);
+ return diff > 0 ? 1 : diff < 0 ? -1 : 0;
+ }
+ }
}
/*
1.67 +8 -32 parrot/classes/perlint.pmc
Index: perlint.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlint.pmc,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -w -r1.66 -r1.67
--- perlint.pmc 26 Jun 2004 16:35:34 -0000 1.66
+++ perlint.pmc 27 Jun 2004 15:29:40 -0000 1.67
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: perlint.pmc,v 1.66 2004/06/26 16:35:34 leo Exp $
+$Id: perlint.pmc,v 1.67 2004/06/27 15:29:40 leo Exp $
=head1 NAME
@@ -389,42 +389,18 @@
*/
void divide (PMC* value, PMC* dest) {
- INTVAL pmci;
- int vtype = VTABLE_type(INTERP, value);
- FLOATVAL valf;
- FLOATVAL divf;
-
- /* TODO: Is this the appropriate way to throw the exception? */
-
- pmci = PMC_int_val(SELF);
- if (vtype == enum_class_PerlUndef) {
+MMD_PerlUndef: {
internal_exception(DIV_BY_ZERO, "division by zero!\n");
- return;
}
+MMD_DEFAULT: {
- valf = VTABLE_get_number(INTERP, value);
+ FLOATVAL valf = VTABLE_get_number(INTERP, value);
if (valf == 0.0) {
internal_exception(DIV_BY_ZERO, "division by zero!\n");
return;
}
- divf = pmci / valf;
- if (vtype == enum_class_PerlNum) {
- VTABLE_set_number_native(INTERP, dest, divf);
- return;
- }
- {
- INTVAL vali = (INTVAL) valf;
- INTVAL divi = pmci / vali;
- /* if result is an integer or zero yield an integer */
- if (divf == divi || !pmci)
- VTABLE_set_integer_native(INTERP, dest, divi);
- else {
- /* TODO BIG* promotion */
- VTABLE_set_number_native(INTERP, dest, divf);
- }
- return;
-
+ VTABLE_set_number_native(INTERP, dest, PMC_int_val(SELF)/valf);
}
}
@@ -741,7 +717,7 @@
*/
INTVAL cmp(PMC* value) {
- if (value->vtable == Parrot_base_vtables[enum_class_PerlString]) {
+MMD_PerlString: {
FLOATVAL fdiff = PMC_int_val(SELF)
- VTABLE_get_number(INTERP, value);
if (fdiff == 0) {
@@ -752,13 +728,13 @@
return fdiff > 0 ? 1 : -1;
}
}
- else if (value->vtable == Parrot_base_vtables[enum_class_PerlNum]) {
+MMD_PerlNum: {
FLOATVAL diff;
diff = (FLOATVAL)PMC_int_val(SELF)
- VTABLE_get_number(INTERP, value);
return diff > 0 ? 1 : diff < 0 ? -1 : 0;
}
- else {
+MMD_DEFAULT: {
/* int or undef */
INTVAL diff = PMC_int_val(SELF)
- VTABLE_get_integer(INTERP, value);
1.3 +2 -2 parrot/classes/string.pmc
Index: string.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/string.pmc,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- string.pmc 25 Jun 2004 07:57:49 -0000 1.2
+++ string.pmc 27 Jun 2004 15:29:40 -0000 1.3
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: string.pmc,v 1.2 2004/06/25 07:57:49 leo Exp $
+$Id: string.pmc,v 1.3 2004/06/27 15:29:40 leo Exp $
=head1 NAME
@@ -436,7 +436,7 @@
INTVAL is_equal_str (PMC* value) {
STRING *s = PMC_str_val(SELF);
STRING *v = VTABLE_get_string(INTERP, value);
- return string_equal(INTERP, s, v);
+ return string_equal(INTERP, s, v) == 0;
}
/*
1.17 +7 -2 parrot/config/gen/core_pmcs.pl
Index: core_pmcs.pl
===================================================================
RCS file: /cvs/public/parrot/config/gen/core_pmcs.pl,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -w -r1.16 -r1.17
--- core_pmcs.pl 22 Jun 2004 13:13:36 -0000 1.16
+++ core_pmcs.pl 27 Jun 2004 15:29:44 -0000 1.17
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: core_pmcs.pl,v 1.16 2004/06/22 13:13:36 leo Exp $
+# $Id: core_pmcs.pl,v 1.17 2004/06/27 15:29:44 leo Exp $
=head1 NAME
@@ -89,10 +89,15 @@
{
int pass;
for (pass = 0; pass <= 1; ++pass) {
+ /* first the PMC with the highest enum
+ * this reduces MMD table resize action
+ */
END
print OUT " Parrot_${_}_class_init(interp, enum_class_${_}, pass);\n"
- foreach (@pmcs);
+ foreach (@pmcs[-1..-1]);
+ print OUT " Parrot_${_}_class_init(interp, enum_class_${_}, pass);\n"
+ foreach (@pmcs[0..$#pmcs-1]);
print OUT <<"END";
if (!pass) {
/* Need an empty stash */
1.19 +7 -1 parrot/include/parrot/mmd.h
Index: mmd.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/mmd.h,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -w -r1.18 -r1.19
--- mmd.h 18 May 2004 13:03:01 -0000 1.18
+++ mmd.h 27 Jun 2004 15:29:47 -0000 1.19
@@ -1,7 +1,7 @@
/* mmd.h
* Copyright: 2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: mmd.h,v 1.18 2004/05/18 13:03:01 leo Exp $
+ * $Id: mmd.h,v 1.19 2004/06/27 15:29:47 leo Exp $
* Overview:
* This is the api header for the mmd subsystem
* Data Structure and Algorithms:
@@ -37,6 +37,12 @@
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.68 +2 -1 parrot/include/parrot/pmc.h
Index: pmc.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc.h,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -w -r1.67 -r1.68
--- pmc.h 11 Jun 2004 16:29:03 -0000 1.67
+++ pmc.h 27 Jun 2004 15:29:47 -0000 1.68
@@ -1,7 +1,7 @@
/* pmc.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: pmc.h,v 1.67 2004/06/11 16:29:03 dan Exp $
+ * $Id: pmc.h,v 1.68 2004/06/27 15:29:47 leo Exp $
* Overview:
* This is the api header for the pmc subsystem
* Data Structure and Algorithms:
@@ -37,6 +37,7 @@
INTVAL pmc_register(struct Parrot_Interp *, STRING *);
INTVAL pmc_type(struct Parrot_Interp *, STRING *);
+void Parrot_mmd_register_parents(Interp*, INTVAL, const MMD_init *, INTVAL);
/*
* DOD registry interface
1.31 +13 -27 parrot/lib/Parrot/Pmc2c.pm
Index: Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -w -r1.30 -r1.31
--- Pmc2c.pm 27 Jun 2004 11:14:04 -0000 1.30
+++ Pmc2c.pm 27 Jun 2004 15:29:49 -0000 1.31
@@ -1,5 +1,5 @@
# Copyright: 2004 The Perl Foundation. All Rights Reserved.
-# $Id: Pmc2c.pm,v 1.30 2004/06/27 11:14:04 leo Exp $
+# $Id: Pmc2c.pm,v 1.31 2004/06/27 15:29:49 leo Exp $
=head1 NAME
@@ -130,6 +130,7 @@
STRING *whoami;
PMC *pmc;
INTVAL type;
+ int pass;
/*
* create a library PMC
@@ -145,8 +146,9 @@
whoami = string_from_cstring(interpreter, "$classname", 0);
type = pmc_register(interpreter, whoami);
/* do class_init code */
+ for (pass = 0; pass <= 1; ++pass) {
$call_class_init
-
+ }
return pmc;
}
@@ -582,28 +584,17 @@
$cout .= <<"EOC";
- struct {
- INTVAL func_nr;
- INTVAL left, right;
- funcptr_t func_ptr;
- } _temp_mmd_init[] = {
+ const MMD_init _temp_mmd_init[] = {
$mmd_list
};
/* Dynamic classes need the runtime type
which is passed in entry to class_init.
*/
- #define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
- int i;
- if (!pass) {
- for (i = 0; i < (int)N_MMD_INIT; ++i) {
- _temp_mmd_init[i].left = entry;
- }
EOC
$cout .= <<"EOC";
-
+ if (!pass) {
/*
- * parrotio calls some class_init functions during its class_init
- * code, so some of the slots might already be allocated
+ * Parrot_base_vtables is a true global - register just once
*/
if (!Parrot_base_vtables[entry]) {
temp_base_vtable.whoami = string_make(interp,
@@ -621,20 +612,15 @@
}
EOC
$cout .= <<"EOC";
- /*
- * register mmds
- */
- for (i = 0; i < (int)N_MMD_INIT; ++i) {
- mmd_register(interp,
- _temp_mmd_init[i].func_nr,
- _temp_mmd_init[i].left,
- _temp_mmd_init[i].right,
- _temp_mmd_init[i].func_ptr);
- }
} /* pass */
EOC
$cout .= <<"EOC";
$class_init_code
+ if (pass) {
+#define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
+ Parrot_mmd_register_parents(interp, entry,
+ _temp_mmd_init, N_MMD_INIT);
+ }
} /* Parrot_${classname}_class_init */
EOC
if ($self->{flags}{dynpmc}) {
1.8 +2 -2 parrot/ops/cmp.ops
Index: cmp.ops
===================================================================
RCS file: /cvs/public/parrot/ops/cmp.ops,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- cmp.ops 14 May 2004 20:44:32 -0000 1.7
+++ cmp.ops 27 Jun 2004 15:29:52 -0000 1.8
@@ -114,14 +114,14 @@
}
op eq_str (in PMC, in PMC, labelconst INT) :base_core {
- if (mmd_dispatch_i_pp(interpreter, $1, $2, MMD_STREQ) == 0) {
+ if (mmd_dispatch_i_pp(interpreter, $1, $2, MMD_STREQ)) {
goto OFFSET($3);
}
goto NEXT();
}
op eq_num (in PMC, in PMC, labelconst INT) :base_core {
- if (mmd_dispatch_i_pp(interpreter, $1, $2, MMD_NUMEQ) == 0) {
+ if (mmd_dispatch_i_pp(interpreter, $1, $2, MMD_NUMEQ)) {
goto OFFSET($3);
}
goto NEXT();
1.41 +5 -1 parrot/src/mmd.c
Index: mmd.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd.c,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -w -r1.40 -r1.41
--- mmd.c 26 Jun 2004 16:35:37 -0000 1.40
+++ mmd.c 27 Jun 2004 15:29:55 -0000 1.41
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: mmd.c,v 1.40 2004/06/26 16:35:37 leo Exp $
+$Id: mmd.c,v 1.41 2004/06/27 15:29:55 leo Exp $
=head1 NAME
@@ -112,12 +112,16 @@
* w/o the compare for equal types, mmd_fallback jumps in
* This just depends on *other* PMCs that use MMD
*/
+ /* XXX do this in table setup */
if (left_type == enum_class_delegate)
right_type = 0;
if (left_type < x_funcs) {
if (right_type < y_funcs) {
offset = x_funcs * right_type + left_type;
func = table->mmd_funcs[offset];
+ /* XXX do this in table setup */
+ if (func == table->default_func)
+ func = table->mmd_funcs[left_type];
}
else {
func = table->mmd_funcs[left_type];
1.6 +11 -12 parrot/src/mmd_fallback.c
Index: mmd_fallback.c
===================================================================
RCS file: /cvs/public/parrot/src/mmd_fallback.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- mmd_fallback.c 18 May 2004 13:03:07 -0000 1.5
+++ mmd_fallback.c 27 Jun 2004 15:29:55 -0000 1.6
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: mmd_fallback.c,v 1.5 2004/05/18 13:03:07 leo Exp $
+$Id: mmd_fallback.c,v 1.6 2004/06/27 15:29:55 leo Exp $
=head1 NAME
@@ -212,8 +212,8 @@
mmd_fallback_cmod_pmc(Parrot_Interp interp, PMC *left, PMC *right, PMC *dest)
{
VTABLE_set_number_native(interp, dest,
- VTABLE_get_integer(interp, left) %
- VTABLE_get_integer(interp, right));
+ fmod(VTABLE_get_number(interp, left),
+ VTABLE_get_number(interp, right)));
}
static void
@@ -504,16 +504,15 @@
INTVAL left_truth, right_truth;
PMC *true;
left_truth = VTABLE_get_bool(interp, left);
- right_truth = VTABLE_get_bool(interp, left);
- /* Are they both false? That's the easy case */
- if ((left_truth && right_truth) || (!left_truth && !right_truth)) {
- true = constant_pmc_new_noinit(interp, enum_class_PerlUndef);
- } else {
- if (left_truth) {
+ right_truth = VTABLE_get_bool(interp, right);
+
+ if (left_truth && !right_truth)
true = left;
- } else {
+ else if (!left_truth && right_truth)
true = right;
- }
+ else {
+ VTABLE_set_integer_native(interp, dest, 0);
+ return;
}
VTABLE_set_pmc(interp, dest, true);
}
@@ -584,7 +583,7 @@
static INTVAL
mmd_fallback_streq_pmc(Parrot_Interp interp, PMC *left, PMC *right)
{
- if (string_compare(interp, VTABLE_get_string(interp, left),
+ if (0 == string_equal(interp, VTABLE_get_string(interp, left),
VTABLE_get_string(interp, right))) {
return 1;
} else {
1.84 +80 -17 parrot/src/pmc.c
Index: pmc.c
===================================================================
RCS file: /cvs/public/parrot/src/pmc.c,v
retrieving revision 1.83
retrieving revision 1.84
diff -u -w -r1.83 -r1.84
--- pmc.c 24 Jun 2004 08:02:20 -0000 1.83
+++ pmc.c 27 Jun 2004 15:29:55 -0000 1.84
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: pmc.c,v 1.83 2004/06/24 08:02:20 leo Exp $
+$Id: pmc.c,v 1.84 2004/06/27 15:29:55 leo Exp $
=head1 NAME
@@ -17,6 +17,8 @@
*/
#include "parrot/parrot.h"
+#include <assert.h>
+
static PMC* get_new_pmc_header(Parrot_Interp, INTVAL base_type, UINTVAL flags);
@@ -213,22 +215,6 @@
}
pmc->vtable = vtable;
- /*
- * class interface - a PMC is it's own class
- * XXX use a separate vtable entry?
- * A ParrotObject has already the ParrotClass PMC in data
- */
- if (!vtable->data) {
- /* can't put this PMC in: if it needs timely destruction
- * it'll not get destroyed, so put in another PMC
- *
- * we should do that in pmc_register, but this doesn't
- * work for dynamic PMCs, which don't have a vtable
- * when they call pmc_register
- */
- PMC *class = vtable->data = new_pmc_header(interpreter, PObj_constant_FLAG);
- class->vtable = vtable;
- }
#if GC_VERBOSE
if (Interp_flags_TEST(interpreter, PARROT_TRACE_FLAG)) {
@@ -461,6 +447,83 @@
/*
+=item C<void Parrot_mmd_register_parents(Interp*, INTVAL type,
+ MMD_init *, INTVAL)>
+
+Register MMD functions for this PMC type and for its parent
+
+=cut
+
+*/
+
+void
+Parrot_mmd_register_parents(Interp* interpreter, INTVAL type,
+ const MMD_init *mmd_table, INTVAL n)
+{
+ INTVAL i;
+ VTABLE *vtable = Parrot_base_vtables[type];
+ STRING *class_name;
+ INTVAL pos, len, parent_type;
+ /*
+ * class interface - a PMC is it's own class
+ * XXX use a separate vtable entry?
+ *
+ * put an instance of this PMC into data
+ */
+ PMC *class = vtable->data = new_pmc_header(interpreter,
+ PObj_constant_FLAG);
+ class->vtable = vtable;
+ /*
+ * register 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);
+ mmd_register(interpreter,
+ mmd_table[i].func_nr, type,
+ mmd_table[i].right, mmd_table[i].func_ptr);
+ }
+ /*
+ * now 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
+ */
+ }
+}
+/*
+
=item C<static size_t
key_hash_int(Interp *interp, Hash *hash, void *value)>
1.48 +3 -3 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -w -r1.47 -r1.48
--- objects.t 23 Jun 2004 17:09:23 -0000 1.47
+++ objects.t 27 Jun 2004 15:29:58 -0000 1.48
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.47 2004/06/23 17:09:23 leo Exp $
+# $Id: objects.t,v 1.48 2004/06/27 15:29:58 leo Exp $
=head1 NAME
@@ -1260,7 +1260,7 @@
MyInt(42)
OUTPUT
-output_is(<<'CODE', <<'OUTPUT', "PMC as classes - overrid mmd methods");
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - overridden mmd methods");
##PIR##
.sub main @MAIN
.local pmc MyInt
@@ -1278,7 +1278,7 @@
.local pmc add_sub
add_sub = find_global "MyInt", "__add"
.include "mmd.pasm"
- mmdvtregister .MMD_ADD, $I0, 0, add_sub
+ mmdvtregister .MMD_ADD, $I0, $I0, add_sub
k = i + j
print k
print "\n"
