cvsuser 05/02/23 01:45:05
Modified: src objects.c
t/op trans.t
t/pmc objects.t
Log:
some more tests
* fill attribute slots with PMCNULL
* better diags for failed attribute access
* test for -0.0 preservation
Revision Changes Path
1.130 +17 -7 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.129
retrieving revision 1.130
diff -u -r1.129 -r1.130
--- objects.c 30 Dec 2004 00:13:58 -0000 1.129
+++ objects.c 23 Feb 2005 09:45:03 -0000 1.130
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.129 2004/12/30 00:13:58 scog Exp $
+$Id: objects.c,v 1.130 2005/02/23 09:45:03 leo Exp $
=head1 NAME
@@ -745,7 +745,7 @@
PMC *init, int is_python)
{
SLOTTYPE *new_object_array;
- INTVAL attrib_count;
+ INTVAL attrib_count, i;
SLOTTYPE *class_array;
PMC *class;
PMC *class_name;
@@ -770,6 +770,10 @@
attrib_count + POD_FIRST_ATTRIB);
new_object_array = PMC_data(object);
+ /* fill with PMCNULL, so that access doesn't segfault */
+ for (i = POD_FIRST_ATTRIB; i < attrib_count + POD_FIRST_ATTRIB; ++i)
+ set_attrib_num(object, new_object_array, i, PMCNULL);
+
/* turn marking on */
set_attrib_flags(object);
/* 0 - class PMC, 1 - class name */
@@ -1491,7 +1495,8 @@
attrib_array = PMC_data(object);
attrib_count = ATTRIB_COUNT(object);
if (attrib >= attrib_count || attrib < POD_FIRST_ATTRIB) {
- internal_exception(OUT_OF_BOUNDS, "No such attribute");
+ internal_exception(OUT_OF_BOUNDS,
+ "No such attribute #%d", (int)attrib);
}
return get_attrib_num(attrib_array, attrib);
}
@@ -1503,6 +1508,7 @@
PMC *attr_hash;
SLOTTYPE *class_array;
HashBucket *b;
+ char *cattr, *cobj;
if (!PObj_is_object_TEST(object))
internal_exception(INTERNAL_NOT_IMPLEMENTED,
@@ -1515,9 +1521,12 @@
(Hash*) PMC_struct_val(attr_hash), attr);
if (b)
return VTABLE_get_integer(interpreter, (PMC*)b->value);
- /* TODO escape the NUL char(s) */
- internal_exception(1, "No such attribute '%s'",
- string_to_cstring(interpreter, attr));
+ /* escape the NUL char */
+ cobj = string_to_cstring(interpreter, attr);
+ cattr = cobj + strlen(cobj) + 1;
+ internal_exception(1, "No such attribute '%s\\0%s'",
+ cobj, cattr);
+ string_cstring_free(cattr);
return 0;
}
@@ -1558,7 +1567,8 @@
attrib_array = PMC_data(object);
attrib_count = ATTRIB_COUNT(object);
if (attrib >= attrib_count || attrib < POD_FIRST_ATTRIB) {
- internal_exception(OUT_OF_BOUNDS, "No such attribute");
+ internal_exception(OUT_OF_BOUNDS,
+ "No such attribute #%d", (int)attrib);
}
set_attrib_num(object, attrib_array, attrib, value);
}
1.13 +12 -5 parrot/t/op/trans.t
Index: trans.t
===================================================================
RCS file: /cvs/public/parrot/t/op/trans.t,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- trans.t 1 Oct 2004 21:16:49 -0000 1.12
+++ trans.t 23 Feb 2005 09:45:04 -0000 1.13
@@ -1,6 +1,6 @@
#!perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: trans.t,v 1.12 2004/10/01 21:16:49 jrieks Exp $
+# $Id: trans.t,v 1.13 2005/02/23 09:45:04 leo Exp $
=head1 NAME
@@ -334,7 +334,7 @@
.fp_eq (N4, 0.785398, EQ4)
print "not "
EQ4: print "ok 4\\n"
-
+
atan N4, N3, 1.0
.fp_eq (N4, -0.785398, EQ5)
print "not "
@@ -359,7 +359,7 @@
.fp_eq (N4, 2.356194, EQ9)
print "not "
EQ9: print "ok 9\\n"
-
+
atan N4, 1.0, I0
.fp_eq (N4, 1.570796, EQ10)
print "not "
@@ -394,6 +394,12 @@
.fp_eq (N4, 0.000000, EQ16)
print "not "
EQ16: print "ok 16\\n"
+
+ atan N4, -0.0, -0.0
+ .fp_eq (N4, -3.1415926, EQ17)
+ print "not "
+ print N4
+EQ17: print "ok 17\\n"
end
CODE
ok 1
@@ -412,6 +418,7 @@
ok 14
ok 15
ok 16
+ok 17
OUTPUT
output_is( <<"CODE", <<OUTPUT, "log2" );
@@ -524,7 +531,7 @@
set I1, 1
set N2, 4.0
set I2, 4
- pow N3, N2, 2.5
+ pow N3, N2, 2.5
.fp_eq (N3, 32.0, EQ5)
print "not "
EQ5: print "ok 5\\n"
@@ -623,5 +630,5 @@
ok 2
OUTPUT
-
+
1;
1.67 +27 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- objects.t 2 Jan 2005 11:34:56 -0000 1.66
+++ objects.t 23 Feb 2005 09:45:05 -0000 1.67
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.66 2005/01/02 11:34:56 leo Exp $
+# $Id: objects.t,v 1.67 2005/02/23 09:45:05 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 57;
+use Parrot::Test tests => 59;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -455,6 +455,31 @@
/No such attribute/
OUTPUT
+output_like(<<'CODE', <<'OUTPUT', "setting non-existent by name");
+ newclass P1, "Foo"
+ find_type I0, "Foo"
+ new P2, I0
+
+ new P3, .PerlInt
+ setattribute P2, "Foo\0no_such", P3
+ end
+CODE
+/No such attribute 'Foo\\0no_such'/
+OUTPUT
+
+output_like(<<'CODE', <<'OUTPUT', "getting NULL attribute");
+ newclass P1, "Foo"
+ addattribute P1, "i"
+ find_type I0, "Foo"
+ new P2, I0
+
+ getattribute P3, P2, "Foo\0i"
+ print P3
+ end
+CODE
+/Null PMC access/
+OUTPUT
+
output_like(<<'CODE', <<'OUTPUT', "setting non-existent attribute - 1");
newclass P1, "Foo"
find_type I0, "Foo"
