cvsuser 03/07/16 05:53:02
Modified: . interpreter.c object.ops
Added: . objects.c
Log:
Create and subclass classes
Revision Changes Path
1.171 +6 -2 parrot/interpreter.c
Index: interpreter.c
===================================================================
RCS file: /cvs/public/parrot/interpreter.c,v
retrieving revision 1.170
retrieving revision 1.171
diff -u -w -r1.170 -r1.171
--- interpreter.c 14 Jul 2003 09:54:50 -0000 1.170
+++ interpreter.c 16 Jul 2003 12:53:01 -0000 1.171
@@ -1,7 +1,7 @@
/* interpreter.c
- * Copyright: (When this is determined...it will go here)
+ * Copyright: 2001, 2002, 2001 Yet Another Society
* CVS Info
- * $Id: interpreter.c,v 1.170 2003/07/14 09:54:50 leo Exp $
+ * $Id: interpreter.c,v 1.171 2003/07/16 12:53:01 dan Exp $
* Overview:
* The interpreter api handles running the operations
* Data Structure and Algorithms:
@@ -601,6 +601,10 @@
/* setup stdio PMCs */
PIO_init(interpreter);
/* Done. Return and be done with it */
+
+ /* Add in the class hash. Bit of a hack, probably, as there's
+ altogether too much overlap with the PMC classes */
+ interpreter->class_hash = pmc_new(interpreter, enum_class_PerlHash);
/* Okay, we've finished doing anything that might trigger GC.
* Actually, we could enable DOD/GC earlier, but here all setup is
1.3 +53 -2 parrot/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/object.ops,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- object.ops 18 Jun 2003 12:28:50 -0000 1.2
+++ object.ops 16 Jul 2003 12:53:01 -0000 1.3
@@ -92,21 +92,72 @@
=cut
inline op subclass(out PMC, in PMC, in STR) {
+ $1 = Parrot_single_subclass(interpreter, $2, $3);
goto NEXT();
}
inline op subclass(out PMC, in PMC) {
+ $1 = Parrot_single_subclass(interpreter, $2, NULL);
goto NEXT();
}
-inline op subclass(out PMC, in STR, in STR) {
+op subclass(out PMC, in STR, in STR) {
+ PMC *class = VTABLE_get_pmc_keyed(interpreter, interpreter->class_hash,
key_new_string(interpreter, $2));
+ if (!class) {
+ internal_exception(NO_CLASS, "Class doesn't exist");
+ }
+ $1 = Parrot_single_subclass(interpreter, class, $3);
+ goto NEXT();
+}
+
+op subclass(out PMC, in STR) {
+ PMC *class = VTABLE_get_pmc_keyed(interpreter, interpreter->class_hash,
key_new_string(interpreter, $2));
+ if (!class) {
+ internal_exception(NO_CLASS, "Class doesn't exist");
+ }
+ $1 = Parrot_single_subclass(interpreter, class, NULL);
goto NEXT();
}
-inline op subclass(out PMC, in STR) {
+=item B<newclass>(out PMC, in STR)
+
+Create a new base class named $2
+
+=cut
+
+inline op newclass(out PMC, in STR) {
+ $1 = Parrot_new_class(interpreter, $2)
+}
+
+=item B<findclass>(out INT, in STR)
+
+Returns 1 if the class exists, 0 if it does not.
+
+=cut
+
+inline op findclass(out INT, in STR) {
+ if (VTABLE_get_pmc_keyed(interpreter, interpreter->class_hash,
key_new_string(interpreter, $2))) {
+ $1 = 1;
+ } else {
+ $1 = 0;
+ }
goto NEXT();
}
+=item B<getclass>(out PMC, in STR)
+
+Find the PMC for a class, by name. Note that this is a one-level hash, so for
+classes that have some structure you need to impose that structure externally.
+
+Parrot's conventions are that level separators are noted with the NULL
+character, so Perl's Foo::Bar would be Foo\0Bar.
+
+=cut
+
+inline op findclass(out PMC, in STR) {
+ $1 = VTABLE_get_pmc_keyed(interpreter, interpreter->class_hash,
key_new_string(interpreter, $2));
+ goto NEXT();
+}
=item B<singleton>(in PMC)
1.1 parrot/objects.c
Index: objects.c
===================================================================
/* objects.c
* Copyright: 2003, Yet Another Society
* CVS Info
* $Id: objects.c,v 1.1 2003/07/16 12:53:01 dan Exp $
* Overview:
* Handles class and object manipulation
* Data Structure and Algorithms:
* History:
* Notes:
* References:
*/
#include "parrot/parrot.h"
/* Subclass a class. Single parent class, nice and
straightforward. If child_class is NULL, this is an anonymous
subclass we're creating, which happens commonly enough to warrant
an actual single-subclass function
*/
PMC *
Parrot_single_subclass(Parrot_Interp interpreter, PMC *base_class,
STRING *child_class_name) {
PMC *child_class;
PMC *child_class_array;
PMC *classname_pmc;
PMC *temp_pmc;
if (!PObj_is_class_TEST(base_class)) {
internal_exception(NO_CLASS, "Can't subclass a non-class!");
}
child_class = pmc_new(interpreter, enum_class_ParrotClass);
child_class_array = PMC_data(child_class);
/* We have the same number of attributes as our parent */
child_class->obj.u.int_val = base_class->obj.u.int_val;
/* Our parent class array has a single member in it */
temp_pmc = pmc_new(interpreter, enum_class_Array);
VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 0, temp_pmc);
VTABLE_set_pmc_keyed_int(interpreter, temp_pmc, 0, base_class);
/* Our penultimate parent list is a clone of our parent's parent
list, with our parent unshifted onto the beginning */
temp_pmc = pmc_new(interpreter, enum_class_PerlUndef);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
(PMC *)PMC_data(base_class), 1),
temp_pmc);
VTABLE_unshift_pmc(interpreter, temp_pmc, base_class);
VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 1, temp_pmc);
/* Our attribute list is our parent's attribute list */
temp_pmc = pmc_new(interpreter, enum_class_PerlUndef);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
(PMC *)PMC_data(base_class), 2),
temp_pmc);
VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 2, temp_pmc);
/* And our full keyed attribute list is our parent's */
temp_pmc = pmc_new(interpreter, enum_class_PerlUndef);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
(PMC *)PMC_data(base_class), 3),
temp_pmc);
VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 3, temp_pmc);
/* Set the classname, if we have one */
classname_pmc = pmc_new(interpreter, enum_class_PerlString);
if (child_class_name) {
VTABLE_set_string_native(interpreter, classname_pmc, child_class_name);
} else {
VTABLE_set_string_native(interpreter, classname_pmc,
string_make(interpreter, "\0\0anonymous", 11, NULL, 0,
NULL));
}
VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 4, classname_pmc);
return(child_class);
}
/* Create a brand new class, named what we pass in.
*/
PMC *
Parrot_new_class(Parrot_Interp interpreter, STRING *class_name) {
PMC *new_class;
PMC *new_class_array;
PMC *classname_pmc;
PMC *temp_pmc;
new_class = pmc_new(interpreter, enum_class_ParrotClass);
new_class_array = PMC_data(new_class);
/* We have the same number of attributes as our parent */
new_class->obj.u.int_val = 0;
/* Our parent class array nothing in it */
VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 0,
pmc_new(interpreter, enum_class_Array));
VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 1,
pmc_new(interpreter, enum_class_Array));
VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 2,
pmc_new(interpreter, enum_class_PerlHash));
VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 3,
pmc_new(interpreter, enum_class_PerlHash));
/* Set the classname, if we have one */
classname_pmc = pmc_new(interpreter, enum_class_PerlString);
VTABLE_set_string_native(interpreter, classname_pmc, class_name);
VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 4, classname_pmc);
return(new_class);
}
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*
* vim: expandtab shiftwidth=4:
*/
