develooper Front page | perl.cvs.parrot | Postings from January 2009

[svn:parrot] r35507 - in trunk/languages/perl6: config/makefiles src/builtins src/classes src/parser

From:
jonathan
Date:
January 13, 2009 13:46
Subject:
[svn:parrot] r35507 - in trunk/languages/perl6: config/makefiles src/builtins src/classes src/parser
Message ID:
20090113214648.51F8CCB9F9@x12.develooper.com
Author: jonathan
Date: Tue Jan 13 13:46:46 2009
New Revision: 35507

Modified:
   trunk/languages/perl6/config/makefiles/root.in
   trunk/languages/perl6/src/builtins/enums.pir
   trunk/languages/perl6/src/builtins/guts.pir
   trunk/languages/perl6/src/builtins/op.pir
   trunk/languages/perl6/src/classes/Code.pir
   trunk/languages/perl6/src/classes/List.pir
   trunk/languages/perl6/src/classes/Mapping.pir
   trunk/languages/perl6/src/classes/Match.pir
   trunk/languages/perl6/src/classes/Role.pir
   trunk/languages/perl6/src/classes/Signature.pir
   trunk/languages/perl6/src/parser/actions.pm
   trunk/languages/perl6/src/parser/methods.pir

Log:
[rakudo] Initial refactor of roles to work towards parametric role support. Now we have a Perl6Role object installed in the namespace. It knows how to produce a Parrot-level role when given parameters, by doing a multi-dispatch on them. There's a bunch of nasty things to make enums keep working (that code is over-ripe for a big refactor soon), plus many comments of things that remain to be done. Happily, discounting enum stuff which will shrink a lot soon, actions.pm grows little.

Modified: trunk/languages/perl6/config/makefiles/root.in
==============================================================================
--- trunk/languages/perl6/config/makefiles/root.in	(original)
+++ trunk/languages/perl6/config/makefiles/root.in	Tue Jan 13 13:46:46 2009
@@ -48,12 +48,14 @@
 
 BUILTINS_PIR = \
   src/classes/Object.pir \
+  src/classes/Any.pir \
+  src/classes/Signature.pir \
+  src/classes/Role.pir \
   src/classes/Abstraction.pir \
   src/classes/Protoobject.pir \
   src/classes/Positional.pir \
   src/classes/Associative.pir \
   src/classes/Callable.pir \
-  src/classes/Any.pir \
   src/classes/Bool.pir \
   src/classes/Str.pir \
   src/classes/Num.pir \
@@ -76,12 +78,10 @@
   src/classes/Failure.pir \
   src/classes/Exception.pir \
   src/classes/Nil.pir \
-  src/classes/Role.pir \
   src/classes/Pair.pir \
   src/classes/Whatever.pir \
   src/classes/Capture.pir \
   src/classes/Match.pir \
-  src/classes/Signature.pir \
   src/classes/Grammar.pir \
   src/classes/Module.pir \
   src/builtins/globals.pir \

Modified: trunk/languages/perl6/src/builtins/enums.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/enums.pir	(original)
+++ trunk/languages/perl6/src/builtins/enums.pir	Tue Jan 13 13:46:46 2009
@@ -11,6 +11,7 @@
     # Set up bool role.
     .local pmc bool_role
     bool_role = "!keyword_role"("bool")
+    bool_role = bool_role.'!select'()
     get_global $P21, "Object"
     "!keyword_has"(bool_role, "$!bool", $P21)
     get_global $P24, "bool_role_bool"

Modified: trunk/languages/perl6/src/builtins/guts.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/guts.pir	(original)
+++ trunk/languages/perl6/src/builtins/guts.pir	Tue Jan 13 13:46:46 2009
@@ -205,6 +205,7 @@
 
     # It's an abstraction.
     $P0 = get_hll_global 'Abstraction'
+    $P0 = $P0.'!select'()
     subset.'add_role'($P0)
 
     # Instantiate it - we'll only ever create this one instance.
@@ -355,6 +356,43 @@
 .end
 
 
