cvsuser 04/06/23 06:25:07
Modified: . MANIFEST
lib/Parrot Pmc2c.pm
t/pmc objects.t
Added: classes deleg_pmc.pmc
Log:
Pie-thon 5 - autogenerate deleg_pmc methods
Revision Changes Path
1.683 +1 -0 parrot/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.682
retrieving revision 1.683
diff -u -w -r1.682 -r1.683
--- MANIFEST 22 Jun 2004 07:36:07 -0000 1.682
+++ MANIFEST 23 Jun 2004 13:24:55 -0000 1.683
@@ -37,6 +37,7 @@
classes/coroutine.pmc []
classes/csub.pmc []
classes/default.pmc []
+classes/deleg_pmc.pmc []
classes/delegate.pmc []
classes/env.pmc []
classes/eval.pmc []
1.1 parrot/classes/deleg_pmc.pmc
Index: deleg_pmc.pmc
===================================================================
/*
Copyright: 2004 The Perl Foundation. All Rights Reserved.
$Id: deleg_pmc.pmc,v 1.1 2004/06/23 13:24:58 leo Exp $
=head1 NAME
classes/deleg_pmc.pmc - Delegate PMC
=head1 DESCRIPTION
Delegate functions to the PMC in attribute slote #0.
Almost all methods are auto-generated in lib/Parrot/Pmc2c.pm
=head2 Methods
=over 4
=cut
*/
#include "parrot/parrot.h"
#include <assert.h>
/*
* MMD dispatch macros
*/
#define VTABLE_bitwise_xor(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_BXOR)
#define VTABLE_bitwise_xor_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_BXOR_INT)
#define VTABLE_add(i, l, r, d) mmd_dispatch_v_ppp(i, l, r, d, MMD_ADD)
#define VTABLE_add_int(i, l, r, d) mmd_dispatch_v_pip(i, l, r, d, MMD_ADD_INT)
#define VTABLE_add_float(i, l, r, d) mmd_dispatch_v_pnp(i, l, r, d, MMD_ADD_FLOAT)
#define VTABLE_subtract(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_SUBTRACT)
#define VTABLE_subtract_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_SUBTRACT_INT)
#define VTABLE_subtract_float(i,l,r,d) mmd_dispatch_v_pnp(i,l,r,d,MMD_SUBTRACT_FLOAT)
#define VTABLE_multiply(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_MULTIPLY)
#define VTABLE_multiply_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_MULTIPLY_INT)
#define VTABLE_multiply_float(i,l,r,d) mmd_dispatch_v_pnp(i,l,r,d,MMD_MULTIPLY_FLOAT)
#define VTABLE_divide(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_DIVIDE)
#define VTABLE_divide_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_DIVIDE_INT)
#define VTABLE_divide_float(i,l,r,d) mmd_dispatch_v_pnp(i,l,r,d,MMD_DIVIDE_FLOAT)
#define VTABLE_modulus(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_MOD)
#define VTABLE_modulus_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_MOD_INT)
#define VTABLE_modulus_float(i,l,r,d) mmd_dispatch_v_pnp(i,l,r,d,MMD_MOD_FLOAT)
#define VTABLE_cmodulus(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_CMOD)
#define VTABLE_cmodulus_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_CMOD_INT)
#define VTABLE_cmodulus_float(i,l,r,d) mmd_dispatch_v_pnp(i,l,r,d,MMD_CMOD_FLOAT)
#define VTABLE_bitwise_and(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_BAND)
#define VTABLE_bitwise_and_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_BAND_INT)
#define VTABLE_bitwise_ors(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_SOR)
#define VTABLE_bitwise_ors_str(i,l,r,d) mmd_dispatch_v_psp(i,l,r,d,MMD_SOR_STR)
#define VTABLE_bitwise_ands(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_SAND)
#define VTABLE_bitwise_ands_str(i,l,r,d) mmd_dispatch_v_psp(i,l,r,d,MMD_SAND_STR)
#define VTABLE_bitwise_xors(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_SXOR)
#define VTABLE_bitwise_xors_str(i,l,r,d) mmd_dispatch_v_psp(i,l,r,d,MMD_SXOR_STR)
#define VTABLE_bitwise_shl(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_BSL)
#define VTABLE_bitwise_shl_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_BSL_INT)
#define VTABLE_bitwise_shr(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_BSR)
#define VTABLE_bitwise_shr_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_BSR_INT)
#define VTABLE_bitwise_or(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_BOR)
#define VTABLE_bitwise_or_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_BOR_INT)
#define VTABLE_concatenate(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_CONCAT)
#define VTABLE_concatenate_str(i,l,r,d) mmd_dispatch_v_psp(i,l,r,d,MMD_CONCAT_STR)
#define VTABLE_logical_or(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_LOR)
#define VTABLE_logical_and(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_LAND)
#define VTABLE_logical_xor(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_LXOR)
#define VTABLE_repeat(i,l,r,d) mmd_dispatch_v_ppp(i,l,r,d,MMD_REPEAT)
#define VTABLE_repeat_int(i,l,r,d) mmd_dispatch_v_pip(i,l,r,d,MMD_REPEAT_INT)
#define VTABLE_cmp(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_CMP)
#define VTABLE_cmp_num(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_NUMCMP)
#define VTABLE_cmp_string(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_STRCMP)
#define VTABLE_is_equal(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_EQ)
#define VTABLE_is_equal_num(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_NUMEQ)
#define VTABLE_is_equal_str(i,l,r) mmd_dispatch_i_pp(i,l,r,MMD_STREQ)
pmclass deleg_pmc {
/*
=item C<void init()>
=cut
*/
void init () {
PObj_custom_mark_SET(SELF);
}
void init_pmc (PMC* class) {
PObj_custom_mark_SET(SELF);
}
void mark() {
SLOTTYPE *attrib_array = PMC_data(SELF);
PMC *attr = get_attrib_num(attrib_array, POD_FIRST_ATTRIB);
pobject_lives(INTERP, (PObj *) PMC_pmc_val(SELF));
}
}
/*
=back
=cut
*/
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*
* vim: expandtab shiftwidth=4:
*/
1.29 +63 -2 parrot/lib/Parrot/Pmc2c.pm
Index: Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -w -r1.28 -r1.29
--- Pmc2c.pm 22 Jun 2004 10:57:19 -0000 1.28
+++ Pmc2c.pm 23 Jun 2004 13:25:03 -0000 1.29
@@ -1,5 +1,5 @@
# Copyright: 2004 The Perl Foundation. All Rights Reserved.
-# $Id: Pmc2c.pm,v 1.28 2004/06/22 10:57:19 leo Exp $
+# $Id: Pmc2c.pm,v 1.29 2004/06/23 13:25:03 leo Exp $
=head1 NAME
@@ -88,7 +88,9 @@
sub class_name {
my ($self, $class) = @_;
my %special = ( 'Ref' => 1, 'default' => 1, 'Null' => 1,
- 'delegate' => 1, 'SharedRef' => 1 );
+ 'delegate' => 1, 'SharedRef' => 1,
+ 'deleg_pmc' => 1,
+ );
my $classname = $self->{class};
my $nclass = $class;
# bless object into different classes inheriting from
@@ -1214,6 +1216,65 @@
EOC
}
+package Parrot::Pmc2c::deleg_pmc;
+use base 'Parrot::Pmc2c';
+import Parrot::Pmc2c qw( gen_ret );
+
+=item C<implements($method)>
+
+Always true.
+
+=cut
+
+sub implements
+{
+ 1;
+}
+
+=item C<body($method, $line)>
+
+Returns the C code for the method body.
+
+Overrides the default implementation to direct all unknown methods to
+the PMC in the first attribute slot.
+
+=cut
+
+sub body
+{
+ my ($self, $method, $line) = @_;
+ my $meth = $method->{meth};
+ # existing methods get emitted
+ if ($self->SUPER::implements($meth)) {
+ my $n = $self->{has_method}{$meth};
+ return $self->SUPER::body($self->{methods}[$n]);
+ }
+ my $parameters = $method->{parameters};
+ my $n=0;
+ my @args = grep {$n++ & 1 ? $_ : 0} split / /, $parameters;
+ my $arg = '';
+ $arg = ", ". join(' ', @args) if @args;
+ $parameters = ", $parameters" if $parameters;
+ my $body = "VTABLE_$meth(interpreter, attr$arg)";
+ my $ret = gen_ret($method, $body);
+ my $decl = $self->decl($self->{class}, $method, 0);
+ my $l = "";
+ unless ($self->{opt}{nolines}) {
+ $l = <<"EOC";
+#line $line "ref.c"
+EOC
+ }
+ return <<EOC;
+$l
+$decl {
+ SLOTTYPE *attrib_array = PMC_data(pmc);
+ PMC *attr = get_attrib_num(attrib_array, POD_FIRST_ATTRIB);
+ $ret
+}
+
+EOC
+}
+
=back
=head1 SEE ALSO
1.46 +45 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -w -r1.45 -r1.46
--- objects.t 23 Jun 2004 12:41:55 -0000 1.45
+++ objects.t 23 Jun 2004 13:25:07 -0000 1.46
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.45 2004/06/23 12:41:55 leo Exp $
+# $Id: objects.t,v 1.46 2004/06/23 13:25:07 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 41;
+use Parrot::Test tests => 42;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1216,3 +1216,46 @@
42
MyInt(42)
OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - mmd methods");
+##PIR##
+
+.sub main @MAIN
+ .local pmc MyInt
+ getclass $P0, "Integer"
+ subclass MyInt, $P0, "MyInt"
+ .local pmc i
+ .local pmc j
+ .local pmc k
+ $I0 = find_type "MyInt"
+ i = new $I0
+ j = new $I0
+ k = new $I0
+ i = 6
+ j = 7
+ k = i * j
+ $I0 = k
+ print $I0
+ print "\n"
+ $S0 = k # get_string is overridden below
+ print $S0
+ print "\n"
+.end
+
+.namespace ["MyInt"]
+.sub __get_string method
+ $I0 = classoffset self, "MyInt"
+ $P0 = getattribute self, $I0
+ $I0 = $P0
+ $S1 = $I0
+ $S0 = "MyInt("
+ $S0 .= $S1
+ $S0 .= ")"
+ .pcc_begin_return
+ .return $S0
+ .pcc_end_return
+.end
+CODE
+42
+MyInt(42)
+OUTPUT
