Add support for shaped arrays

CREDITS

@@ -27,6 +27,11 @@ N: Alex Elsayed
 U: eternaleye
 E: eternaleye@gmail.com
 
+N: Alex Lyon
+U: Arcterus
+E: arcterus@mail.com
+D: Shaped arrays
+
 N: Allison Randal
 D: Parrot Architect (0.4.6...)
 E: allison@parrot.org

src/Perl6/Actions.nqp

@@ -144,7 +144,13 @@ class Perl6::Actions is HLL::Actions does STDActions {
                 %info<value_type>     := $*W.find_symbol(['Mu']);
             }
             if $shape {
-                $*W.throw($/, 'X::Comp::NYI', feature => 'Shaped arrays');
+                %info<container_shape> := $shape[0].ast;
+            } else {
+                my $whatever := $*W.find_symbol(['Whatever']);
+                %info<container_shape> := QAST::Op.new(
+                    :op('callmethod'), :node($/), :name('new'), :returns($whatever),
+                    QAST::Var.new(:name('Whatever'), :scope('lexical'))
+                );
             }
         }
         elsif $sigil eq '%' {

src/Perl6/Grammar.nqp

@@ -2071,9 +2071,9 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
                             reserved => '() shape syntax in variable declarations');
                     }
                 }
-            | :dba('shape definition') '[' ~ ']' <semilist> <.NYI: "Shaped variable declarations">
+            | :dba('shape definition') '[' ~ ']' <semilist>
             | :dba('shape definition') '{' ~ '}' <semilist>
-            | <?before '<'> <postcircumfix> <.NYI: "Shaped variable declarations">
+            | <?before '<'> <postcircumfix>
             ]+
         ]**0..1
         <.ws>

src/Perl6/Metamodel/BOOTSTRAP.nqp

@@ -76,6 +76,7 @@ my stub Grammar metaclass Perl6::Metamodel::ClassHOW { ... };
 my stub Junction metaclass Perl6::Metamodel::ClassHOW { ... };
 my stub Metamodel metaclass Perl6::Metamodel::PackageHOW { ... };
 my stub ForeignCode metaclass Perl6::Metamodel::ClassHOW { ... };
+my stub Whatever metaclass Perl6::Metamodel::ClassHOW { ... };
 
 # We stick all the declarative bits inside of a BEGIN, so they get
 # serialized.
@@ -1560,10 +1561,12 @@ BEGIN {
 
     # class Array is List {
     #     has $!descriptor;
+    #     has $!shape;
     #     ...
     # }
     Array.HOW.add_parent(Array, List);
     Array.HOW.add_attribute(Array, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu), :package(Array)));
+    Array.HOW.add_attribute(Array, scalar_attr('$!shape', Mu, Array));
     Array.HOW.compose_repr(Array);
 
     # class LoL is List {
@@ -1636,6 +1639,10 @@ BEGIN {
     ForeignCode.HOW.set_invocation_attr(ForeignCode, ForeignCode, '$!do');
     ForeignCode.HOW.compose_invocation(ForeignCode);
 
+    # class Whatever { }
+    Whatever.HOW.add_parent(Whatever, Any);
+    Whatever.HOW.compose_repr(Whatever);
+
     # Set up Stash type, which is really just a hash.
     Stash.HOW.add_parent(Stash, Hash);
     Stash.HOW.compose_repr(Stash);
@@ -1672,6 +1679,7 @@ BEGIN {
     Perl6::Metamodel::ClassHOW.add_stash(Hash);
     Perl6::Metamodel::ClassHOW.add_stash(ObjAt);
     Perl6::Metamodel::ClassHOW.add_stash(ForeignCode);
+    Perl6::Metamodel::ClassHOW.add_stash(Whatever);
 
     # Default invocation behavior delegates off to postcircumfix:<( )>.
     my $invoke_forwarder :=
@@ -1762,6 +1770,7 @@ BEGIN {
     EXPORT::DEFAULT.WHO<Bool>      := Bool;
     EXPORT::DEFAULT.WHO<False>     := $false;
     EXPORT::DEFAULT.WHO<True>      := $true;
+    EXPORT::DEFAULT.WHO<Whatever>  := Whatever;
     EXPORT::DEFAULT.WHO<ContainerDescriptor> := Perl6::Metamodel::ContainerDescriptor;
     EXPORT::DEFAULT.WHO<MethodDispatcher>    := Perl6::Metamodel::MethodDispatcher;
     EXPORT::DEFAULT.WHO<MultiDispatcher>     := Perl6::Metamodel::MultiDispatcher;

src/Perl6/World.nqp

@@ -613,6 +613,17 @@ class Perl6::World is HLL::World {
             nqp::bindattr($cont, %cont_info<container_base>, '$!value',
                 %cont_info<default_value>);
         }
+        if nqp::existskey(%cont_info, 'container_shape') {
+            $block[0].push(
+                QAST::Op.new(
+                    :op('bindattr'),
+                    QAST::Var.new(:scope('lexical'), :name($name)),
+                    QAST::WVal.new(:value(%cont_info<container_base>)),
+                    QAST::SVal.new(:value('$!shape')),
+                    %cont_info<container_shape>
+                )
+            );
+        }
         self.add_object($cont);
         $block.symbol($name, :value($cont));
         self.install_package_symbol($package, $name, $cont) if $scope eq 'our';
@@ -689,6 +700,16 @@ class Perl6::World is HLL::World {
                 QAST::SVal.new( :value('$!value') ),
                 QAST::WVal.new( :value(%cont_info<default_value>) )));
         }
+
+        if nqp::existskey(%cont_info, 'container_shape') {
+            $cont_code.push(QAST::Op.new(
+                :op('bindattr'),
+                QAST::Var.new(:name($tmp), :scope('local')),
+                QAST::WVal.new(:value(%cont_info<container_base>)),
+                QAST::SVal.new(:value('$!shape')),
+                %cont_info<container_shape>
+            ));
+        }
 
         $cont_code
     }