+=item !ADDTOROLE
+
+Adds a given role initializing multi-variant to a Role object, creating it
+and putting it in the namespace if it doesn't already exist.
+
+=cut
+
+.sub '!ADDTOROLE'
+    .param pmc variant
+
+    # Get short name of role.
+    .local pmc ns
+    .local string short_name
+    ns = variant.'get_namespace'()
+    ns = ns.'get_name'()
+    short_name = pop ns
+    $I0 = index short_name, '['
+    if $I0 == -1 goto have_short_name
+    short_name = substr short_name, 0, $I0
+  have_short_name:
+
+    # See if we have a Role object already.
+    .local pmc role_obj
+    role_obj = get_root_global ns, short_name
+    if null role_obj goto need_role_obj
+    $I0 = isa role_obj, 'NameSpace'
+    unless $I0 goto have_role_obj
+  need_role_obj:
+    role_obj = new 'Perl6Role'
+    set_root_global ns, short_name, role_obj
+  have_role_obj:
+
+    # Add this variant.
+    role_obj.'!add_variant'(variant)
+.end
+
+
 =item !meta_create(type, name, also)
 
 Create a metaclass object for C<type> with the given C<name>.
@@ -398,15 +436,24 @@
     .return (metaclass)
 
   role:
+    # This is a little fun. We only want to create the Parrot role and suck
+    # in the methods once per role definition. We do this and it is attached to
+    # the namespace. Next time, we will find and clone it.
     .local pmc info, metarole
+    ns = get_hll_namespace nsarray
+    metarole = get_class ns
+    unless null metarole goto have_role
+
     info = new 'Hash'
     $P0 = nsarray[-1]
     info['name'] = $P0
     info['namespace'] = nsarray
     metarole = new 'Role', info
-    nsarray = clone nsarray
-    $S0 = pop nsarray
-    set_hll_global nsarray, $S0, metarole
+  
+  have_role:
+    # XXX At this point, we need to create a clone of the role, but it's a bit
+    # more special than that; we also need to clone and lexically capture the
+    # methods of the role so they will get the parameters captured.
     .return (metarole)
 .end
 
@@ -457,6 +504,7 @@
 .sub '!meta_compose' :multi()
     .param pmc metaclass
     # Currently, nothing to do.
+    .return (metaclass)
 .end
 
 
@@ -487,12 +535,16 @@
     .return ()
 
   does:
-    ##  get the role to be composed
+    ##  get the Role object for the role to be composed
     $P0 = compreg 'Perl6'
     $P0 = $P0.'parse_name'(name)
     $S0 = pop $P0
     $P0 = get_hll_global $P0, $S0
 
+    ##  select the correct role based upon any parameters
+    ##  XXX need to pass along params; for now, none.
+    $P0 = $P0.'!select'()
+
     ##  add it to the class.
     metaclass.'add_role'($P0)
 .end
@@ -751,27 +803,39 @@
 
 .sub '!keyword_role'
     .param string name
-    .local pmc info, role
+    .local pmc info, role, helper
 
-    # Need to make sure it ends up attached to the right namespace.
+    # Create Parrot-level role. Need to make sure it gets its methods from
+    # the right namespace.
     .local pmc ns
     ns = split '::', name
     name = ns[-1]
     info = new 'Hash'
     info['name'] = name
     info['namespace'] = ns
-
-    # Create role.
     role = new 'Role', info
 
-    # Stash in namespace.
-    $I0 = elements ns
-    dec $I0
-    ns = $I0
-    set_hll_global ns, name, role
-
+    # Now we need to wrap it up as a Perl6Role.
+    helper = find_name '!keyword_role_helper'
+    helper = clone helper
+    setprop helper, '$!metarole', role
+    $P0 = new ["Signature"]
+    setprop helper, '$!signature', $P0
+    role = new ["Perl6Role"]
+    role.'!add_variant'(helper)
+
+    # Store it in the namespace.
+    ns = clone ns
+    $S0 = pop ns
+    set_hll_global ns, $S0, role
     .return(role)
 .end
