Author: pmichaud
Date: Sat May 17 22:50:46 2008
New Revision: 27613
Modified:
branches/p6object/runtime/parrot/library/P6object.pir
branches/p6object/t/library/p6object.t
Log:
[p6object]:
* Make :name option work for registering classes.
Modified: branches/p6object/runtime/parrot/library/P6object.pir
==============================================================================
--- branches/p6object/runtime/parrot/library/P6object.pir (original)
+++ branches/p6object/runtime/parrot/library/P6object.pir Sat May 17
22:50:46 2008
@@ -164,6 +164,11 @@
of C<parrotclass>, or by individually composing C<P6object>'s methods
into C<parrotclass>.
+The C<name> parameter causes objects to be registered using a name
+that differs from the parrotclass name. This is useful when needing
+to map to a class name that already exists in Parrot (e.g., 'Hash'
+or 'Object').
+
=cut
.sub 'register' :method
@@ -207,14 +212,19 @@
p6object_done:
## determine parrotclass' canonical p6-name
+ .local string name
.local pmc ns
- $S0 = parrotclass
+ name = options['name']
+ if name goto have_name
+ ## use the name of parrotclass if :name not supplied
+ name = parrotclass
+ have_name:
## Parrot joins namespaces with ';'
- ns = split ';', $S0
+ ns = split ';', name
$I0 = elements ns
if $I0 > 1 goto have_ns
## but perhaps it's a (legacy) ::-delimited name instead
- ns = split '::', $S0
+ ns = split '::', name
have_ns:
## get the metaclass (how) from :protoobject, or create one
@@ -288,7 +298,6 @@
.param string name
.param pmc options :slurpy :named
- trace 1
.local pmc parentclass, parrotclass
parentclass = options['parent']
if null parentclass goto parent_p6object
@@ -317,7 +326,6 @@
parent_p6object:
parrotclass = subclass 'P6object', name
have_parrotclass:
- trace 0
.local pmc attrlist
attrlist = options['attr']
@@ -336,7 +344,7 @@
goto iter_loop
iter_end:
attr_done:
- .return self.'register'(parrotclass)
+ .return self.'register'(parrotclass, options :named :flat)
.end
Modified: branches/p6object/t/library/p6object.t
==============================================================================
--- branches/p6object/t/library/p6object.t (original)
+++ branches/p6object/t/library/p6object.t Sat May 17 22:50:46 2008
@@ -26,7 +26,7 @@
## set our plan
.local int plan_tests
- plan(80)
+ plan(87)
## make sure we can load the P6object library
push_eh load_failed
@@ -246,6 +246,24 @@
$I0 = isa mno, 'P6protoobject'
nok($I0, 'MNO object not isa P6protoobject')
+ ## use the :name option to set a class name
+ .local pmc p6objproto, p6obj
+ metaproto.'new_class'('Perl6Object', 'name'=>'Object')
+ p6objproto = get_hll_global 'Object'
+ isa_ok(p6objproto, 'Perl6Object', 'Object proto')
+ isa_ok(p6objproto, 'P6object', 'Object proto')
+ isa_ok(p6objproto, 'P6protoobject', 'Object proto')
+ $S0 = p6objproto
+ is($S0, 'Object', 'Object.WHAT eq "Object"')
+ $P0 = get_hll_global 'Perl6Object'
+ $I0 = isa $P0, 'P6protoobject'
+ nok($I0, "Didn't store proto into Perl6Object")
+ p6obj = p6objproto.'new'()
+ isa_ok(p6obj, 'Perl6Object', 'Object instance')
+ $P0 = p6obj.'WHAT'()
+ $I0 = issame $P0, p6objproto
+ ok($I0, 'obj.WHAT =:= Object.WHAT')
+
.return ()
load_failed:
ok(0, "load_bytecode 'P6object.pir' failed -- skipping tests")