src/core/Array.pm

@@ -3,17 +3,21 @@ my class X::Item { ... };
 class Array {
     # Has attributes and parent List declared in BOOTSTRAP.    
 
-    method new(|) { 
+    method new(:$shape = *, |) {
         my Mu $args := nqp::p6argvmarray();
         nqp::shift($args);
-        nqp::p6list($args, self.WHAT, Bool::True);
+        fail "Too many elements for this shaped array" unless nqp::istype($shape, Whatever) or nqp::elems($args) < $shape;
+        my $array := nqp::p6list($args, self.WHAT, Bool::True);
+        nqp::bindattr($array, Array, '$!shape', $shape);
+        $array;
     }
 
     multi method at_pos(Array:D: $pos) is rw {
         if nqp::isnanorinf($pos) {
             X::Item.new(aggregate => self, index => $pos).throw;
         }
         my int $p = nqp::unbox_i($pos.Int);
+        fail "Index $p is too large for this shaped array" unless nqp::istype($!shape, Whatever) or $p < $!shape;
         my Mu $items := nqp::p6listitems(self);
         # hotpath check for element existence (RT #111848)
         nqp::existspos($items, $p)
@@ -24,6 +28,7 @@ class Array {
                  -> { nqp::bindpos($items, $p, $v) } )
     }
     multi method at_pos(Array:D: int $pos) is rw {
+        fail "Index $pos is too large for this shaped array" unless nqp::istype($!shape, Whatever) or $pos < $!shape;
         my Mu $items := nqp::p6listitems(self);
         # hotpath check for element existence (RT #111848)
         nqp::existspos($items, $pos)
@@ -37,10 +42,12 @@ class Array {
     proto method bind_pos(|) { * }
     multi method bind_pos($pos is copy, Mu \bindval) is rw {
         $pos = $pos.Int;
+        fail "Index $pos is too large for this shaped array" unless nqp::istype($!shape, Whatever) or $pos < $!shape;
         self.gimme($pos + 1);
         nqp::bindpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos), bindval);
     }
     multi method bind_pos(int $pos, Mu \bindval) is rw {
+        fail "Index $pos is too large for this shaped array" unless nqp::istype($!shape, Whatever) or $pos < $!shape;
         self.gimme($pos + 1);
         nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval)
     }
@@ -57,16 +64,42 @@ class Array {
 
             # next seems unnecessary but handles an obscure
             # edge case
-            if $i == (@array - 1) {
+            #
+            # FIXME: does the shape addition work?
+            if $i == (@array - 1) and nqp::istype(@array.shape, Whatever) {
                 @array.pop;
             }
         }
-        @array.pop while ?@array && !defined @array[@array.elems - 1];
+        if nqp::istype(@array.shape, Whatever) {
+            @array.pop while ?@array && !defined @array[@array.elems - 1];
+        }
         return @result;
     }
 
     method flattens() { 1 }
 
+    method shape() { $!shape }
+
+    method pop() is rw {
+        fail 'Cannot pop from a shaped array' unless nqp::istype($!shape, Whatever);
+        nqp::findmethod(List, 'pop')(self)
+    }
+
+    multi method push(Array:D: *@values) {
+        fail 'Cannot push to a shaped array' unless nqp::istype($!shape, Whatever);
+        nqp::findmethod(List, 'push')(self, |@values)
+    }
+
+    method shift() is rw {
+        fail 'Cannot shift from a shaped array' unless nqp::istype($!shape, Whatever);
+        nqp::findmethod(List, 'shift')(self)
+    }
+
+    multi method unshift(Array:D: *@values) {
+        fail 'Cannot unshift to a shaped array' unless nqp::istype($!shape, Whatever);
+        nqp::findmethod(List, 'unshift')(self, |@values);
+    }
+
     multi method perl(Array:D \SELF:) {
         nqp::iscont(SELF)
           ?? '[' ~ self.map({.perl}).join(', ') ~ ']'
@@ -85,16 +118,20 @@ class Array {
     }
 
     method STORE_AT_POS(\pos, Mu $v is copy) is rw {
+        my $pos = nqp::unbox_i(pos);
+        fail "Index $pos is too large for this shaped array" unless nqp::istype($!shape, Whatever) or $pos < $!shape;
         nqp::findmethod(List, 'STORE_AT_POS')(self, pos, $v);
     }
 
     method STORE(|) {
         # get arguments, shift off invocant
         my $args := nqp::p6argvmarray();
         nqp::shift($args);
+        fail "Too many elements for this shaped array" unless nqp::istype($!shape, Whatever) or nqp::elems($args) < $!shape;
         # make an array from them (we can't just use ourself for this,
         # or @a = @a will go terribly wrong); make it eager
         my $list := nqp::p6list($args, Array, Mu);
+        nqp::bindattr($list, Array, '$!shape', $!shape);
         nqp::bindattr($list, List, '$!flattens', True);
         $list.eager;
         # clear our items and set our next iterator to be one over
@@ -107,23 +144,27 @@ class Array {
     my role TypedArray[::TValue] does Positional[TValue] {
         multi method at_pos($pos is copy, TValue $v? is copy) is rw {
             $pos = $pos.Int;
+            fail "Index $pos is too large for this shaped array" unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
             self.exists($pos)
               ?? nqp::atpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos))
               !! nqp::p6bindattrinvres($v, Scalar, '$!whence',
                      -> { nqp::bindpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos), $v) } )
         }
         multi method at_pos(int $pos, TValue $v? is copy) is rw {
+            fail "Index $pos is too large for this shaped array" unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
             self.exists($pos)
               ?? nqp::atpos(nqp::getattr(self, List, '$!items'), $pos)
               !! nqp::p6bindattrinvres($v, Scalar, '$!whence',
                      -> { nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, $v) } )
         }
         multi method bind_pos($pos is copy, TValue \bindval) is rw {
             $pos = $pos.Int;
+            fail "Index $pos is too large for this shaped array" unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
             self.gimme($pos + 1);
             nqp::bindpos(nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos), bindval)
         }
         multi method bind_pos(int $pos, TValue \bindval) is rw {
+            fail "Index $pos is too large for this shaped array" unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
             self.gimme($pos + 1);
             nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval)
         }