+.sub '!keyword_role_helper'
+    $P0 = new 'ParrotInterpreter'
+    $P0 = $P0['sub']
+    $P0 = getprop '$!metarole', $P0
+    .return ($P0)
+.end
 
 
 =item !keyword_enum(name)

Modified: trunk/languages/perl6/src/builtins/op.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/op.pir	(original)
+++ trunk/languages/perl6/src/builtins/op.pir	Tue Jan 13 13:46:46 2009
@@ -400,7 +400,7 @@
     .local pmc derived
     derived = new 'Class'
     addparent derived, parrot_class
-    $I0 = isa role, 'Role'
+    $I0 = isa role, 'Perl6Role'
     if $I0 goto one_role
     $I0 = isa role, 'List'
     if $I0 goto many_roles
@@ -408,6 +408,8 @@
     'die'("'does' expects a role or a list of roles")
 
   one_role:
+    # XXX Need to handle parameterized roles properly at some point.
+    role = role.'!select'()
     '!keyword_does'(derived, role)
     goto added_roles
 
@@ -417,8 +419,10 @@
   roles_loop:
     unless role_it goto roles_loop_end
     cur_role = shift role_it
-    $I0 = isa cur_role, 'Role'
+    $I0 = isa cur_role, 'Perl6Role'
     unless $I0 goto error
+    # XXX Need to handle parameterized roles properly at some point.
+    cur_role = cur_role.'!select'()
     '!keyword_does'(derived, cur_role)
     goto roles_loop
   roles_loop_end:
@@ -465,25 +469,17 @@
     .param int have_value :opt_flag
 
     # First off, is the role actually a role?
-    $I0 = isa role, 'Role'
+    $I0 = isa role, 'Perl6Role'
     if $I0 goto have_role
 
     # If not, it may be an enum. If we don't have a value, get the class of
     # the thing passed as a role and find out.
     if have_value goto error
-    .local pmc the_class, prop, role_list
+    .local pmc the_class
     push_eh error
     the_class = class role
-    prop = getprop 'enum', the_class
-    if null prop goto error
-    unless prop goto error
-
-    # We have an enum; get the one role of the class and set the value.
-    role_list = inspect the_class, 'roles'
-    value = role
-    role = role_list[0]
-    pop_eh
-    goto have_role
+    role = getprop 'enum', the_class
+    unless null role goto have_role
 
     # Did anything go wrong?
   error:

Modified: trunk/languages/perl6/src/classes/Code.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Code.pir	(original)
+++ trunk/languages/perl6/src/classes/Code.pir	Tue Jan 13 13:46:46 2009
@@ -18,6 +18,7 @@
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     codeproto = p6meta.'new_class'('Code', 'parent'=>'Any')
     $P0 = get_hll_global 'Callable'
+    $P0 = $P0.'!select'()
     p6meta.'add_role'($P0, 'to'=>codeproto)
     codeproto.'!IMMUTABLE'()
     p6meta.'register'('Sub', 'parent'=>codeproto, 'protoobject'=>codeproto)

Modified: trunk/languages/perl6/src/classes/List.pir
==============================================================================
--- trunk/languages/perl6/src/classes/List.pir	(original)
+++ trunk/languages/perl6/src/classes/List.pir	Tue Jan 13 13:46:46 2009
@@ -12,6 +12,7 @@
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     listproto = p6meta.'new_class'('List', 'parent'=>'ResizablePMCArray Any')
     $P0 = get_hll_global 'Positional'
+    $P0 = $P0.'!select'()
     p6meta.'add_role'($P0, 'to'=>listproto)
     p6meta.'register'('ResizablePMCArray', 'parent'=>listproto, 'protoobject'=>listproto)
 

Modified: trunk/languages/perl6/src/classes/Mapping.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Mapping.pir	(original)
+++ trunk/languages/perl6/src/classes/Mapping.pir	Tue Jan 13 13:46:46 2009
@@ -15,6 +15,7 @@
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     mappingproto = p6meta.'new_class'('Mapping', 'parent'=>'Hash Any')
     $P0 = get_hll_global 'Associative'
