Get traits on variables working more along the lines of the way discu…

…ssed on #perl6 (spec will want tweaks). We now invoke the trait with a ContainerDeclarand object, which contains various information about the declaration. At the moment, we ain't applying the tratis only once ever - that will come in the future lexicals refactor.

src/classes/AttributeDeclarand.pir

@@ -11,14 +11,25 @@ describe a declaration of an attribute container in a class.
 
 =cut
 
-.namespace []
+.namespace ['AttributeDeclarand']
 
 .sub '' :anon :load :init
     .local pmc p6meta
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     p6meta.'new_class'('AttributeDeclarand', 'parent'=>'ContainerDeclarand', 'attr'=>'$!how')
 .end
 
+.sub 'new' :method
+    .param pmc container :named('container')
+    .param pmc name      :named('name')
+    .param pmc how       :named('how')
+    $P0 = new ['ContainerDeclarand']
+    setattribute $P0, '$!container', container
+    setattribute $P0, '$!name', name
+    setattribute $P0, '$!how', how
+    .return ($P0)
+.end
+
 .sub 'how' :method
     $P0 = getattribute self, '$!how'
     .return ($P0)

src/classes/ContainerDeclarand.pir

@@ -11,14 +11,23 @@ describe a declaration of a container.
 
 =cut
 
-.namespace []
+.namespace ['ContainerDeclarand']
 
 .sub '' :anon :load :init
     .local pmc p6meta
     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
     p6meta.'new_class'('ContainerDeclarand', 'parent'=>'Any', 'attr'=>'$!container $!name')
 .end
 
+.sub 'new' :method
+    .param pmc container :named('container')
+    .param pmc name      :named('name')
+    $P0 = new ['ContainerDeclarand']
+    setattribute $P0, '$!container', container
+    setattribute $P0, '$!name', name
+    .return ($P0)
+.end
+
 .sub 'container' :method
     $P0 = getattribute self, '$!container'
     .return ($P0)

src/parser/actions.pm

@@ -1818,11 +1818,18 @@ method scope_declarator($/) {
                         # We'll make a block for calling other handles, which'll be
                         # thunked.
                         my $trait_stmts := PAST::Stmts.new();
-                        emit_traits($var<traitlist>, $trait_stmts, PAST::Var.new( :name('$_'), :scope('lexical') ));
+                        emit_traits($var<traitlist>, $trait_stmts, PAST::Op.new(
+                            :pasttype('callmethod'), :name('new'),
+                            PAST::Var.new( :name('AttributeDeclarand'), :scope('package'), :namespace(list()) ),
+                            PAST::Var.new( :name('$_'), :scope('lexical'), :named('container') ),
+                            PAST::Val.new( :value($var.name()), :named('name') ),
+                            PAST::Var.new( :name('$how'), :scope('lexical'), :named('how') )
+                        ));
                         if +@($trait_stmts) > 0 {
                             my $trait_block := PAST::Block.new(
                                 :blocktype('declaration'),
                                 PAST::Var.new( :name('$_'), :scope('parameter') ),
+                                PAST::Var.new( :name('$how'), :scope('parameter') ),
                                 $trait_stmts
                             );
                             $trait_block.named('traits');
@@ -1844,15 +1851,24 @@ method scope_declarator($/) {
                             $viviself
                         )
                     ));
-                    emit_traits($var<traitlist>, $var.viviself(), $init_reg);
+
+                    # Trait and type handling.
+                    $init_reg.named('container');
+                    my $declarand := PAST::Op.new(
+                        :pasttype('callmethod'), :name('new'),
+                        PAST::Var.new( :name('ContainerDeclarand'), :scope('package'), :namespace(list()) ),
+                        $init_reg,
+                        PAST::Val.new( :value($var.name()), :named('name') )
+                    );
+                    emit_traits($var<traitlist>, $var.viviself(), $declarand);
                     if $type {
                         if $var<sigil> ne '$' && $var<sigil> ne '@' && $var<sigil> ne '%' && $var<sigil> ne '' {
                             $/.panic("Cannot handle typed variables with sigil " ~ $var<sigil>);
                         }
                         $var.viviself.push(PAST::Op.new(
                             :pasttype('call'),
                             :name('trait_mod:of'),
-                            $init_reg,
+                            $declarand,
                             $type
                         ));
                     }

