Author: chromatic
Date: Wed May 2 23:56:51 2007
New Revision: 18408
Modified:
trunk/lib/Parrot/Pmc2c/Null.pm
trunk/lib/Parrot/Pmc2c/Ref.pm
trunk/lib/Parrot/Pmc2c/StmRef.pm
trunk/lib/Parrot/Pmc2c/default.pm
trunk/lib/Parrot/Pmc2c/deleg_pmc.pm
trunk/lib/Parrot/Pmc2c/delegate.pm
trunk/src/pmc/deleg_pmc.pmc
trunk/src/pmc/namespace.pmc
trunk/src/pmc/pair.pmc
trunk/src/pmc/stmref.pmc
Log:
[PMC] Fixed the final C++ casting warnings found by gcc.
While I was at it, I prettified the generated code slightly (in the generator;
stop looking at me funny) and fixed a couple of minor bugs there.
All that's left in the PMCs are five type-punning warnings. Use -O2 to make
gcc warn about them.
Modified: trunk/lib/Parrot/Pmc2c/Null.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Null.pm (original)
+++ trunk/lib/Parrot/Pmc2c/Null.pm Wed May 2 23:56:51 2007
@@ -49,7 +49,7 @@
my $ret = gen_ret($method);
# I think that these will be out by one - NWC
- my $l = $self->line_directive( $line, "null.c" );
+ my $l = $self->line_directive( $line, "\L$self->{class}.c" );
my $output = <<EOC;
$l
${decl} {
Modified: trunk/lib/Parrot/Pmc2c/Ref.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Ref.pm (original)
+++ trunk/lib/Parrot/Pmc2c/Ref.pm Wed May 2 23:56:51 2007
@@ -53,7 +53,7 @@
sub raw_deref {
my ( $self, $method ) = @_;
- return 'PMC_pmc_val(pmc)';
+ return '(PMC *)PMC_pmc_val(pmc)';
}
=item C<body($method, $line, $out_name)>
Modified: trunk/lib/Parrot/Pmc2c/StmRef.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/StmRef.pm (original)
+++ trunk/lib/Parrot/Pmc2c/StmRef.pm Wed May 2 23:56:51 2007
@@ -12,12 +12,12 @@
my $name = $method->{meth};
my $code = '';
$code .= <<'EOC';
- PMC *real_pmc;
+PMC *real_pmc;
Parrot_STM_PMC_handle handle;
assert(pmc->vtable->pmc_class != pmc);
- handle = PMC_struct_val(pmc);
+ handle = (Parrot_STM_PMC_handle)PMC_struct_val(pmc);
EOC
if ( $self->does_write($name) ) { # XXX is this good enough?
$code .= <<'EOC';
Modified: trunk/lib/Parrot/Pmc2c/default.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/default.pm (original)
+++ trunk/lib/Parrot/Pmc2c/default.pm Wed May 2 23:56:51 2007
@@ -53,7 +53,7 @@
}
# I think that these will be out by one - NWC
- my $l = $self->line_directive( $line, "default.c" );
+ my $l = $self->line_directive( $line, "\L$self->{class}.c" );
my $cout = <<EOC;
$l
${decl}\{
Modified: trunk/lib/Parrot/Pmc2c/deleg_pmc.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/deleg_pmc.pm (original)
+++ trunk/lib/Parrot/Pmc2c/deleg_pmc.pm Wed May 2 23:56:51 2007
@@ -51,12 +51,13 @@
my $decl = $self->decl( $self->{class}, $method, 0 );
# I think that these will be out by one - NWC
- my $l = $self->line_directive( $line, "ref.c" );
+ my $l = $self->line_directive( $line + 1, "\L$self->{class}.c" );
return <<EOC;
$l
$decl {
- SLOTTYPE *attrib_array = PMC_data(pmc);
- PMC *attr = get_attrib_num(attrib_array, 0);
+ SLOTTYPE *attrib_array = PMC_data_typed(pmc, SLOTTYPE *);
+ PMC *attr = get_attrib_num(attrib_array, 0);
+
$ret
}
Modified: trunk/lib/Parrot/Pmc2c/delegate.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/delegate.pm (original)
+++ trunk/lib/Parrot/Pmc2c/delegate.pm Wed May 2 23:56:51 2007
@@ -95,7 +95,7 @@
}
# I think that these will be out by one - NWC
- my $l = $self->line_directive( $line, "delegate.c" );
+ my $l = $self->line_directive( $line, "\L$self->{class}.c" );
# [Leave the space between "${decl}" and the "{"; otherwise Perl 5.8.0
# thinks this is a hashref. -- rgr, 29-Apr-07.]
my $cout = <<EOC;
Modified: trunk/src/pmc/deleg_pmc.pmc
==============================================================================
--- trunk/src/pmc/deleg_pmc.pmc (original)
+++ trunk/src/pmc/deleg_pmc.pmc Wed May 2 23:56:51 2007
@@ -1,5 +1,5 @@
/*
-Copyright (C) 2004, The Perl Foundation.
+Copyright (C) 2004-2007, The Perl Foundation.
$Id$
=head1 NAME
@@ -8,7 +8,7 @@
=head1 DESCRIPTION
-Delegate functions to the PMC in attribute slote #0.
+Delegate functions to the PMC in attribute slot #0.
Almost all methods are auto-generated in lib/Parrot/Pmc2c.pm
@@ -55,11 +55,13 @@
}
PMC* clone() {
- PMC* res = pmc_new(INTERP, SELF->vtable->base_type);
- INTVAL i;
- SLOTTYPE *attrib_array = PMC_data(res);
+ PMC *res = pmc_new(INTERP, SELF->vtable->base_type);
+ SLOTTYPE *attrib_array = PMC_data_typed(res, SLOTTYPE *);
+ INTVAL i;
+
for (i = 0; i < PMC_int_val(SELF); ++i)
attrib_array[i] = VTABLE_clone(INTERP, attrib_array[i]);
+
return res;
}
Modified: trunk/src/pmc/namespace.pmc
==============================================================================
--- trunk/src/pmc/namespace.pmc (original)
+++ trunk/src/pmc/namespace.pmc Wed May 2 23:56:51 2007
@@ -143,14 +143,15 @@
void set_pmc_keyed_str(STRING *key, PMC *value) {
const int val_is_NS = value->vtable->base_type == enum_class_NameSpace;
- HashBucket *b =
+ PMC *new_tuple = NULL;
+ HashBucket *b =
parrot_hash_get_bucket(INTERP, (Hash*) PMC_struct_val(SELF), key);
- PMC *new_tuple = NULL;
if (!b)
SUPER(key, value);
else {
- PMC *old = b->value;
+ PMC *old = (PMC *)b->value;
+
if ((old->vtable->base_type == enum_class_NameSpace) == val_is_NS)
{
/* simple ns or simple var/sub changed */
SUPER(key, value);
@@ -165,8 +166,10 @@
else {
/* creat new tuple */
new_tuple = pmc_new(INTERP, enum_class_FixedPMCArray);
+
/* flag it as special */
PObj_get_FLAGS(new_tuple) |= FPA_is_ns_ext;
+
/* for a fully typed namespace, we'd need 3 or 4 */
VTABLE_set_integer_native(INTERP, new_tuple, NS_max_slots);
}
@@ -175,14 +178,14 @@
if (val_is_NS) {
/* TODO - this hack needs to go */
Parrot_NSInfo *nsinfo = PARROT_NSINFO(value);
- PMC_pmc_val(value) = SELF; /* set parent */
- nsinfo->name = key; /* and name */
+ PMC_pmc_val(value) = SELF; /* set parent */
+ nsinfo->name = key; /* and name */
if (new_tuple) {
VTABLE_set_pmc_keyed_int(INTERP, new_tuple, NS_slot_ns,
value);
VTABLE_set_pmc_keyed_int(INTERP, new_tuple, NS_slot_var_sub,
- b->value);
+ (PMC *)b->value);
b->value = new_tuple;
/* distinction from a plain FPA, which doesn't extend the
* namespace storage
@@ -190,7 +193,8 @@
}
}
else if (new_tuple) {
- VTABLE_set_pmc_keyed_int(INTERP, new_tuple, NS_slot_ns, b->value);
+ VTABLE_set_pmc_keyed_int(INTERP, new_tuple, NS_slot_ns,
+ (PMC *)b->value);
VTABLE_set_pmc_keyed_int(INTERP, new_tuple, NS_slot_var_sub,
value);
b->value = new_tuple;
}
@@ -220,13 +224,16 @@
real_exception(INTERP, NULL, E_NameError, "Invalid namespace key");
}
- PMC* get_pmc_keyed_str(STRING* key) {
- PMC *ns = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ PMC* get_pmc_keyed_str(STRING *key) {
+ PMC *ns = (PMC *)parrot_hash_get(INTERP, (Hash *)PMC_struct_val(SELF),
+ key);
if (!ns)
return PMCNULL;
+
if ((PObj_get_FLAGS(ns) & FPA_is_ns_ext) &&
ns->vtable->base_type == enum_class_FixedPMCArray)
ns = VTABLE_get_pmc_keyed_int(INTERP, ns, NS_slot_ns);
+
return ns;
}
@@ -271,13 +278,16 @@
*/
- void* get_pointer_keyed_str(STRING* key) {
- PMC *ns = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ void* get_pointer_keyed_str(STRING *key) {
+ PMC *ns = (PMC *)parrot_hash_get(INTERP, (Hash *)PMC_struct_val(SELF),
+ key);
if (!ns)
return PMCNULL;
+
if ((PObj_get_FLAGS(ns) & FPA_is_ns_ext) &&
ns->vtable->base_type == enum_class_FixedPMCArray)
ns = VTABLE_get_pmc_keyed_int(INTERP, ns, NS_slot_var_sub);
+
return ns;
}
@@ -431,7 +441,8 @@
METHOD PMC* find_namespace(STRING* key) {
STRING *s_ns = CONST_STRING(INTERP, "NameSpace");
- PMC *ns = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ PMC *ns = (PMC *)parrot_hash_get(INTERP,
+ (Hash *)PMC_struct_val(SELF), key);
if (!ns)
return PMCNULL;
@@ -445,7 +456,7 @@
/*
-=item C<METHOD PMC* find_sub(STRING* name)>
+=item C<METHOD PMC* find_sub(STRING *name)>
Return the Sub PMC with the given name.
@@ -453,9 +464,10 @@
*/
- METHOD PMC* find_sub(STRING* key) {
+ METHOD PMC* find_sub(STRING *key) {
STRING *s_sub = CONST_STRING(INTERP, "Sub");
- PMC *sub = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ PMC *sub = (PMC *)parrot_hash_get(INTERP,
+ (Hash *)PMC_struct_val(SELF), key);
if (!sub)
return PMCNULL;
@@ -469,7 +481,7 @@
/*
-=item C<METHOD PMC* find_var(STRING* name)>
+=item C<METHOD PMC* find_var(STRING *name)>
Return the PMC with the given name.
@@ -477,8 +489,9 @@
*/
- METHOD PMC* find_var(STRING* key) {
- PMC *val = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ METHOD PMC* find_var(STRING *key) {
+ PMC *val = (PMC *)parrot_hash_get(INTERP,
+ (Hash *)PMC_struct_val(SELF), key);
if (!val)
return PMCNULL;
@@ -488,7 +501,7 @@
/*
-=item C<METHOD PMC* del_namespace(STRING* name)>
+=item C<METHOD PMC* del_namespace(STRING *name)>
Deletes the contained NameSpace PMC with the given name. Throws an invalid
type exception if the item to delete is not a NameSpace PMC or subclass, and
@@ -498,9 +511,9 @@
*/
- METHOD void del_namespace(STRING* name) {
- Hash *hash = (Hash *) PMC_struct_val(SELF);
- PMC *ns = parrot_hash_get(INTERP, hash, name);
+ METHOD void del_namespace(STRING *name) {
+ Hash *hash = (Hash *)PMC_struct_val(SELF);
+ PMC *ns = (PMC *)parrot_hash_get(INTERP, hash, name);
STRING *s_ns = CONST_STRING(INTERP, "NameSpace");
if ( PMC_IS_NULL(ns) )
@@ -521,7 +534,7 @@
/*
-=item C<METHOD PMC* del_sub(STRING* name)>
+=item C<METHOD PMC* del_sub(STRING *name)>
Deletes the contained Sub PMC with the given name. Throws an invalid type
exception if the item to delete is not a Sub PMC or subclass, and does not
@@ -531,9 +544,9 @@
*/
- METHOD void del_sub(STRING* name) {
- Hash *hash = (Hash *) PMC_struct_val(SELF);
- PMC *sub = parrot_hash_get(INTERP, hash, name);
+ METHOD void del_sub(STRING *name) {
+ Hash *hash = (Hash *)PMC_struct_val(SELF);
+ PMC *sub = (PMC *)parrot_hash_get(INTERP, hash, name);
STRING *s_sub = CONST_STRING(INTERP, "Sub");
if ( PMC_IS_NULL(sub) )
@@ -575,17 +588,21 @@
*/
- METHOD PMC* get_sym(STRING* key) {
- PMC *ns = parrot_hash_get(INTERP, (Hash*) PMC_struct_val(SELF), key);
+ METHOD PMC* get_sym(STRING *key) {
+ PMC *ns = (PMC *)parrot_hash_get(INTERP,
+ (Hash *)PMC_struct_val(SELF), key);
+
if (!ns)
return PMCNULL;
- if (ns->vtable == SELF->vtable) {
- /* it's a NameSpace */
+
+ /* it's a NameSpace */
+ if (ns->vtable == SELF->vtable)
return PMCNULL;
- }
+
if ((PObj_get_FLAGS(ns) & FPA_is_ns_ext) &&
ns->vtable->base_type == enum_class_FixedPMCArray)
ns = VTABLE_get_pmc_keyed_int(INTERP, ns, NS_slot_var_sub);
+
return ns;
}
Modified: trunk/src/pmc/pair.pmc
==============================================================================
--- trunk/src/pmc/pair.pmc (original)
+++ trunk/src/pmc/pair.pmc Wed May 2 23:56:51 2007
@@ -158,39 +158,51 @@
*/
- INTVAL is_equal(PMC* value) {
+ INTVAL is_equal(PMC *value) {
STRING *s1, *s2;
PMC *k1, *k2, *p1, *p2;
+
if (value->vtable->base_type != SELF->vtable->base_type)
return 0;
- s1 = PMC_struct_val(SELF);
- s2 = PMC_struct_val(value);
+
+ s1 = (STRING *)PMC_struct_val(SELF);
+ s2 = (STRING *)PMC_struct_val(value);
+
if (PObj_key_is_string_TEST(SELF) && PObj_key_is_string_TEST(value)) {
if (string_equal(INTERP, s1, s2))
return 0;
}
+
if (PObj_key_is_string_TEST(SELF)) {
- k1 = pmc_new(INTERP, enum_class_String);
- PMC_str_val(k1) = PMC_struct_val(SELF);
+ k1 = pmc_new(INTERP, enum_class_String);
+ PMC_str_val(k1) = (STRING *)PMC_struct_val(SELF);
}
else
- k1 = PMC_struct_val(SELF);
+ k1 = (PMC *)PMC_struct_val(SELF);
+
if (PObj_key_is_string_TEST(value)) {
- k2 = pmc_new(INTERP, enum_class_String);
- PMC_str_val(k2) = PMC_struct_val(value);
+ k2 = pmc_new(INTERP, enum_class_String);
+ PMC_str_val(k2) = (STRING *)PMC_struct_val(value);
}
+
else
- k2 = PMC_struct_val(value);
+ k2 = (PMC *)PMC_struct_val(value);
+
if (!mmd_dispatch_i_pp(INTERP, k1, k2, MMD_EQ))
return 0;
+
p1 = PMC_pmc_val(SELF);
p2 = PMC_pmc_val(value);
+
if (!p1 && !p2)
return 1;
+
if (p1 || p2)
return 0;
+
if (!mmd_dispatch_i_pp(INTERP, p1, p2, MMD_EQ))
return 0;
+
return 1;
}
@@ -217,16 +229,18 @@
io->vtable->push_integer(INTERP, io, PObj_key_is_string_TEST(SELF));
if (PObj_key_is_string_TEST(SELF)) {
- io->vtable->push_string(INTERP, io, PMC_struct_val(SELF));
+ io->vtable->push_string(INTERP, io, (STRING
*)PMC_struct_val(SELF));
}
else {
PMC ** const temp_pos = (PMC**)&PMC_struct_val(SELF);
- info->thaw_ptr = temp_pos;
+ info->thaw_ptr = temp_pos;
(info->visit_pmc_now)(INTERP, *temp_pos, info);
}
- pos = &PMC_pmc_val(SELF);
+ pos = &PMC_pmc_val(SELF);
info->thaw_ptr = pos;
+
(info->visit_pmc_now)(INTERP, *pos, info);
+
SUPER(info);
}
@@ -235,7 +249,7 @@
SUPER(info);
io->vtable->push_integer(INTERP, io, PObj_key_is_string_TEST(SELF));
if (PObj_key_is_string_TEST(SELF)) {
- io->vtable->push_string(INTERP, io, PMC_struct_val(SELF));
+ io->vtable->push_string(INTERP, io, (STRING
*)PMC_struct_val(SELF));
}
}
@@ -273,12 +287,14 @@
METHOD PMC* key() {
if (PObj_key_is_string_TEST(SELF)) {
- PMC * const k = pmc_new(INTERP,
+ PMC * const k = pmc_new(INTERP,
Parrot_get_ctx_HLL_type(INTERP, enum_class_String));
- PMC_str_val(k) = PMC_struct_val(SELF);
+
+ PMC_str_val(k) = (STRING *)PMC_struct_val(SELF);
+
return k;
}
- return PMC_struct_val(SELF);
+ return (PMC *)PMC_struct_val(SELF);
}
METHOD PMC* value() {
@@ -289,9 +305,11 @@
Parrot_get_ctx_HLL_type(INTERP, enum_class_FixedPMCArray));
VTABLE_set_integer_native(INTERP, t, 2);
if (PObj_key_is_string_TEST(SELF))
- VTABLE_set_string_keyed_int(INTERP, t, 0, PMC_struct_val(SELF));
+ VTABLE_set_string_keyed_int(INTERP, t, 0,
+ (STRING *)PMC_struct_val(SELF));
else
- VTABLE_set_pmc_keyed_int(INTERP, t, 0, PMC_struct_val(SELF));
+ VTABLE_set_pmc_keyed_int(INTERP, t, 0, (PMC
*)PMC_struct_val(SELF));
+
VTABLE_set_pmc_keyed_int(INTERP, t, 1, PMC_pmc_val(SELF));
return t;
}
Modified: trunk/src/pmc/stmref.pmc
==============================================================================
--- trunk/src/pmc/stmref.pmc (original)
+++ trunk/src/pmc/stmref.pmc Wed May 2 23:56:51 2007
@@ -1,14 +1,14 @@
/*
-Copyright (C) 2006 The Perl Foundation.
+Copyright (C) 2006-2007 The Perl Foundation.
$Id$
=head1 NAME
-src/pmc/ref.pmc - Reference to a PMC
+src/pmc/stmref.pmc - STM-capable Reference to a PMC
=head1 DESCRIPTION
-The vtable functions for the Ref base class.
+The vtable functions for the STMRef base class.
All methods not present below get a default body autogenerated inside
C<Parrot::Pmc2c>.
@@ -65,7 +65,8 @@
*/
void mark() {
- Parrot_STM_mark_pmc_handle(INTERP, PMC_struct_val(SELF));
+ Parrot_STM_mark_pmc_handle(INTERP,
+ (Parrot_STM_PMC_handle)PMC_struct_val(SELF));
}
/*
@@ -102,7 +103,8 @@
}
INTVAL defined() {
- Parrot_STM_PMC_handle handle = PMC_struct_val(pmc);
+ Parrot_STM_PMC_handle handle =
+ (Parrot_STM_PMC_handle)PMC_struct_val(pmc);
PMC *value = Parrot_STM_read(INTERP, handle);
return !PMC_IS_NULL(value);
}
@@ -116,7 +118,8 @@
SUPER(info);
- Parrot_freeze_STM_PMC_handle(INTERP, io, PMC_struct_val(SELF));
+ Parrot_freeze_STM_PMC_handle(INTERP, io,
+ (Parrot_STM_PMC_handle)PMC_struct_val(SELF));
}
void thaw(visit_info *info) {
@@ -133,9 +136,9 @@
}
PMC* get_pmc() {
- Parrot_STM_PMC_handle handle = PMC_struct_val(SELF);
- PMC *value = Parrot_STM_begin_update(INTERP, handle);
- return value;
+ Parrot_STM_PMC_handle handle =
+ (Parrot_STM_PMC_handle)PMC_struct_val(SELF);
+ return Parrot_STM_begin_update(INTERP, handle);
}
}