+    $P0 = $P0.'!select'()
     p6meta.'add_role'($P0, 'to'=>mappingproto)
     p6meta.'register'('Hash', 'parent'=>mappingproto, 'protoobject'=>mappingproto)
     $P0 = get_hll_namespace ['Mapping']

Modified: trunk/languages/perl6/src/classes/Match.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Match.pir	(original)
+++ trunk/languages/perl6/src/classes/Match.pir	Tue Jan 13 13:46:46 2009
@@ -13,8 +13,10 @@
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     matchproto = p6meta.'new_class'('Match', 'parent'=>'PGE::Match Any')
     $P0 = get_hll_global 'Positional'
+    $P0 = $P0.'!select'()
     p6meta.'add_role'($P0, 'to'=>matchproto)
     $P0 = get_hll_global 'Associative'
+    $P0 = $P0.'!select'()
     p6meta.'add_role'($P0, 'to'=>matchproto)
 .end
 

Modified: trunk/languages/perl6/src/classes/Role.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Role.pir	(original)
+++ trunk/languages/perl6/src/classes/Role.pir	Tue Jan 13 13:46:46 2009
@@ -4,19 +4,69 @@
 
 src/classes/Role.pir - methods for the Role class
 
+=head1 Description
+
+This class represents a role in Perl 6. It is not substitutable for a Parrot
+role, nor does it subclass it. Instead, it provides a way to get at a Parrot
+level role through a multiple dispatch (or perhaps from a cache). You can see
+it as a kind of "role factory", which manufactures roles of a particular
+short name for a particular set of parameters.
+
 =head1 Methods
 
 =over 4
 
 =cut
 
-.namespace ['Role']
+.namespace ['Perl6Role']
 
 .sub 'onload' :anon :init :load
     .local pmc p6meta, roleproto
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
-    roleproto = p6meta.'new_class'('Perl6Role', 'parent'=>'Role Any', 'name'=>'Role')
-    p6meta.'register'('Role', 'parent'=>roleproto, 'protoobject'=>roleproto)
+    roleproto = p6meta.'new_class'('Perl6Role', 'parent'=>'Any', 'name'=>'Role', 'attr'=>'$!selector @!created')
+.end
+
+
+=item !add_variant
+
+Adds a parameterized variant of the role.
+
+=cut
+
+.sub '!add_variant' :method
+    .param pmc variant
+    .local pmc selector
+    selector = getattribute self, '$!selector'
+    unless null selector goto have_selector
+    selector = new 'Perl6MultiSub'
+    setattribute self, '$!selector', selector
+  have_selector:
+    push selector, variant
+.end
+
+
+=item !select
+
+Selects a variant of the role to do based upon the supplied parameters.
+
+=cut
+
+.sub '!select' :method
+    .param pmc pos_args  :slurpy
+    .param pmc name_args :slurpy :named
+    
+    # XXX We need to look through the parameters we have and keep track
+    # of variants we did already initialize/parameterize with.
+    .local pmc selector, result, created_list
+    selector = getattribute self, '$!selector'
+    result = selector(pos_args :flat, name_args :flat :named)
+    created_list = getattribute self, '@!created'
+    unless null created_list goto got_created_list
+    created_list = new 'ResizablePMCArray'
+    setattribute self, '@!created', created_list
+  got_created_list:
+    push created_list, result
+    .return (result)
 .end
 
 
@@ -36,7 +86,19 @@
     topic = topic.'WHAT'()
   no_proto:
 
-    $I0 = does topic, self
+    # Now go over the roles we've created and see if one of them is done.
+    .local pmc created, it
+    created = getattribute self, '@!created'
+    if null created goto it_loop_end
+    it = iter created
+    $I0 = 0
+  it_loop:
+    unless it goto it_loop_end
+    $P0 = shift it
+    $I0 = does topic, $P0
+    if $I0 == 0 goto it_loop
+  it_loop_end:
+
     $P0 = 'prefix:?'($I0)
     .return ($P0)
 .end

Modified: trunk/languages/perl6/src/classes/Signature.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Signature.pir	(original)
+++ trunk/languages/perl6/src/classes/Signature.pir	Tue Jan 13 13:46:46 2009
@@ -154,7 +154,7 @@
 .sub 'params' :method
     $P0 = getattribute self, "@!params"
     unless null $P0 goto done
