Author: allison
Date: Thu Oct 4 01:24:44 2007
New Revision: 21818
Removed:
branches/pdd15oo/t/pdd15oo/objects.t
Modified:
branches/pdd15oo/t/pmc/objects.t
Log:
[pdd15oo] Rolling objects.t back into core tests, all passing now.
Modified: branches/pdd15oo/t/pmc/objects.t
==============================================================================
--- branches/pdd15oo/t/pmc/objects.t (original)
+++ branches/pdd15oo/t/pmc/objects.t Thu Oct 4 01:24:44 2007
@@ -6,7 +6,7 @@
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 80;
+use Parrot::Test tests => 72;
=head1 NAME
@@ -101,19 +101,19 @@
new
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "classname" );
+pasm_output_is( <<'CODE', <<'OUTPUT', "get classname from class" );
newclass P1, "Foo"
- classname S0, P1
+ set S0, P1
print S0
print "\n"
subclass P2, P1, "Bar"
- classname S1, P2
+ set S1, P2
print S1
print "\n"
subclass P3, "Foo", "Baz"
- classname S2, P3
+ set S2, P3
print S2
print "\n"
end
@@ -123,25 +123,30 @@
Baz
OUTPUT
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "getclass" );
+pasm_output_is( <<'CODE', <<'OUTPUT', "get_class" );
newclass P1, "Foo"
- getclass P2, "Foo"
- classname S2, P2
+ get_class P2, "Foo"
+ set S2, P2
print S2
print "\n"
subclass P3, P1, "FooBar"
- getclass P4, "FooBar"
- classname S4, P4
+ get_class P4, "FooBar"
+ set S4, P4
print S4
print "\n"
- getclass P3, "NoSuch"
+ get_class P3, "NoSuch"
+ if_null P3, is_null
+ print "error, returned non-null value for 'NoSuch'\n"
+ end
+ is_null:
+ print "returned null, no class for 'NoSuch'\n"
end
CODE
-/Foo
+Foo
FooBar
-Class 'NoSuch' doesn't exist/
+returned null, no class for 'NoSuch'
OUTPUT
# ' for vim
@@ -226,39 +231,35 @@
pasm_output_is( <<'CODE', <<'OUTPUT', "new object - type, isa" );
newclass P1, "Foo"
- new P2, "Foo"
+ new P2, P1
print "ok 1\n"
- typeof I1, P2
- eq I0, I1, ok2
+ isa I0, P2, "Foo"
+ if I0, ok2
print "not "
ok2:
print "ok 2\n"
- isa I3, P2, "Foo"
- print I3
- print "\n"
end
CODE
ok 1
ok 2
-1
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "new object - classname" );
newclass P1, "Foo"
- new P2, "Foo"
- classname S0, P1 # class
+ new P2, P1
+ set S0, P1 # class
print S0
print "\n"
- classname S0, P2 # object
+ typeof S0, P2 # object
print S0
print "\n"
class P3, P1
- classname S0, P1 # class
+ set S0, P1 # class
print S0
print "\n"
class P3, P1
- classname S0, P2 # object
+ typeof S0, P2 # object
print S0
print "\n"
end
@@ -287,12 +288,12 @@
print "not "
ok3:
print "ok 3\n"
- isa I0, P2, "ParrotClass"
+ isa I0, P2, "Class"
if I0, ok4
print "not "
ok4:
print "ok 4\n"
- isa I0, P2, "ParrotObject"
+ isa I0, P2, "Object"
unless I0, ok5
print "not "
ok5:
@@ -306,11 +307,12 @@
ok 5
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "isa subclass - objects" );
+pir_output_is( <<'CODE', <<'OUTPUT', "isa subclass - objects" );
+.sub 'main' :main
newclass P3, "Foo"
subclass P4, P3, "Bar"
- new P1, "Foo"
- new P2, "Bar"
+ P1 = P3.'new'()
+ P2 = P4.'new'()
isa I0, P1, "Foo"
if I0, ok1
@@ -327,17 +329,17 @@
print "not "
ok3:
print "ok 3\n"
- isa I0, P2, "ParrotObject"
+ isa I0, P2, "Object"
if I0, ok4
print "not "
ok4:
print "ok 4\n"
- isa I0, P2, "ParrotClass"
+ isa I0, P2, "Class"
if I0, ok5
print "not "
ok5:
print "ok 5\n"
- end
+.end
CODE
ok 1
ok 2
@@ -352,7 +354,7 @@
addattribute P1, "foo_i"
print "ok 1\n"
# Check that P1 is still the same ParrotClass PMC
- classname S0, P1
+ set S0, P1
eq S0, "Foo", ok2
print "not "
ok2:
@@ -395,27 +397,23 @@
addattribute P2, "k"
print "ok 1\n"
.local pmc o
- o = new 'Bar'
- $I0 = classoffset o, 'Foo'
- $P0 = getattribute o, $I0
+ o = P2.'new'()
+ $P0 = getattribute o, 'i'
print $P0
print ' '
- inc $I0
- $P0 = getattribute o, $I0
+ $P0 = getattribute o, ['Foo'], 'j'
print $P0
print ' '
- $I0 = classoffset o, 'Bar'
- $P0 = getattribute o, $I0
+ $P0 = getattribute o, ['Bar'], 'j'
print $P0
print ' '
- inc $I0
- $P0 = getattribute o, $I0
+ $P0 = getattribute o, 'k'
print $P0
print_newline
$P0 = getattribute o, 'i'
print $P0
print ' '
- $P0 = getattribute o, "Foo\0j"
+ $P0 = getattribute o, ['Foo'], "j"
print $P0
print ' '
$P0 = getattribute o, 'j'
@@ -429,16 +427,16 @@
.sub init :vtable :method
$P0 = new 'String'
$P0 = 'Foo.i'
- setattribute self, "Foo\0i", $P0
+ setattribute self, ['Foo'], "i", $P0
$P0 = new 'String'
$P0 = 'Foo.j'
- setattribute self, "Foo\0j", $P0
+ setattribute self, ["Foo"], "j", $P0
$P0 = new 'String'
$P0 = 'Bar.j'
- setattribute self, "Bar\0j", $P0
+ setattribute self, ["Bar"], "j", $P0
$P0 = new 'String'
$P0 = 'Bar.k'
- setattribute self, "Bar\0k", $P0
+ setattribute self, ["Bar"], "k", $P0
.end
CODE
ok 1
@@ -446,84 +444,17 @@
Foo.i Foo.j Bar.j Bar.k
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "addmethod" );
-
-.sub main :main
-
- newclass $P0, 'Foo'
- $P2 = get_global 'sayFoo'
-
- # add a method BEFORE creating a Foo object
- addmethod $P0, 'foo', $P2
- $P1 = new 'Foo'
- $P1.'foo'()
-
- # get a method from some other namespace
- $P2 = get_global ['Bar'], 'sayBar'
-
- # add a method AFTER creating the object
- addmethod $P0, 'bar', $P2
- $P1.'bar'()
-.end
-
-.sub sayFoo
- print "foo\n"
-.end
-
-.namespace ['Bar']
-
-.sub sayBar
- print "bar\n"
-.end
-
-CODE
-foo
-bar
-OUTPUT
-
-pasm_output_like( <<'CODE', <<'OUTPUT', "classoffset: normal operation" );
- newclass P1, "Foo"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
- print I1
- end
-CODE
-/\d+/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "classoffset: invalid parent
class" );
- newclass P1, "Foo"
- new P2, "Foo"
- classoffset I1, P2, "Bar"
- print I1
- end
-CODE
-/Class not parent of object/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "classoffset: non-object
argument" );
- newclass P1, "Foo"
- find_type I0, "Foo"
- new P2, 'Undef'
- classoffset I1, P2, "Foo"
- print I1
- end
-CODE
-/Not an object/
-OUTPUT
-
pasm_output_is( <<'CODE', <<'OUTPUT', "set/get object attribs" );
newclass P1, "Foo"
addattribute P1, "i"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
+ new P2, P1
new P3, 'Integer'
set P3, 1024
- setattribute P2, I1, P3
+ setattribute P2, "i", P3
new P4, 'Integer'
- getattribute P4, P2, I1
+ getattribute P4, P2, "i"
print P4
print "\n"
end
@@ -535,22 +466,20 @@
newclass P1, "Foo"
addattribute P1, "i"
addattribute P1, "j"
- P2 = new "Foo"
- classoffset I1, P2, "Foo"
+ new P2, "Foo"
new P3, 'Integer'
set P3, 4201
new P4, 'Hash'
set P4["Key"], "Value"
- setattribute P2, I1, P3
- add I2, I1, 1
- setattribute P2, I2, P4
+ setattribute P2, "i", P3
+ setattribute P2, "j", P4
- getattribute P5, P2, I1
+ getattribute P5, P2, "i"
print P5
print "\n"
- getattribute P6, P2, I2
+ getattribute P6, P2, "j"
set S0, P6["Key"]
print S0
print "\n"
@@ -562,11 +491,10 @@
pasm_error_output_like( <<'CODE', <<'OUTPUT', "setting non-existent attribute"
);
newclass P1, "Foo"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
+ new P2, P1
new P3, 'Integer'
- setattribute P2, I1, P3
+ setattribute P2, "bar", P3
end
CODE
/No such attribute/
@@ -574,48 +502,35 @@
pasm_error_output_like( <<'CODE', <<'OUTPUT', "setting non-existent by name" );
newclass P1, "Foo"
- new P2, "Foo"
+ new P2, P1
new P3, 'Integer'
- setattribute P2, "Foo\0no_such", P3
+ setattribute P2, ["Foo"], "no_such", P3
end
CODE
-/No such attribute 'Foo\\0no_such'/
+/No such attribute 'no_such' in class 'Foo'/
OUTPUT
+#XXX
pasm_error_output_like( <<'CODE', <<'OUTPUT', "getting NULL attribute" );
newclass P1, "Foo"
addattribute P1, "i"
new P2, "Foo"
- getattribute P3, P2, "Foo\0i"
+ getattribute P3, P2, "i"
print P3
end
CODE
/Null PMC access/
OUTPUT
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "setting non-existent attribute
- 1" );
- newclass P1, "Foo"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
-
- new P3, 'Integer'
- dec I1
- setattribute P2, I1, P3
- end
-CODE
-/No such attribute/
-OUTPUT
-
-pasm_error_output_like( <<'CODE', <<'OUTPUT', "getting non-existent attribute"
);
+pir_error_output_like( <<'CODE', <<'OUTPUT', "getting non-existent attribute"
);
+.sub 'main' :main
newclass P1, "Foo"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
- add I2, I1, 6
+ P2 = P1.'new'()
- getattribute P3, P2, I2
- end
+ getattribute P3, P2, "bar"
+.end
CODE
/No such attribute/
OUTPUT
@@ -623,22 +538,20 @@
pasm_output_is( <<'CODE', <<'OUTPUT', "attribute values are specific to
objects" );
newclass P1, "Foo"
addattribute P1, "i"
- new P2, "Foo"
- classoffset I1, P2, "Foo"
- new P3, "Foo"
- classoffset I2, P3, "Foo"
+ new P2, P1
+ new P3, P1
new P4, 'Integer'
set P4, 100
- setattribute P2, I1, P4
+ setattribute P2, "i", P4
new P5, 'String'
set P5, "One hundred"
- setattribute P3, I2, P5
+ setattribute P3, "i", P5
- getattribute P6, P2, I1
+ getattribute P6, P2, "i"
print P6
print "\n"
- getattribute P6, P3, I2
+ getattribute P6, P3, "i"
print P6
print "\n"
end
@@ -656,35 +569,31 @@
addattribute P2, "l"
new P2, "Bar"
- classoffset I1, P2, "Foo"
new P3, "Bar"
- classoffset I3, P3, "Foo"
# Note that setattribute holds the actual PMC, not a copy, so
# in this test both attributes get the PMC from P4, and should
# both have the same value, despite the C<inc>.
new P4, 'Integer'
set P4, 10
- setattribute P2, I1, P4
+ setattribute P2, "i", P4
inc P4
- add I2, I1, 1
- setattribute P2, I2, P4
+ setattribute P2, "j", P4
new P5, 'Integer'
set P5, 100
- setattribute P3, I3, P5
+ setattribute P3, "i", P5
inc P5
- add I4, I3, 1
- setattribute P3, I4, P5
+ setattribute P3, "j", P5
- getattribute P6, P2, I1
+ getattribute P6, P2, "i"
bsr l1
- getattribute P6, P2, I2
+ getattribute P6, P2, "j"
bsr l1
- getattribute P6, P3, I3
+ getattribute P6, P3, "i"
bsr l1
- getattribute P6, P3, I4
+ getattribute P6, P3, "j"
bsr l1
branch end
l1:
@@ -719,75 +628,60 @@
# instantiate a Bar object
new P3, "Bar"
- classoffset I3, P3, "Foo" # The parent class
# print I3 # don't assume anything about this offset
# print "\n" # ' for vim
- set I0, I3 # access Foo attribs, remember offset
-
new P10, 'String' # set attribute values
set P10, "i\n" # attribute slots have reference semantics
- setattribute P3, I0, P10 # so always put new PMCs in
+ setattribute P3, ".i", P10 # so always put new PMCs in
# if you have unique values
- inc I0 # next attribute
new P10, 'String'
set P10, "j\n"
- setattribute P3, I0, P10
-
- classoffset I4, P3, "Bar" # set Bar attribs
- set I1, I4 # dup offset for retrieval again
+ setattribute P3, ".j", P10
new P10, 'String'
set P10, "k\n"
- setattribute P3, I1, P10
- inc I1
+ setattribute P3, ".k", P10
new P10, 'String'
set P10, "l\n"
- setattribute P3, I1, P10
+ setattribute P3, ".l", P10
- getattribute P11, P3, I3 # retrieve attribs
+ getattribute P11, P3, ".i" # retrieve attribs
print P11
- inc I3
- getattribute P11, P3, I3
+ getattribute P11, P3, ".j"
print P11
- getattribute P11, P3, I4
+ getattribute P11, P3, ".k"
print P11
- inc I4
- getattribute P11, P3, I4
+ getattribute P11, P3, ".l"
print P11
- classname S0, P3 # verify classname is still ok
- print S0
- print "\n"
end
CODE
i
j
k
l
-Bar
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "attribute values, subclassing access
meths " );
newclass P1, "Foo"
# must add attributes before object instantiation
- addattribute P1, ".i"
- addattribute P1, ".j"
+ addattribute P1, "i"
+ addattribute P1, "j"
# define attrib access functions in Foo namespace
find_global P5, "Foo::set"
- store_global "Foo", "Foo::set", P5
+ addmethod P1, "Foo::set", P5
find_global P5, "Foo::get"
- store_global "Foo", "Foo::get", P5
-
+ addmethod P1, "Foo::get", P5
subclass P2, P1, "Bar"
- addattribute P2, ".k"
- addattribute P2, ".l"
+ addattribute P2, "k"
+ addattribute P2, "l"
find_global P5, "Bar::set"
- store_global "Bar", "Bar::set", P5
+ addmethod P2, "Bar::set", P5
find_global P5, "Bar::get"
- store_global "Bar", "Bar::get", P5
+ addmethod P2, "Bar::get", P5
# instantiate a Bar object
new P13, "Bar"
@@ -795,45 +689,45 @@
# Foo and Bar have attribute accessor methods
new P5, 'String' # set attribute values
set P5, "i\n" # attribute slots have reference semantics
- set_args "0,0", P5, 0
+ set_args "0,0", P5, "i"
get_results ""
callmethodcc P13, "Foo::set"
new P5, 'String'
set P5, "j\n"
- set_args "0,0", P5, 1
+ set_args "0,0", P5, "j"
get_results ""
callmethodcc P13,"Foo::set"
new P5, 'String'
set P5, "k\n"
- set_args "0,0", P5, 0
+ set_args "0,0", P5, "k"
get_results ""
callmethodcc P13,"Bar::set"
new P5, 'String'
set P5, "l\n"
- set_args "0,0", P5, 1
+ set_args "0,0", P5, "l"
get_results ""
callmethodcc P13,"Bar::set"
# now retrieve attributes
- set_args "0", 0
+ set_args "0", "i"
get_results "0", P5
callmethodcc P13,"Foo::get"
print P5 # return result
- set_args "0", 1
+ set_args "0", "j"
get_results "0", P5
callmethodcc P13,"Foo::get"
print P5
- set_args "0", 0
+ set_args "0", "k"
get_results "0", P5
callmethodcc P13,"Bar::get"
print P5 # return result
- set_args "0", 1
+ set_args "0", "l"
get_results "0", P5
callmethodcc P13,"Bar::get"
print P5
@@ -841,44 +735,36 @@
# set(obj: Pvalue, Iattr_idx)
.pcc_sub Foo::set:
- get_params "0,0", P5, I5
+ get_params "0,0", P5, S4
print "in Foo::set\n"
.include "interpinfo.pasm"
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
- classoffset I3, P2, "Foo"
- add I4, I3, I5
- setattribute P2, I4, P5 # so always put new PMCs in
+ setattribute P2, S4, P5 # so always put new PMCs in
set_returns ""
returncc
# Pattr = get(obj: Iattr_idx)
.pcc_sub Foo::get:
- get_params "0", I5
+ get_params "0", S4
print "in Foo::get\n"
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
- classoffset I3, P2, "Foo"
- add I4, I3, I5
- getattribute P5, P2, I4
+ getattribute P5, P2, S4
set_returns "0", P5
returncc
.pcc_sub Bar::set:
- get_params "0,0", P5, I5
+ get_params "0,0", P5, S4
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
print "in Bar::set\n"
- classoffset I3, P2, "Bar"
- add I4, I3, I5
- setattribute P2, I4, P5 # so always put new PMCs in
+ setattribute P2, S4, P5 # so always put new PMCs in
set_returns ""
returncc
.pcc_sub Bar::get:
- get_params "0", I5
+ get_params "0", S4
print "in Bar::get\n"
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
- classoffset I3, P2, "Bar"
- add I4, I3, I5
- getattribute P5, P2, I4
+ getattribute P5, P2, S4
set_returns "0", P5
returncc
CODE
@@ -899,18 +785,18 @@
pasm_output_is( <<'CODE', <<'OUTPUT', "attribute values, inherited access
meths" );
newclass P1, "Foo"
# must add attributes before object instantiation
- addattribute P1, ".i"
- addattribute P1, ".j"
+ addattribute P1, "i"
+ addattribute P1, "j"
# define attrib access functions
find_global P5, "set"
- store_global "Foo", "set", P5
+ addmethod P1, "set", P5
find_global P5, "get"
- store_global "Foo", "get", P5
+ addmethod P1, "get", P5
subclass P2, P1, "Bar"
- addattribute P2, ".k"
- addattribute P2, ".l"
- addattribute P2, ".m"
+ addattribute P2, "k"
+ addattribute P2, "l"
+ addattribute P2, "m"
# subclass is preferred for the SI case over
# newclass P2, "Bar"
@@ -924,57 +810,57 @@
# Foo and Bar have attribute accessor methods
new P5, 'String' # set attribute values
set P5, "i\n" # attribute slots have reference semantics
- set_args "0,0,0", P5, "Foo", 0
+ set_args "0,0,0", P5, "Foo", "i"
get_results ""
callmethodcc P2, "set"
new P5, 'String'
set P5, "j\n"
- set_args "0,0,0", P5, "Foo", 1
+ set_args "0,0,0", P5, "Foo", "j"
get_results ""
callmethodcc P2, "set"
new P5, 'String'
set P5, "k\n"
- set_args "0,0,0", P5, "Bar", 0
+ set_args "0,0,0", P5, "Bar", "k"
get_results ""
callmethodcc P2, "set"
new P5, 'String'
set P5, "l\n"
- set_args "0,0,0", P5, "Bar", 1
+ set_args "0,0,0", P5, "Bar", "l"
get_results ""
callmethodcc P2, "set"
new P5, 'String'
set P5, "m\n"
- set_args "0,0,0", P5, "Bar", 2
+ set_args "0,0,0", P5, "Bar", "m"
get_results ""
callmethodcc P2, "set"
# now retrieve attributes
- set_args "0,0", "Foo", 0
+ set_args "0,0", "Foo", "i"
get_results "0", P5
callmethodcc P2, "get"
print P5 # return result
- set_args "0,0", "Foo", 1
+ set_args "0,0", "Foo", "j"
get_results "0", P5
callmethodcc P2, "get"
print P5
- set_args "0,0", "Bar", 0
+ set_args "0,0", "Bar", "k"
get_results "0", P5
callmethodcc P2, "get"
print P5
- set_args "0,0", "Bar", 1
+ set_args "0,0", "Bar", "l"
get_results "0", P5
callmethodcc P2, "get"
print P5
- set_args "0,0", "Bar", 2
+ set_args "0,0", "Bar", "m"
get_results "0", P5
callmethodcc P2, "get"
print P5
@@ -983,25 +869,21 @@
# Foo provides accessor functions which Bar inherits
# they take an additional classname argument SClass
-# set(obj: Pvalue, SClass, Iattr_idx)
+# set(obj: Pvalue, SClass, Sattr)
.pcc_sub set:
.include "interpinfo.pasm"
- get_params "0,0,0", P5, S5, I5
+ get_params "0,0,0", P5, S4, S5
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
- classoffset I3, P2, S5
- add I4, I3, I5
- setattribute P2, I4, P5
+ setattribute P2, S5, P5
set_returns ""
returncc
-# Pattr = get(obj: SClass, Iattr_idx)
+# Pattr = get(obj: SClass, Sattr)
.pcc_sub get:
- get_params "0,0", S5, I5
+ get_params "0,0", S4, S5
.include "interpinfo.pasm"
interpinfo P2, .INTERPINFO_CURRENT_OBJECT
- classoffset I3, P2, S5
- add I4, I3, I5
- getattribute P5, P2, I4
+ getattribute P5, P2, S5
set_returns "0", P5
returncc
@@ -1013,79 +895,47 @@
m
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "overridden vtables" );
-.include "pmctypes.pasm"
-.include "mmd.pasm"
- newclass P1, "Foo"
- find_global P2, "set_i"
- store_global "Foo", "__set_integer_native", P2
- find_global P2, "add"
- store_global "Foo", "__add", P2
- find_type I1, "Foo"
- mmdvtregister .MMD_ADD, I1, I1, P2
- find_global P2, "get_s"
- store_global "Foo", "__get_string", P2
- # must add attributes before object instantiation
- addattribute P1, ".i"
-
- new P3, "Foo"
- set P3, 1
- new P4, I1
- set P4, 1
- new P5, I1
-
- add P5, P3, P4
- # the print below calls __get_string
- print P5
- print "\n"
- set P4, 41
- add P5, P3, P4
- print P5
- print "\n"
- end
+pir_output_is( <<'CODE', <<'OUTPUT', "PMC as classes - overridden mmd methods"
);
+.sub main :main
+ .local pmc myint
+ get_class $P0, "Integer"
+ subclass myint, $P0, "MyInt"
+ .local pmc i
+ .local pmc j
+ .local pmc k
+ $I0 = find_type "MyInt"
+ i = new $I0
+ j = new $I0
+ k = new $I0
+ i = 6
+ j = 7
+ k = i + j
+ print k
+ print "\n"
+ j = new 'Integer'
+ j = 100
+ k = i + j
+ print k
+ print "\n"
+.end
-.pcc_sub set_i:
- get_params "0,0", P2, I5
- print "in set_integer\n"
- classoffset I0, P2, "Foo"
- new P6, 'Integer'
- set P6, I5
- setattribute P2, I0, P6
- set_returns ""
- returncc
-.pcc_sub add:
- get_params "0,0,0", P5, P6, P7
- print "in add\n"
- classoffset I0, P5, "Foo"
- getattribute P10, P5, I0
- getattribute P11, P6, I0
- new P12, 'Integer'
- add P12, P10, P11
- setattribute P7, I0, P12
- set_returns "0", P7
- returncc
-.pcc_sub get_s:
- get_params "0", P2
- print "in get_string\n"
- classoffset I0, P2, "Foo"
- getattribute P10, P2, I0
- set S5, P10
- set I0, P10
- ne I0, 2, no_2
- set S5, "two"
-no_2:
- set_returns "0", S5
- returncc
+.namespace ["MyInt"]
+.sub __add :multi(MyInt, MyInt)
+ .param pmc self
+ .param pmc right
+ .param pmc dest
+ print "in add\n"
+ $P0 = getattribute self, ['Integer'], "proxy"
+ $I0 = $P0
+ $I1 = right
+ $I2 = $I0 + $I1
+ dest = $I2
+ .return(dest)
+.end
CODE
-in set_integer
-in set_integer
in add
-in get_string
-two
-in set_integer
-in add
-in get_string
-42
+13
+106
OUTPUT
# Not sure if this is right or not
@@ -1134,20 +984,18 @@
new P4, "Sun"
- classoffset I1, P4, "Star"
new P5, 'String'
set P5, "G"
- setattribute P4, I1, P5
+ setattribute P4, "Spectral Type", P5
- classoffset I2, P4, "Company"
new P6, 'String'
set P6, "$100,000,000"
- setattribute P4, I2, P6
+ setattribute P4, "Annual Profit", P6
- getattribute P7, P4, I1
+ getattribute P7, P4, "Spectral Type"
print P7
print "\n"
- getattribute P8, P4, I2
+ getattribute P8, P4, "Annual Profit"
print P8
print "\n"
end
@@ -1168,12 +1016,11 @@
addparent P2, P0
new P4, "Sun"
- classoffset I1, P4, "Astronomical Object"
new P5, 'String'
set P5, "Taurus"
- setattribute P4, I1, P5
- getattribute P6, P4, I1
+ setattribute P4, "Location", P5
+ getattribute P6, P4, "Location"
print P6
print "\n"
end
@@ -1188,7 +1035,7 @@
addparent P0, P1
end
CODE
-/Parent isn't a ParrotClass/
+/Parent isn't a Class/
OUTPUT
# '
@@ -1199,7 +1046,7 @@
addparent P0, P1
end
CODE
-/Class isn't a ParrotClass/
+/Only classes can be subclassed/
OUTPUT
# '
@@ -1209,7 +1056,8 @@
new P1, "City"
class P2, P1
- classname S0, P2
+# classname S0, P2 # deprecated
+ set S0, P2
print S0
print "\n"
end
@@ -1236,27 +1084,29 @@
# '
-pasm_output_like( <<'CODE', <<'OUTPUT', "anon. subclass classname" );
+pasm_output_is( <<'CODE', <<'OUTPUT', "anon. subclass has no name" );
newclass P0, "City"
subclass P1, P0
- classname S0, P1
+# classname S0, P1 # deprecated
+ set S0, P1
+ print "'"
print S0
+ print "'"
print "\n"
end
CODE
-/anon_\d+/
+''
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "get attrib by name" );
newclass P1, "Foo"
addattribute P1, "i"
new P2, "Foo"
- classoffset I2, P2, "Foo"
new P3, 'String'
set P3, "ok\n"
- setattribute P2, I2, P3
+ setattribute P2, "i", P3
- getattribute P4, P2, "Foo\x0i"
+ getattribute P4, P2, ["Foo"], "i"
print P4
end
CODE
@@ -1269,18 +1119,16 @@
subclass P1, P0, "Foo"
addattribute P1, "i"
new P2, "Foo"
- classoffset I2, P2, "Foo"
new P3, 'String'
set P3, "foo i\n"
- setattribute P2, I2, P3
- classoffset I2, P2, "Bar"
+ setattribute P2, "i", P3
new P3, 'String'
set P3, "bar j\n"
- setattribute P2, I2, P3
+ setattribute P2, "j", P3
- getattribute P4, P2, "Foo\x0i"
+ getattribute P4, P2, ["Foo"], "i"
print P4
- getattribute P4, P2, "Bar\x0j"
+ getattribute P4, P2, ["Bar"], "j"
print P4
end
CODE
@@ -1296,16 +1144,14 @@
new P2, "Foo"
new P3, 'String'
set P3, "foo i\n"
- setattribute P2, "Foo\x0i", P3
+ setattribute P2, ["Foo"], "i", P3
new P3, 'String'
set P3, "bar j\n"
- setattribute P2, "Bar\x0j", P3
+ setattribute P2, ["Bar"], "j", P3
- classoffset I2, P2, "Foo"
- getattribute P4, P2, I2
+ getattribute P4, P2, "i"
print P4
- classoffset I2, P2, "Bar"
- getattribute P4, P2, I2
+ getattribute P4, P2, "j"
print P4
end
CODE
@@ -1321,13 +1167,13 @@
print "never\n"
end
CODE
-/Attribute 'Foo(.*?i)?' already exists/
+/Attribute 'i' already exists/
OUTPUT
pasm_output_is( <<'CODE', <<'OUTPUT', "PMC as classes" );
- getclass P0, "Integer"
+ get_class P0, "Integer"
print "ok 1\n"
- getclass P0, "Integer"
+ get_class P0, "Integer"
print "ok 2\n"
typeof S0, P0
print S0
@@ -1336,14 +1182,14 @@
CODE
ok 1
ok 2
-Integer
+PMCProxy
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', "PMC as classes - subclass" );
.sub main :main
.local pmc MyInt
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
print "ok 2\n"
@@ -1359,7 +1205,7 @@
CODE
ok 1
ok 2
-MyInt
+Class
11
OUTPUT
@@ -1367,7 +1213,7 @@
.sub main :main
.local pmc MyInt
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
addattribute MyInt, ".i"
@@ -1386,9 +1232,10 @@
.sub main :main
.local pmc MyInt
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
+ addattribute MyInt, "intval"
print "ok 2\n"
.local pmc i
i = new "MyInt"
@@ -1404,25 +1251,25 @@
.end
.namespace ["MyInt"]
+.sub set_integer_native :vtable :method
+ .param int new_value
+ $P1 = new 'Integer'
+ $P1 = new_value
+ setattribute self, "intval", $P1
+.end
.sub get_integer :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, "intval"
$I0 = $P0
- .pcc_begin_return
- .return $I0
- .pcc_end_return
+ .return ($I0)
.end
.sub get_string :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, "intval"
$I0 = $P0
$S1 = $I0
$S0 = "MyInt("
$S0 .= $S1
$S0 .= ")"
- .pcc_begin_return
- .return $S0
- .pcc_end_return
+ .return ($S0)
.end
CODE
ok 1
@@ -1438,14 +1285,14 @@
.sub main :main
.local pmc MyInt
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
subclass MyInt, $P0, "MyInt"
.local pmc i
.local pmc j
.local pmc k
i = new "MyInt"
- j = new $I0
- k = new $I0
+ j = new "MyInt"
+ k = new "MyInt"
i = 6
j = 7
k = i * j
@@ -1459,16 +1306,12 @@
.namespace ["MyInt"]
.sub get_string :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
- $I0 = $P0
+ $I0 = self # get_integer is not overridden
$S1 = $I0
$S0 = "MyInt("
$S0 .= $S1
$S0 .= ")"
- .pcc_begin_return
- .return $S0
- .pcc_end_return
+ .return ($S0)
.end
CODE
42
@@ -1479,14 +1322,14 @@
.sub main :main
.local pmc MyInt
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
subclass MyInt, $P0, "MyInt"
.local pmc i
.local pmc j
.local pmc k
i = new "MyInt"
- j = new $I0
- k = new $I0
+ j = new "MyInt"
+ k = new "MyInt"
i = 6
j = 7
k = i + j
@@ -1505,8 +1348,7 @@
.param pmc right
.param pmc dest
print "in add\n"
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, ['Integer'], 'proxy'
$I0 = $P0
$I1 = right
$I2 = $I0 + $I1
@@ -1524,10 +1366,11 @@
.sub main :main
.local pmc MyInt
.local pmc MyInt2
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
- getclass $P1, "MyInt"
+ addattribute MyInt, 'intval'
+ get_class $P1, "MyInt"
subclass MyInt2, $P1, "MyInt2"
print "ok 2\n"
.local pmc i
@@ -1540,7 +1383,7 @@
print $I0
print "\n"
print "ok 3\n"
- i = 42 # set_integer is inherited from Integer
+ i = 42 # set_integer is overridden below
print "ok 4\n"
$I0 = i # get_integer is overridden below
print $I0
@@ -1551,26 +1394,27 @@
.end
.namespace ["MyInt"]
+.sub 'set_integer_native' :vtable :method
+ .param int val
+ $P1 = new 'Integer'
+ $P1 = val
+ setattribute self, "intval", $P1
+ .return ()
+.end
.sub get_integer :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
- .pcc_begin_return
- .return $I0
- .pcc_end_return
+ .return ($I0)
.end
.sub get_string :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
$S1 = $I0
$S0 = typeof self
$S0 .= "("
$S0 .= $S1
$S0 .= ")"
- .pcc_begin_return
- .return $S0
- .pcc_end_return
+ .return ($S0)
.end
CODE
ok 1
@@ -1587,10 +1431,11 @@
.sub main :main
.local pmc MyInt
.local pmc MyInt2
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
- getclass $P1, "MyInt"
+ addattribute MyInt, 'intval'
+ get_class $P1, "MyInt"
subclass MyInt2, $P1, "MyInt2"
print "ok 2\n"
.local pmc i
@@ -1603,7 +1448,7 @@
print $I0
print "\n"
print "ok 3\n"
- i = 42 # set_integer is inherited from Integer
+ i = 42 # set_integer is overridden below
print "ok 4\n"
$I0 = i # get_integer is overridden below
print $I0
@@ -1617,35 +1462,33 @@
# subclassing methods from MyInt is ok
# this one changes the value a bit
.sub get_integer :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
inc $I0 # <<<<<
- .pcc_begin_return
- .return $I0
- .pcc_end_return
+ .return ($I0)
.end
.namespace ["MyInt"]
+.sub 'set_integer_native' :vtable :method
+ .param int val
+ $P1 = new 'Integer'
+ $P1 = val
+ setattribute self, "intval", $P1
+ .return ()
+.end
.sub get_integer :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
- .pcc_begin_return
- .return $I0
- .pcc_end_return
+ .return ($I0)
.end
.sub get_string :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
$S1 = $I0
$S0 = typeof self
$S0 .= "("
$S0 .= $S1
$S0 .= ")"
- .pcc_begin_return
- .return $S0
- .pcc_end_return
+ .return ($S0)
.end
CODE
ok 1
@@ -1662,10 +1505,11 @@
.sub main :main
.local pmc MyInt
.local pmc MyInt2
- getclass $P0, "Integer"
+ get_class $P0, "Integer"
print "ok 1\n"
subclass MyInt, $P0, "MyInt"
- getclass $P1, "MyInt"
+ addattribute MyInt, 'intval'
+ get_class $P1, "MyInt"
subclass MyInt2, $P1, "MyInt2"
print "ok 2\n"
.local pmc i
@@ -1678,7 +1522,7 @@
print $I0
print "\n"
print "ok 3\n"
- i = 42 # set_integer is inherited from Integer
+ i = 42 # set_integer is overridden below
print "ok 4\n"
$I0 = i # get_integer is overridden below
print $I0
@@ -1690,25 +1534,27 @@
.namespace ["MyInt2"]
.sub get_integer :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
- .pcc_begin_return
- .return $I0
- .pcc_end_return
+ .return ($I0)
.end
.sub get_string :vtable :method
- $I0 = classoffset self, "MyInt"
- $P0 = getattribute self, $I0
+ $P0 = getattribute self, 'intval'
$I0 = $P0
$S1 = $I0
$S0 = typeof self
$S0 .= "("
$S0 .= $S1
$S0 .= ")"
- .pcc_begin_return
- .return $S0
- .pcc_end_return
+ .return ($S0)
+.end
+.namespace ['MyInt']
+.sub 'set_integer_native' :vtable :method
+ .param int val
+ $P1 = new 'Integer'
+ $P1 = val
+ setattribute self, "intval", $P1
+ .return ()
.end
CODE
ok 1
@@ -1720,18 +1566,18 @@
MyInt2(42)
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "subclassing ParrotClass" );
+pir_output_is( <<'CODE', <<'OUTPUT', "subclassing Class" );
.sub main :main
.local pmc cl
.local pmc parent
- parent = getclass "ParrotClass"
+ parent = get_class "Class"
cl = subclass parent, "Foo"
print "ok 1\n"
.local pmc o
o = new "Foo"
print "ok 2\n"
- $S0 = classname o
+ $S0 = typeof o
print $S0
print "\n"
.end
@@ -1741,60 +1587,6 @@
Foo
OUTPUT
-SKIP: {
- skip( "instantiate disabled", 2 );
- pasm_output_is( <<'CODE', <<'OUTPUT', "instantiate" );
- subclass P2, "Integer", "Foo"
- set I0, 0
- set I3, 1
- new P5, 'Integer'
- set P5, 42
- instantiate P1
- print P1
- print "\n"
- end
-.namespace [ "Foo" ]
-.pcc_sub __instantiate: # create object the hard way
- new P10, "Foo" # should inspect passed arguments
- classoffset I0, P10, "Foo" # better should clone the argument
- setattribute P10, I0, P5 # the first attribute is the internal __value
- set P5, P10 # set return value
- set I0, 0
- set I3, 1
- returncc
-CODE
-42
-OUTPUT
-
- pir_output_is( <<'CODE', <<'OUTPUT', "instantiate - PIR" );
-
-.sub main :main
- .local pmc cl
- cl = subclass "Integer", "Foo"
- .local pmc i
- i = cl."instantiate"(42)
- print i
- print "\n"
-.end
-
-.namespace ["Foo"]
-.sub __instantiate :method
- .param int val # in realiter check what is passed
- .local pmc obj
- obj = new "Foo"
- $I1 = classoffset obj, "Foo"
- $P0 = new 'Integer'
- $P0 = val
- setattribute obj, $I1, $P0
- .pcc_begin_return
- .return obj
- .pcc_end_return
-.end
-CODE
-42
-OUTPUT
-}
-
pir_output_is( <<'CODE', <<'OUTPUT', "namespace vs name" );
.sub main :main
.local pmc o, cl, f
@@ -1906,9 +1698,9 @@
getattribute P6, P2, "l"
bsr l1
- getattribute P6, P2, "Foo\0i"
+ getattribute P6, P2, ["Foo"], "i"
bsr l1
- getattribute P6, P2, "Bar\0k"
+ getattribute P6, P2, ["Bar"], "k"
bsr l1
branch end
l1:
@@ -1931,14 +1723,14 @@
.local pmc cl, o, h, a
cl = newclass "Foo"
addattribute cl, "a"
- o = new 'Foo'
+ o = cl.'new'()
a = getattribute o, "a"
print a
h = new 'Hash'
$P0 = new 'String'
$P0 = "ok 2\n"
h['a'] = $P0
- o = new 'Foo', h
+ o = new cl, h
a = getattribute o, "a"
print a
.end
@@ -2004,7 +1796,7 @@
.sub main :main
.local pmc cl, o
cl = newclass ['Foo';'Bar']
- o = new ['Foo';'Bar']
+ o = cl.'new'()
print "ok\n"
.end
.namespace ['Foo';'Bar']
@@ -2021,8 +1813,8 @@
.local pmc c1, c2, o1, o2
c1 = newclass ['Foo';'Bar']
c2 = newclass ['Foo';'Baz']
- o1 = new ['Foo';'Bar']
- o2 = new ['Foo';'Baz']
+ o1 = c1.'new'()
+ o2 = c2.'new'()
print "ok\n"
.end
.namespace ['Foo';'Bar']
@@ -2103,9 +1895,10 @@
pir_output_is( <<'CODE', <<'OUTPUT', "class name" );
.sub main :main
- .local pmc base, o1, o2
+ .local pmc base, o1
base = subclass 'Hash', ['Perl6'; 'PAST'; 'Node']
- $S0 = classname base
+ o1 = new base
+ $S0 = typeof o1
print $S0
print "\n"
.end
@@ -2113,12 +1906,13 @@
Perl6;PAST;Node
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "getclass" );
+pir_output_is( <<'CODE', <<'OUTPUT', "get_class" );
.sub main :main
- .local pmc base, o1, o2
+ .local pmc base, o1
base = subclass 'Hash', ['Perl6'; 'PAST'; 'Node']
- $P0 = getclass ['Perl6'; 'PAST'; 'Node']
- $S0 = classname $P0
+ $P0 = get_class ['Perl6'; 'PAST'; 'Node']
+ o1 = new $P0
+ $S0 = typeof o1
print $S0
print "\n"
.end
@@ -2148,7 +1942,7 @@
.local pmc c1, c2, o
c1 = newclass ['Foo']
c2 = newclass ['Foo';'Bar']
- o = new ['Foo';'Bar']
+ o = c2.'new'()
print "ok\n"
.end
.namespace ['Foo']
@@ -2167,7 +1961,7 @@
pir_output_is( <<'CODE', <<'OUTPUT', "vtable override once removed (#39056)" );
.sub main :main
.local pmc base
- $P0 = getclass 'Integer'
+ $P0 = get_class 'Integer'
base = subclass $P0, 'Foo' # create subclass 'Foo'
addattribute base, '@!capt'
@@ -2189,42 +1983,12 @@
ok bar
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', ":vtable fails for subclasses of core
classes - (#40626)" );
-.sub main :main
- $P0 = subclass 'Hash', 'Foo'
- $P0 = subclass 'Hash', 'Bar'
-
- $P1 = new 'Foo'
- $S1 = $P1
- say $S1
-
- $P1 = new 'Bar'
- $S1 = $P1
- say $S1
-.end
-
-.namespace [ 'Foo' ]
-
-.sub '__get_string' :method
- .return('Hello world')
-.end
-
-.namespace [ 'Bar' ]
-
-.sub 'get_string' :method :vtable
- .return('Hello world')
-.end
-CODE
-Hello world
-Hello world
-OUTPUT
-
pir_output_is( <<'CODE', <<'OUTPUT', "super __init called twice (#39081)" );
.sub main :main
$P0 = newclass 'Foo'
$P1 = subclass $P0, 'Bar'
- $P2 = new 'Bar'
+ $P2 = $P1.'new'()
.end
.namespace [ 'Foo' ]
@@ -2237,19 +2001,18 @@
foo constructor
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "Using key from classname op with new" );
+pir_output_is( <<'CODE', <<'OUTPUT', "Using class object from typeof op with
new" );
.sub main :main
$P0 = newclass [ "Monkey" ; "Banana" ]
- $P0 = new [ "Monkey" ; "Banana" ]
+ $P0 = $P0.'new'()
$P0.ook()
- $P1 = class $P0
- $P2 = classname $P0
+ $P2 = typeof $P0
$P3 = new $P2
$P3.ook()
.end
.namespace [ "Monkey" ; "Banana" ]
-.sub ook
+.sub ook :method
print "Ook!\n"
.end
CODE
