Author: allison
Date: Mon Feb 5 17:49:34 2007
New Revision: 16902
Added:
trunk/compilers/smop/
trunk/compilers/smop/Attribute.pir
trunk/compilers/smop/Class.pir
trunk/compilers/smop/_accessor.pir
trunk/compilers/smop/t/
trunk/compilers/smop/t/class.t (contents, props changed)
Modified:
trunk/MANIFEST
Log:
A prototype object model for Parrot.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Mon Feb 5 17:49:34 2007
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sun Feb 4 13:42:45 2007 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Tue Feb 6 00:47:37 2007 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -120,6 +120,10 @@
compilers/pge/STATUS []
compilers/pge/demo.pir []
compilers/pge/pgc.pir []
+compilers/smop/_accessor.pir []
+compilers/smop/Attribute.pir []
+compilers/smop/Class.pir []
+compilers/smop/t/class.t []
compilers/tge/README []
compilers/tge/TGE.pir []
compilers/tge/TGE/Compiler.pir []
Added: trunk/compilers/smop/Attribute.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/smop/Attribute.pir Mon Feb 5 17:49:34 2007
@@ -0,0 +1,46 @@
+# Copyright (C) 2007, The Perl Foundation.
+
+=head1 NAME
+
+Attribute - An attribute of a class
+
+=head1 DESCRIPTION
+
+The Attribute class represents a single attribute of a class object.
+Attributes have a name, a type, and a link back to the class that
+contains them.
+
+=cut
+
+.namespace ['Attribute']
+
+.include 'compilers/smop/_accessor.pir'
+
+.sub onload :load
+ .local pmc class
+ newclass class, "Attribute"
+ addattribute class, "name"
+ addattribute class, "type"
+ addattribute class, "class"
+.end
+
+.sub name :method
+ .param pmc name :optional
+ .param int got_name :opt_flag
+ .local pmc rv
+ rv = self._accessor( "name", name, got_name )
+ .return(rv)
+.end
+
+.sub class :method
+ .param pmc class :optional
+ .param int got_class :opt_flag
+ .local pmc rv
+ rv = self._accessor( "class", class, got_class )
+ .return(rv)
+.end
+
+.sub init :vtable :method
+ $P0 = new String
+ setattribute self, "name", $P0
+.end
Added: trunk/compilers/smop/Class.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/smop/Class.pir Mon Feb 5 17:49:34 2007
@@ -0,0 +1,157 @@
+# Copyright (C) 2007, The Perl Foundation.
+
+=head1 NAME
+
+Class - Core structure of a class
+
+=head1 DESCRIPTION
+
+Classes are instances of the C<Class> PMC. Currently implemented in PIR,
+but ultimately implemented as low-level .pmc.
+
+=head2 find_class
+
+This subroutine prototypes the C<find_class> opcode. It looks up a class
+by name and returns a class object.
+
+=cut
+
+.sub find_class
+ .param pmc name
+ .local pmc class
+
+ # Currently storing the class object as a namespace variable, mimicing
+ # whatever strategy Namespace objects will use to store a link to the
+ # associated class.
+ class = find_global name, "class_object"
+ .return(class)
+.end
+
+.namespace ['Class']
+
+.sub onload :load
+ .local pmc class
+ class = newclass "Class"
+ addattribute class, "name"
+ addattribute class, "_parrotclass"
+ addattribute class, "attributes"
+ addattribute class, "methods"
+ addattribute class, "superclasses"
+.end
+
+=head2 new
+
+ .local pmc class, init_args
+ init_args = new Hash
+ init_args['name'] = 'MyClass'
+ class = new 'Class', init_args
+# class = newclass 'MyClass'
+
+=cut
+
+.sub init :vtable :method
+ $P0 = new Hash
+ setattribute self, "attributes", $P0
+ $P0 = new Hash
+ setattribute self, "methods", $P0
+ $P0 = new ResizablePMCArray
+ setattribute self, "superclasses", $P0
+.end
+
+.sub init_pmc :vtable :method
+ .param pmc init_args
+ self.init()
+
+ # 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
+
+.include "compilers/smop/_accessor.pir"
+
+.sub name :method
+ .param pmc name :optional
+ .param int got_name :opt_flag
+ .local pmc rv
+
+ rv = self._accessor( "name", name, got_name )
+
+ unless got_name goto get_only
+ store_global name, "class_object", self # namespace entry for class object
+ $P1 = newclass name
+ setattribute self, "_parrotclass", $P1 # dummy old-style class object within
+ #$P0 = get_namespace [name]
+ #$P1 = get_namespace
+ #.local pmc initpmc
+ #initpmc = get_global "_init_pmc"
+ #print "but... but... "
+ #say name
+ #print "and "
+ #say initpmc
+ #store_global name, "_init_pmc", initpmc
+ #$P0.add_sub("init_pmc", init)
+get_only:
+
+ .return(rv)
+.end
+
+.sub 'new' :method
+ .param pmc args :slurpy :named
+
+ .local pmc obj
+ .local string name
+ name = self.'name'()
+
+ $I0 = find_type name
+ obj = new $I0, args
+
+ .return(obj)
+.end
+
+
+.sub attributes :method
+ .param pmc attribs :optional
+ .param int got_attribs :opt_flag
+ .local pmc rv
+
+ unless got_attribs goto skip_set
+ .local pmc iter
+ iter = new Iterator, attribs
+ iter = 0
+iter_loop:
+ unless iter goto iter_end
+ $S1 = shift iter # NOTE: convert to hash to add attribute types
+ self.add_attribute($S1)
+ goto iter_loop
+iter_end:
+
+skip_set:
+ rv = getattribute self, 'attributes'
+ .return(rv)
+.end
+
+.sub 'add_attribute' :method
+ .param string attribute_name
+ .param pmc init_args :slurpy :named
+ .local pmc new_attribute, attributes
+ new_attribute = new 'Attribute', init_args
+ new_attribute.'name'(attribute_name)
+ new_attribute.'class'(self)
+
+ # store the attribute in the class
+ attributes = getattribute self, 'attributes'
+ attributes[attribute_name] = new_attribute
+
+ # add the attribute to the dummy internal class
+ .local pmc delegclass
+ delegclass = getattribute self, '_parrotclass'
+ addattribute delegclass, attribute_name
+.end
Added: trunk/compilers/smop/_accessor.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/smop/_accessor.pir Mon Feb 5 17:49:34 2007
@@ -0,0 +1,11 @@
+.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
Added: trunk/compilers/smop/t/class.t
==============================================================================
--- (empty file)
+++ trunk/compilers/smop/t/class.t Mon Feb 5 17:49:34 2007
@@ -0,0 +1,79 @@
+#!./parrot
+
+.macro IMPORT ( lib, subname, TEMP )
+ .TEMP = find_global .lib, .subname
+ store_global .subname, .TEMP
+.endm
+
+.sub _main :main
+ load_bytecode 'library/Test/More.pir'
+ load_bytecode 'compilers/smop/Class.pir'
+ load_bytecode 'compilers/smop/Attribute.pir'
+
+ .local pmc _
+ .IMPORT( 'Test::More', 'plan', _ )
+ .IMPORT( 'Test::More', 'ok', _ )
+ .IMPORT( 'Test::More', 'is', _ )
+
+ plan( 6 )
+
+ .local pmc class, init_args
+ init_args = new Hash
+ init_args['name'] = 'Dog'
+ class = new 'Class', init_args # equiv to newclass 'Dog'
+
+ $P1 = class.name()
+ is($P1, "Dog", "created a new Class")
+ $P1 = class.name()
+ is($P1, "Dog", "Class accessor doesn't destroy value")
+
+ class.add_attribute('bark')
+ .local pmc attributes
+ attributes = class.'attributes'()
+ $I0 = exists attributes['bark']
+ ok($I0, "added attribute to the class")
+
+
+ $P0 = find_class('Dog')
+ $I0 = issame $P0, class
+ ok($I0, "find_class can find the class")
+
+ $P0 = class.'new'( 'bark' => "Wooof" )
+ $P1 = getattribute $P0, "bark"
+ $I0 = defined $P1
+ ok($I0, "got back a bark attribute object")
+ unless $I0 goto SKIP
+ is($P1, "Wooof", "create object via Dog.new()")
+ goto NEXT
+SKIP:
+ fail("SKIP - no attribute")
+NEXT:
+
+.end
+
+.namespace['Dog']
+
+.include 'compilers/smop/_accessor.pir'
+
+.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
