cvsuser 04/11/09 03:58:04
Modified: classes parrotclass.pmc
t/pmc freeze.t
Log:
freeze_thaw a class 3 - attributes
Revision Changes Path
1.26 +55 -8 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- parrotclass.pmc 9 Nov 2004 08:43:08 -0000 1.25
+++ parrotclass.pmc 9 Nov 2004 11:58:02 -0000 1.26
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotclass.pmc,v 1.25 2004/11/09 08:43:08 leo Exp $
+$Id: parrotclass.pmc,v 1.26 2004/11/09 11:58:02 leo Exp $
=head1 NAME
@@ -148,24 +148,27 @@
Used to unarchive the class.
+=item C<void thawfinish(visit_info *info)>
+
+Create the class from the thawed parents and attributes array.
+
=cut
*/
void visit(visit_info *info) {
- INTVAL i, n;
PMC **class_data, **pos;
class_data = (PMC **)PMC_data(SELF);
/* 2) direct parents array */
pos = class_data + PCD_PARENTS;
- info->thaw_ptr = pos;
(info->visit_pmc_now)(interpreter, *pos, info);
- /* 3) attributes */
- pos = class_data + PCD_ATTRIBUTES;
- info->thaw_ptr = pos;
+
+ /* 3) attributes array */
+ pos = class_data + PCD_CLASS_ATTRIBUTES;
(info->visit_pmc_now)(interpreter, *pos, info);
+
SUPER(info);
}
@@ -175,18 +178,25 @@
SUPER(info);
class_data = (PMC **)PMC_data(SELF);
+
/* 1) freeze class name */
pos = class_data + PCD_CLASS_NAME;
io->vtable->push_string(INTERP, io,
VTABLE_get_string(INTERP, *pos));
+
}
void thaw(visit_info *info) {
IMAGE_IO *io = info->image_io;
+ STRING *mark, *s;
+ PMC *class;
+
SUPER(info);
if (info->extra_flags == EXTRA_IS_NULL) {
STRING *class_name;
INTVAL new_type;
+ PMC *ar;
+
/* thaw class name */
class_name = io->vtable->shift_string(INTERP, io);
/* if class exists in this interpreter, check if the
@@ -195,14 +205,51 @@
*/
new_type = pmc_type(INTERP, class_name);
if (new_type > enum_type_undef) {
- /* TODO */
+ /* exists */
}
else {
- Parrot_new_class(INTERP, *info->thaw_ptr, class_name);
+ class = *info->thaw_ptr;
+ Parrot_new_class(INTERP, class, class_name);
}
}
}
+ void thawfinish(visit_info *info) {
+ INTVAL i, n;
+ PMC * class = SELF;
+ PMC *parents, *attribs;
+ int ignore = 0; /* XXX */
+ PMC **class_data = (PMC **)PMC_data(SELF);
+
+ /*
+ * we now have to plain array: parents and attributes
+ * TODO if class did exists compare these with the
+ * information in the class
+ * TODO don't thaw directly into class array - this destroys
+ * existing classes
+ */
+
+ parents = class_data[PCD_PARENTS];
+ n = VTABLE_elements(INTERP, parents);
+ for (i = 0; i < n; ++i) {
+ Parrot_add_parent(INTERP, class,
+ VTABLE_get_pmc_keyed_int(INTERP, parents, i));
+ }
+ /*
+ * preserve the thawed attrib array
+ */
+ attribs = class_data[PCD_CLASS_ATTRIBUTES];
+ attribs = VTABLE_clone(INTERP, attribs);
+ /* set an empty one in the class */
+ class_data[PCD_CLASS_ATTRIBUTES] = pmc_new(INTERP, enum_class_Array);
+
+ n = VTABLE_elements(INTERP, attribs);
+ for (i = 0; i < n; ++i) {
+ Parrot_add_attribute(INTERP, class,
+ VTABLE_get_string_keyed_int(INTERP, attribs, i));
+ }
+ }
+
}
/*
1.15 +59 -2 parrot/t/pmc/freeze.t
Index: freeze.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/freeze.t,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- freeze.t 9 Nov 2004 09:46:04 -0000 1.14
+++ freeze.t 9 Nov 2004 11:58:04 -0000 1.15
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: freeze.t,v 1.14 2004/11/09 09:46:04 leo Exp $
+# $Id: freeze.t,v 1.15 2004/11/09 11:58:04 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 18;
+use Parrot::Test tests => 20;
use Test::More;
END { unlink "temp.fpmc"; };
@@ -501,4 +501,61 @@
Foo
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "freeze class w attr");
+ newclass P10, "Foo"
+ addattribute P10, ".aa"
+ classname S10, P10
+ print S10
+ print "\n"
+ freeze S11, P10
+ print "ok 1\n"
+ open P3, "temp.fpmc", ">"
+ print P3, S11
+ close P3
+ print "ok 2\n"
+ end
+CODE
+Foo
+ok 1
+ok 2
+OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "thaw class w attr into new interpreter");
+ set S3, "temp.fpmc"
+ .include "stat.pasm"
+ stat I0, S3, .STAT_FILESIZE
+ gt I0, 1, ok1
+ print "stat failed\n"
+ exit 1
+ok1:
+ open P3, S3, "<"
+ read S3, P3, I0
+ close P3
+ # print S3
+ # print "\n"
+ print "ok 1\n"
+ thaw P4, S3
+ print "ok 2\n"
+ classname S10, P4
+ print S10
+ print "\n"
+
+ find_type I4, S10
+ new P5, I4
+ print "ok 3\n"
+ classoffset I5, P5, S10
+ new P6, .PerlString
+ set P6, "ok 5\n"
+ setattribute P5, I5, P6
+ print "ok 4\n"
+ getattribute P7, P5, I5
+ print P7
+ end
+CODE
+ok 1
+ok 2
+Foo
+ok 3
+ok 4
+ok 5
+OUTPUT