src/pmc/mutablevar.pmc

@@ -49,37 +49,38 @@ pmclass MutableVAR need_ext dynpmc group perl6_group {
         PMC_data(SELF) = NULL;
     }
 
-    VTABLE PMC *find_method(STRING *method_name) {
+    VTABLE PMC* getprop(STRING *prop_name) {
         PMC *scalar;
-        PMC *mro;
-        INTVAL elements, i;
         GET_ATTR_scalar(INTERP, SELF, scalar);
+        return VTABLE_getprop(INTERP, scalar, prop_name);
+    }
+
+    METHOD INTVAL readonly() {
+        STRING *s_ro = string_from_literal(INTERP, "readonly");
+        PMC    *ro, *scalar;
+        INTVAL  res;
+
+        GET_ATTR_scalar(INTERP, SELF, scalar);
+        ro = VTABLE_getprop(INTERP, scalar, s_ro);
+        res = PMC_IS_NULL(ro) ? 0 : VTABLE_get_bool(INTERP, ro);
+        RETURN(INTVAL res);
+    }
 
-        /* We can't get Parrot do dispatch this for us as usual, because it
-         * calls VTABLE_namespace, which delegates to what the mutable
-         * contains. We want to call on the container. */
-        mro = scalar->vtable->mro;
-        elements = VTABLE_elements(INTERP, mro);
-        for (i = 0; i < elements; i++) {
-            PMC * const cur_class = VTABLE_get_pmc_keyed_int(INTERP, mro, i);
-            PMC * const ns        = cur_class->vtable->_namespace;
-
-            if (!PMC_IS_NULL(ns)) {
-                PMC * const method = VTABLE_get_pmc_keyed_str(interp, ns, method_name);
-                if (!PMC_IS_NULL(method)) {
-                    /* Found method. If it's an NCI, we return a BoundNCI, to
-                     * make sure we call with the scalar invocant. */
-                    return method;
-                }
-            }
-        }
-        return PMCNULL;
+    METHOD INTVAL rw() {
+        INTVAL ro, rw;
+        (INTVAL ro) = PCCINVOKE(INTERP, SELF, "readonly");
+        rw = ro ? 0 : 1;
+        RETURN (INTVAL rw);
     }
 
-    VTABLE PMC* getprop(STRING *prop_name) {
+    METHOD PMC *of(PMC *type) {
         PMC *scalar;
         GET_ATTR_scalar(INTERP, SELF, scalar);
-        return VTABLE_getprop(INTERP, scalar, prop_name);
+        if (!PMC_IS_NULL(type))
+            VTABLE_setprop(interp, scalar, CONST_STRING(interp, "type"), type);
+        else
+            type = VTABLE_getprop(interp, scalar, CONST_STRING(interp, "type"));
+        RETURN (PMC *type);
     }
 }
 

src/pmc/objectref_pmc.template

@@ -115,18 +115,4 @@ pmclass ObjectRef need_ext dynpmc group perl6_group {
     /* VTABLE PMC * setprop() */
     /* VTABLE PMC * delprop() */
     /* VTABLE PMC * getprops() */
-
-    METHOD INTVAL readonly() {
-        STRING *s_ro = string_from_literal(INTERP, "readonly");
-        PMC *ro = VTABLE_getprop(INTERP, SELF, s_ro);
-        INTVAL res =  PMC_IS_NULL(ro) ? 0 : VTABLE_get_bool(INTERP, ro);
-        RETURN(INTVAL res);
-    }
-
-    METHOD INTVAL rw() {
-        INTVAL ro, rw;
-        (INTVAL ro) = PCCINVOKE(INTERP, SELF, "readonly");
-        rw = ro ? 0 : 1;
-        RETURN (INTVAL rw);
-    }
 }

src/setting/traits.pm

@@ -126,7 +126,7 @@ multi trait_mod:<of>(ContainerDeclarand $c, Object $type is rw) {
     given $c.container {
         when Array { $_ does Positional[$type] }
         when Hash { $_ does Associative[$type] }
-        default { .of($type) }
+        default { VAR($_).of($type) }
     }
 }