Author: allison
Date: Sat Apr 14 11:55:35 2007
New Revision: 18205
Added:
trunk/t/oo/metamodel.t (contents, props changed)
Modified:
trunk/MANIFEST
Log:
[oo]: Adding a stress test for the metamodel, converted from the SMOP tests.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sat Apr 14 11:55:35 2007
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Tue Apr 10 11:35:05 2007 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sat Apr 14 18:26:54 2007 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -138,6 +138,7 @@
compilers/pirc/src/pirutil.h []
compilers/pirc/src/pirvtable.c []
compilers/pirc/src/pirvtable.h []
+compilers/pirc/t/heredoc.pir []
compilers/pirc/t/macro.pir []
compilers/pirc/t/pirc.t []
compilers/pirc/t/stmts.pir []
@@ -1900,6 +1901,7 @@
languages/regex/lib/Regex/Driver.pm [regex]
languages/regex/lib/Regex/Generate.pm [regex]
languages/regex/lib/Regex/Grammar.pm [regex]
+languages/regex/lib/Regex/Grammar.yp [regex]
languages/regex/lib/Regex/Ops.pm [regex]
languages/regex/lib/Regex/Ops/List.pm [regex]
languages/regex/lib/Regex/Ops/Tree.pm [regex]
@@ -2840,6 +2842,7 @@
t/native_pbc/string_1.pbc []
t/native_pbc/string_2.pbc []
t/oo/composition.t []
+t/oo/metamodel.t []
t/oo/mro-c3.t []
t/oo/ops.t []
t/op/00ff-dos.t []
Added: trunk/t/oo/metamodel.t
==============================================================================
--- (empty file)
+++ trunk/t/oo/metamodel.t Sat Apr 14 11:55:35 2007
@@ -0,0 +1,148 @@
+#!./parrot
+# Copyright (C) 2007, The Perl Foundation.
+# $Id$
+
+=head1 NAME
+
+t/oo/metamodel.t - test the metamodel for Parrot OO
+
+=head1 SYNOPSIS
+
+ % prove t/oo/metamodel.t
+
+=head1 DESCRIPTION
+
+Tests the metamodel for the OO implementation.
+
+=cut
+
+.sub _main :main
+ load_bytecode 'library/Test/More.pir'
+
+ .local pmc exports, curr_namespace, test_namespace
+ curr_namespace = get_namespace
+ test_namespace = get_namespace [ "Test::More" ]
+ exports = split " ", "plan ok is isa_ok skip todo"
+ test_namespace.export_to(curr_namespace, exports)
+
+ plan( 11 )
+
+ .local pmc class, init_args1
+ init_args1 = new 'Hash'
+ init_args1['name'] = 'Dog'
+
+ class = new "Class", init_args1
+ isa_ok(class, "Class", "created class isa Class")
+ $S1 = class.name()
+ $I0 = iseq $S1, "Dog"
+ todo($I0, "created a new class via Class", "apparently new on Class
ignores name")
+# is($P1, "Dog", "created a new class via Class")
+ $S1 = class.name()
+ $I0 = iseq $S1, "Dog"
+ todo($I0, "Class accessor doesn't destroy value", "apparently new on Class
ignores name")
+# is($P1, "Dog", "Class accessor doesn't destroy value")
+
+ class.'add_attribute'('bark')
+ class.'add_attribute'('ear')
+ class.'add_attribute'('tail')
+ .local pmc attributes
+ attributes = class.'attributes'()
+ $I0 = exists attributes['bark']
+ ok($I0, "added attribute to the class")
+
+ $I0 = exists attributes['tail']
+ ok($I0, "added second attribute to the class")
+ unless $I0 goto no_tail_attribute
+ $P1 = attributes['tail']
+ $S1 = $P1['type']
+ $I0 = iseq $S1, 'Str'
+ todo($I0, "tail attribute has a type", "not implemented")
+# is($S1,'Str', "tail attribute has a type")
+ goto end_tail_attrib_test
+ no_tail_attribute:
+ fail("tail attribute doesn't exist")
+ end_tail_attrib_test:
+
+
+# $P0 = get_class 'Dog'
+# $I0 = issame $P0, class
+# todo($I0, "get_class can find the class", "not implemented")
+
+ $P0 = class.'new'( 'bark' => "Wooof", 'tail' => 'long' )
+ $P1 = getattribute $P0, "tail"
+ $I0 = defined $P1
+ ok($I0, "got back a tail attribute object")
+ unless $I0 goto FAILTAIL
+ is($P1, "long", "tail attribute has expected value")
+ goto NEXTTAIL
+FAILTAIL:
+ fail("no attribute")
+NEXTTAIL:
+
+ $P1 = getattribute $P0, "bark"
+ $I0 = defined $P1
+ ok($I0, "got back a bark attribute object")
+ unless $I0 goto FAIL
+ is($P1, "Wooof", "bark attribute has expected value")
+ goto NEXT
+FAIL:
+ fail("no attribute")
+NEXT:
+
+ todo(0, "new opcode makes working objects", "not implemented")
+# $P0 = new "Dog"
+# $I0 = defined $P0
+# isa_ok($P0, "Dog", "new opcode makes working objects")
+
+.end
+
+.namespace['Dog']
+
+.sub _accessor :method
+ .param string attrib
+ .param pmc value :optional
+ .param int got_value
+ unless got_value goto get_attr
+ setattribute self, attrib, value
+get_attr:
+ .local pmc rv
+ rv = getattribute self, attrib
+ .return(rv)
+.end
+
+.sub init_pmc :vtable :method
+ .param pmc init_args
+ # Iterate over the constructor arguments, calling the accessor for each
+ .local pmc iter
+ iter = new Iterator, init_args
+ iter = 0
+ iter_loop:
+ unless iter goto iter_end
+ $S1 = shift iter
+ $P1 = iter[$S1]
+ self.$S1($P1)
+ goto iter_loop
+ iter_end:
+.end
+
+.sub bark :method
+ .param pmc bark :optional
+ .param int got_bark :opt_flag
+ .local pmc rv
+ rv = self._accessor( "bark", bark, got_bark )
+ .return(rv)
+.end
+
+.sub tail :method
+ .param pmc tail :optional
+ .param int got_tail :opt_flag
+ .local pmc rv
+ rv = self._accessor( "tail", tail, got_tail )
+ .return(rv)
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
