cvsuser 04/04/03 07:59:32
Modified: docs/pdds pdd15_objects.pod
imcc pcc.c
include/parrot objects.h
ops object.ops ops.num
src objects.c
t/pmc objects.t
Log:
attribute access by name
Revision Changes Path
1.36 +6 -6 parrot/docs/pdds/pdd15_objects.pod
Index: pdd15_objects.pod
===================================================================
RCS file: /cvs/public/parrot/docs/pdds/pdd15_objects.pod,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -w -r1.35 -r1.36
--- pdd15_objects.pod 26 Mar 2004 15:01:29 -0000 1.35
+++ pdd15_objects.pod 3 Apr 2004 15:59:17 -0000 1.36
@@ -1,5 +1,5 @@
# Copyright: 2001-2004 The Perl Foundation. All Rights Reserved.
-# $Id: pdd15_objects.pod,v 1.35 2004/03/26 15:01:29 dan Exp $
+# $Id: pdd15_objects.pod,v 1.36 2004/04/03 15:59:17 leo Exp $
=head1 NAME
@@ -263,7 +263,7 @@
Returns attribute Iz of object Py and puts it in Px. Note that the
attribute number is an absolute offset.
-=item getattribute Px, Py, Sz (Unimplemented)
+=item getattribute Px, Py, Sz
Get the attribute with the fully qualified name Sz from object Py and
put it in Px.
@@ -274,7 +274,7 @@
B<actual> PMC rather than a copy, and so if the PMC's value is subsequently
changed, the value of the attribute will also change.
-=item setattribute Px, Sy, Pz (Unimplemented)
+=item setattribute Px, Sy, Pz
Set the attribute of object Px with the fully qualified name Sy to Pz
1.63 +8 -2 parrot/imcc/pcc.c
Index: pcc.c
===================================================================
RCS file: /cvs/public/parrot/imcc/pcc.c,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -w -r1.62 -r1.63
--- pcc.c 3 Apr 2004 09:25:18 -0000 1.62
+++ pcc.c 3 Apr 2004 15:59:21 -0000 1.63
@@ -780,12 +780,13 @@
int tail_call;
int proto;
int meth_call = 0;
- SymReg *p2, *s0 = NULL;
+ SymReg *p1, *p2, *s0 = NULL;
/*
- * we must preserve P2 too
+ * we must preserve P1, P2
*/
reg = unit->instructions->r[1]; /* the sub we are in */
+ p1 = reg->pcc_sub->cc_sym;
p2 = reg->pcc_sub->p2_sym;
#if IMC_TRACE
@@ -963,6 +964,11 @@
ins = ins->next;
}
ins = insINS(interp, unit, ins, "restoretop", regs, 0);
+ if (p1) {
+ regs[0] = get_pasm_reg("P1");
+ regs[1] = p1;
+ ins = insINS(interp, unit, ins, "set", regs, 2);
+ }
if (p2) {
regs[0] = get_pasm_reg("P2");
regs[1] = p2;
1.23 +3 -1 parrot/include/parrot/objects.h
Index: objects.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/objects.h,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -w -r1.22 -r1.23
--- objects.h 26 Mar 2004 12:10:37 -0000 1.22
+++ objects.h 3 Apr 2004 15:59:24 -0000 1.23
@@ -1,7 +1,7 @@
/* objects.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.h,v 1.22 2004/03/26 12:10:37 leo Exp $
+ * $Id: objects.h,v 1.23 2004/04/03 15:59:24 leo Exp $
* Overview:
* Parrot class and object header stuff
* Data Structure and Algorithms:
@@ -51,6 +51,8 @@
void Parrot_note_method_offset(Parrot_Interp, UINTVAL, PMC *);
PMC *Parrot_get_attrib_by_num(Parrot_Interp, PMC *, INTVAL);
void Parrot_set_attrib_by_num(Parrot_Interp, PMC *, INTVAL, PMC *);
+PMC *Parrot_get_attrib_by_str(Parrot_Interp, PMC *, STRING*);
+void Parrot_set_attrib_by_str(Parrot_Interp, PMC *, STRING*, PMC *);
INTVAL Parrot_get_attrib_num(Parrot_Interp, PMC *, STRING *);
INTVAL Parrot_class_offset(Parrot_Interp, PMC *, STRING *);
PMC *Parrot_find_class_constructor(Parrot_Interp, STRING *, INTVAL);
1.40 +15 -0 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -w -r1.39 -r1.40
--- object.ops 1 Apr 2004 09:21:25 -0000 1.39
+++ object.ops 3 Apr 2004 15:59:26 -0000 1.40
@@ -332,7 +332,10 @@
=item B<getattribute>(out PMC, in PMC, in INT)
+=item B<getattribute>(out PMC, in PMC, in STR)
+
Get attribute number $3 from object $2 and put the result in $1.
+String attribute names have to be fully qualified.
=cut
@@ -341,14 +344,26 @@
goto NEXT();
}
+inline op getattribute(out PMC, in PMC, in STR) :object_classes {
+ $1 = Parrot_get_attrib_by_str(interpreter, $2, $3);
+ goto NEXT();
+}
+
=item B<setattribute>(in PMC, in INT, in PMC)
+=item B<setattribute>(in PMC, in STR, in PMC)
+
Set attribute $2 of object $1 to $3
=cut
inline op setattribute(in PMC, in INT, in PMC) :object_classes {
Parrot_set_attrib_by_num(interpreter, $1, $2, $3);
+ goto NEXT();
+}
+
+inline op setattribute(in PMC, in STR, in PMC) :object_classes {
+ Parrot_set_attrib_by_str(interpreter, $1, $2, $3);
goto NEXT();
}
1.34 +4 -0 parrot/ops/ops.num
Index: ops.num
===================================================================
RCS file: /cvs/public/parrot/ops/ops.num,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -w -r1.33 -r1.34
--- ops.num 1 Apr 2004 12:46:04 -0000 1.33
+++ ops.num 3 Apr 2004 15:59:26 -0000 1.34
@@ -1444,3 +1444,7 @@
mmdvtfind_p_ic_ic_ic 1417
isnull_s_ic 1418
isnull_sc_ic 1419
+getattribute_p_p_s 1420
+getattribute_p_p_sc 1421
+setattribute_p_s_p 1422
+setattribute_p_sc_p 1423
1.74 +50 -3 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -w -r1.73 -r1.74
--- objects.c 2 Apr 2004 07:50:38 -0000 1.73
+++ objects.c 3 Apr 2004 15:59:29 -0000 1.74
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.73 2004/04/02 07:50:38 leo Exp $
+$Id: objects.c,v 1.74 2004/04/03 15:59:29 leo Exp $
=head1 NAME
@@ -1014,8 +1014,43 @@
return NULL;
}
+static INTVAL
+attr_str_2_num(Parrot_Interp interpreter, PMC *object, STRING *attr)
+{
+ PMC *class;
+ PMC *attr_hash;
+ SLOTTYPE *class_array;
+ HashBucket *b;
+
+ if (!PObj_is_object_TEST(object))
+ internal_exception(INTERNAL_NOT_IMPLEMENTED,
+ "Can't set non-core object attribs yet");
+
+ class = GET_CLASS((SLOTTYPE *)PMC_data(object), object);
+ class_array = (SLOTTYPE *)PMC_data(class);
+ attr_hash = get_attrib_num(class_array, PCD_ATTRIBUTES);
+ b = hash_get_bucket(interpreter,
+ (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));
+ return 0;
+}
+
+PMC *
+Parrot_get_attrib_by_str(Parrot_Interp interpreter, PMC *object, STRING *attr)
+{
+ return Parrot_get_attrib_by_num(interpreter, object,
+ POD_FIRST_ATTRIB +
+ attr_str_2_num(interpreter, object, attr));
+}
+
void
-Parrot_set_attrib_by_num(Parrot_Interp interpreter, PMC *object, INTVAL attrib, PMC
*value) {
+Parrot_set_attrib_by_num(Parrot_Interp interpreter, PMC *object,
+ INTVAL attrib, PMC *value)
+{
SLOTTYPE *attrib_array;
if (PObj_is_object_TEST(object)) {
INTVAL attrib_count;
@@ -1027,8 +1062,20 @@
set_attrib_num(attrib_array, attrib, value);
}
else {
- internal_exception(INTERNAL_NOT_IMPLEMENTED, "Can't set non-core object
attribs yet");
+ internal_exception(INTERNAL_NOT_IMPLEMENTED,
+ "Can't set non-core object attribs yet");
}
+}
+
+void
+Parrot_set_attrib_by_str(Parrot_Interp interpreter, PMC *object,
+ STRING *attr, PMC *value)
+{
+
+ Parrot_set_attrib_by_num(interpreter, object,
+ POD_FIRST_ATTRIB +
+ attr_str_2_num(interpreter, object, attr),
+ value);
}
INTVAL
1.39 +73 -3 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -w -r1.38 -r1.39
--- objects.t 1 Apr 2004 09:21:29 -0000 1.38
+++ objects.t 3 Apr 2004 15:59:32 -0000 1.39
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.38 2004/04/01 09:21:29 leo Exp $
+# $Id: objects.t,v 1.39 2004/04/03 15:59:32 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 33;
+use Parrot::Test tests => 36;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1001,7 +1001,7 @@
CODE
/Class 'Nemo' doesn't exist/
OUTPUT
-
+# '
output_like(<<'CODE', <<'OUTPUT', "anon. subclass of non-existant class");
subclass P1, "Character"
print "Uh-oh...\n"
@@ -1009,6 +1009,7 @@
CODE
/Class 'Character' doesn't exist/
OUTPUT
+# '
output_like(<<'CODE', <<'OUTPUT', "anon. subclass classname");
newclass P0, "City"
@@ -1021,4 +1022,73 @@
/anonymous/
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "get attrib by name");
+ newclass P1, "Foo"
+ addattribute P1, "i"
+ find_type I1, "Foo"
+ new P2, I1
+ classoffset I2, P2, "Foo"
+ new P3, .PerlString
+ set P3, "ok\n"
+ setattribute P2, I2, P3
+
+ getattribute P4, P2, "Foo\x0i"
+ print P4
+ end
+CODE
+ok
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "get attrib by name subclass");
+ loadlib P10, "myops_ops"
+ newclass P0, "Bar"
+ addattribute P0, "j"
+ subclass P1, P0, "Foo"
+ addattribute P1, "i"
+ find_type I1, "Foo"
+ new P2, I1
+ classoffset I2, P2, "Foo"
+ new P3, .PerlString
+ set P3, "foo i\n"
+ setattribute P2, I2, P3
+ classoffset I2, P2, "Bar"
+ new P3, .PerlString
+ set P3, "bar j\n"
+ setattribute P2, I2, P3
+
+ getattribute P4, P2, "Foo\x0i"
+ print P4
+ getattribute P4, P2, "Bar\x0j"
+ print P4
+ end
+CODE
+foo i
+bar j
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "set attrib by name subclass");
+ loadlib P10, "myops_ops"
+ newclass P0, "Bar"
+ addattribute P0, "j"
+ subclass P1, P0, "Foo"
+ addattribute P1, "i"
+ find_type I1, "Foo"
+ new P2, I1
+ new P3, .PerlString
+ set P3, "foo i\n"
+ setattribute P2, "Foo\x0i", P3
+ new P3, .PerlString
+ set P3, "bar j\n"
+ setattribute P2, "Bar\x0j", P3
+ classoffset I2, P2, "Foo"
+ getattribute P4, P2, I2
+ print P4
+ classoffset I2, P2, "Bar"
+ getattribute P4, P2, I2
+ print P4
+ end
+CODE
+foo i
+bar j
+OUTPUT
