cvsuser 04/11/09 07:07:29
Modified: classes parrotclass.pmc parrotobject.pmc
include/parrot pmc_freeze.h
t/pmc freeze.t
Log:
freeze_thaw a class 4 - non-working hooks for objects
Revision Changes Path
1.27 +5 -3 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- parrotclass.pmc 9 Nov 2004 11:58:02 -0000 1.26
+++ parrotclass.pmc 9 Nov 2004 15:07:26 -0000 1.27
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotclass.pmc,v 1.26 2004/11/09 11:58:02 leo Exp $
+$Id: parrotclass.pmc,v 1.27 2004/11/09 15:07:26 leo Exp $
=head1 NAME
@@ -161,6 +161,8 @@
class_data = (PMC **)PMC_data(SELF);
+ if (info->extra_flags == EXTRA_CLASS_EXISTS)
+ PIO_eprintf(INTERP, "class exists\n");
/* 2) direct parents array */
pos = class_data + PCD_PARENTS;
(info->visit_pmc_now)(interpreter, *pos, info);
@@ -205,7 +207,7 @@
*/
new_type = pmc_type(INTERP, class_name);
if (new_type > enum_type_undef) {
- /* exists */
+ /* info->extra_flags = EXTRA_CLASS_EXISTS; */
}
else {
class = *info->thaw_ptr;
@@ -222,7 +224,7 @@
PMC **class_data = (PMC **)PMC_data(SELF);
/*
- * we now have to plain array: parents and attributes
+ * we now have two plain arrays: 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
1.33 +49 -1 parrot/classes/parrotobject.pmc
Index: parrotobject.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotobject.pmc,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- parrotobject.pmc 16 Jul 2004 12:15:27 -0000 1.32
+++ parrotobject.pmc 9 Nov 2004 15:07:26 -0000 1.33
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotobject.pmc,v 1.32 2004/07/16 12:15:27 leo Exp $
+$Id: parrotobject.pmc,v 1.33 2004/11/09 15:07:26 leo Exp $
=head1 NAME
@@ -159,6 +159,54 @@
PMC* get_class() {
return GET_CLASS(PMC_data(SELF), SELF);
}
+
+/*
+
+=item C<void visit(visit_info *info)>
+
+This is used by freeze/thaw to visit the contents of the object.
+
+C<*info> is the visit info, (see F<include/parrot/pmc_freeze.h>).
+
+=item C<void freeze(visit_info *info)>
+
+Used to archive the object.
+
+=item C<void thaw(visit_info *info)>
+
+Used to unarchive the object.
+
+=item C<void thawfinish(visit_info *info)>
+
+=cut
+
+*/
+
+ void visit(visit_info *info) {
+ PMC **class_data, **pos;
+ INTVAL i, n;
+
+ class_data = (PMC **)PMC_data(SELF);
+
+ /* 1) visit class */
+ pos = class_data + POD_CLASS;
+ (info->visit_pmc_now)(interpreter, *pos, info);
+
+ /* 2) visit the attributes */
+ n = ATTRIB_COUNT(SELF);
+ for (i = POD_FIRST_ATTRIB; i < n; ++i) {
+ info->thaw_ptr = class_data + i;
+ (info->visit_pmc_now)(interpreter, class_data[i], info);
+ }
+ }
+ void freeze(visit_info *info) {
+ Parrot_default_freeze(INTERP, SELF, info);
+ }
+ void thaw(visit_info *info) {
+ Parrot_default_thaw(INTERP, SELF, info);
+ }
+ void thawfinish(visit_info *info) {
+ }
}
/*
1.8 +3 -2 parrot/include/parrot/pmc_freeze.h
Index: pmc_freeze.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc_freeze.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- pmc_freeze.h 20 Aug 2004 08:41:37 -0000 1.7
+++ pmc_freeze.h 9 Nov 2004 15:07:28 -0000 1.8
@@ -1,7 +1,7 @@
/* pmc_freeze.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: pmc_freeze.h,v 1.7 2004/08/20 08:41:37 leo Exp $
+ * $Id: pmc_freeze.h,v 1.8 2004/11/09 15:07:28 leo Exp $
* Overview:
* PMC freeze and thaw interface
* Data Structure and Algorithms:
@@ -56,7 +56,8 @@
typedef enum {
EXTRA_IS_NULL,
EXTRA_IS_COUNT,
- EXTRA_IS_PROP_HASH
+ EXTRA_IS_PROP_HASH,
+ EXTRA_CLASS_EXISTS
} extra_flags_enum;
typedef struct _visit_info {
1.16 +59 -2 parrot/t/pmc/freeze.t
Index: freeze.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/freeze.t,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- freeze.t 9 Nov 2004 11:58:04 -0000 1.15
+++ freeze.t 9 Nov 2004 15:07:29 -0000 1.16
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: freeze.t,v 1.15 2004/11/09 11:58:04 leo Exp $
+# $Id: freeze.t,v 1.16 2004/11/09 15:07:29 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 20;
+use Parrot::Test tests => 21;
use Test::More;
END { unlink "temp.fpmc"; };
@@ -482,6 +482,8 @@
Foo
OUTPUT
+SKIP: {
+ skip("todo class exists", 1);
output_is(<<'CODE', <<'OUTPUT', "freeze/thaw simple class");
newclass P10, "Foo"
classname S10, P10
@@ -500,6 +502,7 @@
ok
Foo
OUTPUT
+}
output_is(<<'CODE', <<'OUTPUT', "freeze class w attr");
newclass P10, "Foo"
@@ -559,3 +562,57 @@
ok 4
ok 5
OUTPUT
+
+SKIP: {
+ skip("todo class exists", 1);
+output_is(<<'CODE', <<'OUTPUT', "thaw class w attrr");
+ newclass P10, "Foo"
+ addattribute P10, ".aa"
+ addattribute P10, ".bb"
+ classname S10, P10
+ print S10
+ print "\n"
+ freeze S3, P10
+ open P3, "temp.fpmc", ">"
+ print P3, S3
+ 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, "Foo\0.aa", P6
+ new P6, .PerlString
+ set P6, "ok 6\n"
+ setattribute P5, "Foo\0.bb", P6
+ print "ok 4\n"
+ getattribute P7, P5, I5
+ print P7
+ inc I5
+ getattribute P7, P5, I5
+ print P7
+ end
+
+
+CODE
+Foo
+ok 1
+ok 2
+Foo
+ok 3
+ok 4
+ok 5
+ok 6
+OUTPUT
+}