src/vm/jvm/runtime/org/perl6/rakudo/Ops.java

@@ -31,6 +31,7 @@ public final class Ops {
     public static SixModelObject ContainerDescriptor;
     public static SixModelObject False;
     public static SixModelObject True;
+    public static SixModelObject Whatever;
     public static SixModelObject AutoThreader;
     public static SixModelObject EMPTYARR;
     private static boolean initialized = false;
@@ -49,6 +50,7 @@ public final class Ops {
     private static final int HINT_LISTITER_nextiter = 1;
     private static final int HINT_LISTITER_rest = 2;
     private static final int HINT_LISTITER_list = 3;
+    private static final int HINT_ARRAY_shape = 0;
 
     public static SixModelObject p6init(ThreadContext tc) {
         if (!initialized) {
@@ -83,6 +85,7 @@ public static SixModelObject p6settypes(SixModelObject conf, ThreadContext tc) {
         ContainerDescriptor = conf.at_key_boxed(tc, "ContainerDescriptor");
         False = conf.at_key_boxed(tc, "False");
         True = conf.at_key_boxed(tc, "True");
+        Whatever = conf.at_key_boxed(tc, "Whatever");
         return conf;
     }
 
@@ -124,6 +127,9 @@ public static SixModelObject p6list(SixModelObject arr, SixModelObject type, Six
             list.bind_attribute_boxed(tc, List, "$!nextiter", HINT_LIST_nextiter,
                 p6listiter(arr, list, tc));
         list.bind_attribute_boxed(tc, List, "$!flattens", HINT_LIST_flattens, flattens);
+        if (type == Array)
+            list.bind_attribute_boxed(tc, Array, "$!shape", HINT_ARRAY_shape,
+                Whatever.st.REPR.allocate(tc, Whatever.st));
         return list;
     }
 

src/vm/parrot/guts/bind.c

@@ -27,6 +27,7 @@ static STRING *REST_str         = NULL;
 static STRING *LIST_str         = NULL;
 static STRING *HASH_str         = NULL;
 static STRING *FLATTENS_str     = NULL;
+static STRING *SHAPE_str        = NULL;
 static STRING *NEXTITER_str     = NULL;
 static STRING *HASH_SIGIL_str   = NULL;
 static STRING *ARRAY_SIGIL_str  = NULL;
@@ -51,6 +52,7 @@ static void setup_binder_statics(PARROT_INTERP) {
     LIST_str         = Parrot_str_new_constant(interp, "$!list");
     HASH_str         = Parrot_str_new_constant(interp, "$!hash");
     FLATTENS_str     = Parrot_str_new_constant(interp, "$!flattens");
+    SHAPE_str        = Parrot_str_new_constant(interp, "$!shape");
     NEXTITER_str     = Parrot_str_new_constant(interp, "$!nextiter");
     HASH_SIGIL_str   = Parrot_str_new_constant(interp, "%");
     ARRAY_SIGIL_str  = Parrot_str_new_constant(interp, "@");
@@ -155,13 +157,18 @@ Rakudo_binding_list_from_rpa(PARROT_INTERP, PMC *rpa, PMC *type, PMC *flattens)
     VTABLE_set_attr_keyed(interp, list, List, FLATTENS_str, flattens);
     return list;
 }
-   
+
 
 /* Creates a Perl 6 Array. */
 static PMC *
 Rakudo_binding_create_positional(PARROT_INTERP, PMC *rpa) {
-    return Rakudo_binding_list_from_rpa(interp, rpa, Rakudo_types_array_get(),
-               Rakudo_types_bool_true_get());
+    PMC *Array = Rakudo_types_array_get();
+    PMC *Whatever = Rakudo_types_whatever_get();
+    PMC *list = Rakudo_binding_list_from_rpa(interp, rpa, Array,
+        Rakudo_types_bool_true_get());
+    VTABLE_set_attr_keyed(interp, list, Array, SHAPE_str,
+        REPR(Whatever)->allocate(interp, STABLE(Whatever)));
+    return list;
 }
 
 

src/vm/parrot/guts/types.c

@@ -27,6 +27,7 @@ static PMC * Capture    = NULL;
 static PMC * Code       = NULL;
 static PMC * BoolFalse  = NULL;
 static PMC * BoolTrue   = NULL;
+static PMC * Whatever   = NULL;
 static PMC * JunctionThreader = NULL;
 
 static INTVAL ownedhash_id = 0;
@@ -89,6 +90,9 @@ PMC * Rakudo_types_bool_false_get(void) { return BoolFalse; }
 void Rakudo_types_bool_true_set(PMC * type) { BoolTrue = type; }
 PMC * Rakudo_types_bool_true_get(void) { return BoolTrue; }
 
+void Rakudo_types_whatever_set(PMC * type) { Whatever = type; }
+PMC * Rakudo_types_whatever_get(void) { return Whatever; }
+
 void Rakudo_types_junction_threader_set(PMC * threader) { JunctionThreader = threader; }
 PMC * Rakudo_types_junction_threader_get(void) { return JunctionThreader; }
 

src/vm/parrot/guts/types.h

@@ -58,6 +58,9 @@ PMC * Rakudo_types_bool_false_get(void);
 void Rakudo_types_bool_true_set(PMC * type);
 PMC * Rakudo_types_bool_true_get(void);
 
+void Rakudo_types_whatever_set(PMC * type);
+PMC * Rakudo_types_whatever_get(void);
+
 void Rakudo_types_junction_threader_set(PMC * threader);
 PMC * Rakudo_types_junction_threader_get(void);
 

src/vm/parrot/ops/perl6.ops

@@ -654,6 +654,8 @@ inline op p6settypes(invar PMC) :base_core {
         Parrot_str_new_constant(interp, "False")));
     Rakudo_types_bool_true_set(VTABLE_get_pmc_keyed_str(interp, $1,
         Parrot_str_new_constant(interp, "True")));
+    Rakudo_types_whatever_set(VTABLE_get_pmc_keyed_str(interp, $1,
+        Parrot_str_new_constant(interp, "Whatever")));
     Rakudo_types_junction_set(VTABLE_get_pmc_keyed_str(interp, $1,
         Parrot_str_new_constant(interp, "Junction")));
 }