-    $P0 = 'list'()
+    $P0 = new 'ResizablePMCArray'
     setattribute self, "@!params", $P0
   done:
     .return ($P0)

Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm	(original)
+++ trunk/languages/perl6/src/parser/actions.pm	Tue Jan 13 13:46:46 2009
@@ -600,16 +600,20 @@
                 ),
                 PAST::Op.new(
                     :pasttype('call'),
-                    :name('!keyword_role'),
+                   :name('!keyword_role'),
                     PAST::Val.new( :value($name) )
                 )
             ),
             PAST::Op.new(
                 :pasttype('call'),
                 :name('!keyword_has'),
-                PAST::Var.new(
-                    :name('def'),
-                    :scope('register')
+                PAST::Op.new(
+                    :pasttype('callmethod'),
+                    :name('!select'),
+                    PAST::Var.new(
+                        :name('def'),
+                        :scope('register')
+                    )
                 ),
                 PAST::Val.new( :value("$!" ~ $name) ),
                 # XXX Set declared type here, when we parse that.
@@ -621,9 +625,13 @@
             PAST::Op.new(
                 :pasttype('callmethod'),
                 :name('add_method'),
-                PAST::Var.new(
-                    :name('def'),
-                    :scope('register')
+                PAST::Op.new(
+                    :pasttype('callmethod'),
+                    :name('!select'),
+                    PAST::Var.new(
+                        :name('def'),
+                        :scope('register')
+                    )
                 ),
                 PAST::Val.new( :value($name) ),
                 make_accessor($/, undef, "$!" ~ $name, 1, 'attribute')
@@ -634,9 +642,13 @@
             $role_past.push(PAST::Op.new(
                 :pasttype('callmethod'),
                 :name('add_method'),
-                PAST::Var.new(
-                    :name('def'),
-                    :scope('register')
+                PAST::Op.new(
+                    :pasttype('callmethod'),
+                    :name('!select'),
+                    PAST::Var.new(
+                        :name('def'),
+                        :scope('register')
+                    )
                 ),
                 PAST::Val.new( :value($_) ),
                 PAST::Block.new(
@@ -664,28 +676,32 @@
             PAST::Op.new(
                 :pasttype('bind'),
                 PAST::Var.new(
-                    :name('def'),
+                    :name('class_def'),
                     :scope('register'),
                     :isdecl(1)
                 ),
                 PAST::Op.new(
                     :pasttype('call'),
                     :name('!keyword_enum'),
-                    PAST::Var.new(
-                        :name('def'),
-                        :scope('register')
+                    PAST::Op.new(
+                        :pasttype('callmethod'),
+                        :name('!select'),
+                        PAST::Var.new(
+                            :name('def'),
+                            :scope('register')
+                        )
                     )
                 )
             ),
             PAST::Op.new(
                 :inline('    setprop %0, "enum", %1'),
                 PAST::Var.new(
-                    :name('def'),
+                    :name('class_def'),
                     :scope('register')
                 ),
-                PAST::Val.new(
-                    :value(1),
-                    :returns('Int')
+                PAST::Var.new(
+                    :name('def'),
+                    :scope('register')
                 )
             )
         );
@@ -698,7 +714,7 @@
             :name('add_vtable_override'),
             PAST::Var.new(
                 :scope('register'),
-                :name('def')
+                :name('class_def')
             ),
             'invoke',
             PAST::Block.new(
@@ -715,7 +731,7 @@
             :name('add_vtable_override'),
             PAST::Var.new(
                 :scope('register'),
-                :name('def')
+                :name('class_def')
             ),
             'get_string',
             PAST::Block.new(
@@ -736,7 +752,7 @@
             :name('add_vtable_override'),
             PAST::Var.new(
                 :scope('register'),
-                :name('def')
+                :name('class_def')
             ),
             'get_integer',
             PAST::Block.new(
@@ -757,7 +773,7 @@
             :name('add_vtable_override'),
             PAST::Var.new(
                 :scope('register'),
-                :name('def')
+                :name('class_def')
             ),
             'get_number',
             PAST::Block.new(
@@ -792,7 +808,7 @@
                     :pasttype('callmethod'),
                     :name('new'),
                     PAST::Var.new(
-                        :name('def'),
+                        :name('class_def'),
                         :scope('register')
                     ),
                     PAST::Val.new(
@@ -1425,11 +1441,29 @@
     # See note at top of file for %?CLASSMAP.
     if %?CLASSMAP{$modulename} { $modulename := %?CLASSMAP{$modulename}; }
 
-    if ($modulename) {
-        $block.namespace( Perl6::Compiler.parse_name($modulename) );
-    }
+    if $?PKGDECL eq 'role' {
+        # Parametric roles need to have their bodies evaluated per type-
+        # parmeterization, and are "invoked" by 'does'. We make them
+        # multis, and ensure they have a signature. XXX Need to put
+        # $?CLASS as first item in signature always too.
+        $block.blocktype('declaration');
 
-    if $key eq 'block' {
+        # Also need to put this (possibly parameterized) role into the
+        # set of possible roles.
+        $block.loadinit().push(
+            PAST::Op.new( :name('!ADDTOROLE'), :pasttype('call'),
+                PAST::Var.new( :name('block'), :scope('register') )
+            )
+        );
+
+        # And if there's no signature, make sure we set one up and add [] to
+        # the namespace name.
+        if $modulename eq ~$<module_name>[0]<name> {
+            $modulename := $modulename ~ '[]';
+            block_signature($block);
+        }
+    }
+    elsif $key eq 'block' {
         # A normal block acts like a BEGIN and is executed ASAP.
         $block.blocktype('declaration');
         $block.pirflags(':load :init');
@@ -1442,6 +1476,10 @@
         $block.blocktype('immediate');
     }
 
+    if ($modulename) {
+        $block.namespace( Perl6::Compiler.parse_name($modulename) );
+    }
+
     #  Create a node at the beginning of the block's initializer
     #  for package initializations
     my $init := PAST::Stmts.new();
@@ -1485,17 +1523,21 @@
     #  ...and at the end of the block's initializer (after any other
     #  items added by the block), we finalize the composition. This
     # returns a proto, which we need to keep around and also return at
-    # the end of initialization for anonymous classes.
-    if $<module_name> eq "" && ($?PKGDECL eq 'class' || $?PKGDECL eq 'role'
-            || $?PKGDECL eq 'grammar') {
+    # the end of initialization for anonymous classes. We always need to
+    # return it for roles, since we do a role by invoking the multi-sub
+    # it produces (but those don't want to be immediate).
+    if $<module_name> eq "" && ($?PKGDECL eq 'class' || $?PKGDECL eq 'grammar')
+            || $?PKGDECL eq 'role' {
         $block[0].push(PAST::Op.new(
             :pasttype('bind'),
             PAST::Var.new(:name('proto_store'), :scope('register'), :isdecl(1)),
             PAST::Op.new( :name('!meta_compose'), $?METACLASS)
         ));
         $block.push(PAST::Var.new(:name('proto_store'), :scope('register')));
-        $block.blocktype('immediate');
-        $block.pirflags('');
+        if $?PKGDECL ne 'role' {
+            $block.blocktype('immediate');
+            $block.pirflags('');
+        }
     }
     else {
         $block[0].push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) );

Modified: trunk/languages/perl6/src/parser/methods.pir
==============================================================================
--- trunk/languages/perl6/src/parser/methods.pir	(original)
+++ trunk/languages/perl6/src/parser/methods.pir	Tue Jan 13 13:46:46 2009
@@ -101,7 +101,7 @@
     # XXX The following should be covered by a check for does Abstraction
     $I0 = isa check_symbol, 'P6protoobject'
     if $I0 goto type_ok
-    $I0 = isa check_symbol, 'Role'
+    $I0 = isa check_symbol, 'Perl6Role'
     if $I0 goto type_ok
     $P0 = class check_symbol
     $P0 = getprop 'enum', $P0



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About