Skip to content

Instantly share code, notes, and snippets.

@FROGGS

FROGGS/sized-arrays.diff Secret

Last active December 31, 2015 08:59
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save FROGGS/50d58158001696e89327 to your computer and use it in GitHub Desktop.
Save FROGGS/50d58158001696e89327 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
sized-arrays.diff
diff --git a/CREDITS b/CREDITS
index ef253f9..a04a224 100644
--- a/CREDITS
+++ b/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
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
index 53ad22d..095375f 100644
--- a/src/Perl6/Actions.nqp
+++ b/src/Perl6/Actions.nqp
@@ -198,7 +198,29 @@ class Perl6::Actions is HLL::Actions does STDActions {
%info<default_value> := $*W.find_symbol(['Any']);
}
if $shape {
- $*W.throw($/, 'X::Comp::NYI', feature => 'Shaped arrays');
+ my $shape_ast := $shape[0].ast;
+ if +@($shape_ast) == 1 {
+ my $sast_size := +@($shape_ast[0]);
+ if $sast_size > 1 {
+ my $map_ast := $shape_ast[0][$sast_size - 1];
+ if nqp::istype($map_ast[1], QAST::Node) &&
+ $map_ast[1].has_compile_time_value &&
+ $map_ast[1].compile_time_value eq 'map' {
+ %info<container_index_map> := $shape_ast[0].pop[2];
+ $shape_ast[0] := $shape_ast[0][0] if +@($shape_ast[0]) == 1;
+ }
+ } elsif $sast_size == 0 {
+ $*W.throw($/, 'X::Comp::AdHoc',
+ payload => 'empty shape definition');
+ }
+ } else {
+ $*W.throw($/, 'X::Comp::NYI',
+ feature => 'multidimensional shaped arrays');
+ }
+ %info<container_shape> := $shape_ast;
+ } else {
+ my $whatever := $*W.find_symbol(['Whatever']);
+ %info<container_shape> := nqp::create($whatever);
}
}
elsif $sigil eq '%' {
@@ -2204,11 +2226,27 @@ class Perl6::Actions is HLL::Actions does STDActions {
}
if $*SCOPE eq 'our' {
- $BLOCK[0].push(QAST::Op.new(
- :op('bind'),
- $past,
- $*W.symbol_lookup([$name], $/, :package_only(1), :lvalue(1))
- ));
+ if $sigil == '@' && %cont_info<container_index_map> {
+ my @asts;
+ nqp::push(@asts, $BLOCK[0].pop);
+ if nqp::istype(%cont_info<container_shape>, QAST::Node) {
+ nqp::push(@asts, $BLOCK[0].pop);
+ }
+ $BLOCK[0].push(QAST::Op.new(
+ :op('bind'),
+ $past,
+ $*W.symbol_lookup([$name], $/, :package_only(1), :lvalue(1))
+ ));
+ for @asts {
+ $BLOCK[0].push($_);
+ }
+ } else {
+ $BLOCK[0].push(QAST::Op.new(
+ :op('bind'),
+ $past,
+ $*W.symbol_lookup([$name], $/, :package_only(1), :lvalue(1))
+ ));
+ }
}
}
diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp
index 4e71bff..ce49840 100644
--- a/src/Perl6/Grammar.nqp
+++ b/src/Perl6/Grammar.nqp
@@ -2199,9 +2199,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>
- | <?[<]> <postcircumfix> <.NYI: "Shaped variable declarations">
+ | <?[<]> <postcircumfix>
]+
]?
<.ws>
diff --git a/src/Perl6/Metamodel/BOOTSTRAP.nqp b/src/Perl6/Metamodel/BOOTSTRAP.nqp
index 6314bb4..e6954bc 100644
--- a/src/Perl6/Metamodel/BOOTSTRAP.nqp
+++ b/src/Perl6/Metamodel/BOOTSTRAP.nqp
@@ -77,6 +77,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.
@@ -1573,8 +1574,12 @@ BEGIN {
# class Array is List {
# has Mu $!descriptor;
+ # has Mu $!shape;
+ # has Mu $!index_map;
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.add_attribute(Array, scalar_attr('$!index_map', Mu, Array));
Array.HOW.compose_repr(Array);
# class LoL is List {
@@ -1634,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.
# class Stash is Hash {
Stash.HOW.add_parent(Stash, Hash);
@@ -1671,6 +1680,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 :=
@@ -1764,6 +1774,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;
@@ -1793,6 +1804,7 @@ Regex.HOW.publish_parrot_vtable_handler_mapping(Regex);
Regex.HOW.publish_parrot_vtable_mapping(Regex);
Stash.HOW.publish_parrot_vtable_handler_mapping(Stash);
Str.HOW.publish_parrot_vtable_handler_mapping(Str);
+Whatever.HOW.publish_parrot_vtable_mapping(Whatever);
#?endif
# Set up various type mappings.
diff --git a/src/Perl6/World.nqp b/src/Perl6/World.nqp
index b85a61c..45e0734 100644
--- a/src/Perl6/World.nqp
+++ b/src/Perl6/World.nqp
@@ -223,7 +223,7 @@ class Perl6::World is HLL::World {
@!cleanup_tasks := [];
%!magical_cds := {};
}
-
+
# Creates a new lexical scope and puts it on top of the stack.
method push_lexpad($/) {
# Create pad, link to outer and add to stack.
@@ -626,6 +626,33 @@ class Perl6::World is HLL::World {
nqp::bindattr($cont, %cont_info<container_base>, '$!value',
%cont_info<scalar_value>);
}
+ if nqp::existskey(%cont_info, 'container_shape') {
+ if nqp::istype(%cont_info<container_shape>, QAST::Node) {
+ $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>
+ )
+ );
+ } else {
+ nqp::bindattr($cont, %cont_info<container_base>, '$!shape',
+ %cont_info<container_shape>);
+ }
+ if nqp::existskey(%cont_info, 'container_index_map') {
+ $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('$!index_map')),
+ %cont_info<container_index_map>
+ )
+ );
+ }
+ }
self.add_object($cont);
$block.symbol($name, :value($cont));
self.install_package_symbol($package, $name, $cont) if $scope eq 'our';
@@ -706,6 +733,32 @@ class Perl6::World is HLL::World {
QAST::SVal.new( :value('$!value') ),
QAST::WVal.new( :value(%cont_info<scalar_value>) )));
}
+
+ if nqp::existskey(%cont_info, 'container_shape') {
+ if !nqp::istype(%cont_info<container_shape>, QAST::Node) {
+ %cont_info<container_shape> := QAST::Op.new(
+ :op('callmethod'),
+ :name('new'),
+ QAST::WVal.new(:value(self.find_symbol(['Whatever'])))
+ );
+ }
+ $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>
+ ));
+ if nqp::existskey(%cont_info, 'container_index_map') {
+ $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('$!index_map')),
+ %cont_info<container_index_map>
+ ));
+ }
+ }
$cont_code
}
@@ -1499,13 +1552,26 @@ class Perl6::World is HLL::World {
nqp::bindattr($cont, %cont_info<container_base>, '$!value',
%cont_info<scalar_value>);
}
-
+ if nqp::existskey(%cont_info, 'container_shape') {
+ if nqp::istype(%cont_info<container_shape>, QAST::Node) {
+ nqp::bindattr($cont, %cont_info<container_base>, '$!shape',
+ self.compile_time_evaluate($/, %cont_info<container_shape>));
+ } else {
+ nqp::bindattr($cont, %cont_info<container_base>, '$!shape',
+ %cont_info<container_shape>);
+ }
+ if nqp::existskey(%cont_info, 'container_index_map') {
+ nqp::bindattr($cont, %cont_info<container_base>, '$!index_map',
+ self.compile_time_evaluate($/, %cont_info<container_index_map>));
+ }
+ }
+
# Create meta-attribute instance and add right away. Also add
# it to the SC.
my $attr := $meta_attr.new(:auto_viv_container($cont), |%lit_args, |%obj_args);
$obj.HOW.add_attribute($obj, $attr);
self.add_object($attr);
-
+
# Return attribute that was built.
$attr
}
diff --git a/src/core/Array.pm b/src/core/Array.pm
index 4490fb0..713a580 100644
--- a/src/core/Array.pm
+++ b/src/core/Array.pm
@@ -3,13 +3,18 @@ my class X::TypeCheck { ... };
class Array { # declared in BOOTSTRAP
# class Array is List {
+ # has Mu $!shape;
+ # has Mu $!index_map;
# has Mu $!descriptor;
- 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 {
@@ -21,7 +26,9 @@ class Array { # declared in BOOTSTRAP
#?endif
X::Item.new(aggregate => self, index => $pos).throw;
}
- my int $p = nqp::unbox_i($pos.Int);
+ my int $p = self.map_index($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)
if nqp::existspos($items, $p)
@@ -38,7 +45,10 @@ class Array { # declared in BOOTSTRAP
);
}
}
- multi method at_pos(Array:D: int $pos) is rw {
+ multi method at_pos(Array:D: int $p) is rw {
+ my int $pos = self.map_index($p);
+ 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)
if nqp::existspos($items, $pos)
@@ -57,12 +67,17 @@ class Array { # declared in BOOTSTRAP
}
proto method bind_pos(|) { * }
- multi method bind_pos($pos is copy, Mu \bindval) is rw {
- $pos = $pos.Int;
+ multi method bind_pos($p is copy, Mu \bindval) is rw {
+ my int $pos = self.map_index($p.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);
+ nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval);
}
- multi method bind_pos(int $pos, Mu \bindval) is rw {
+ multi method bind_pos(int $p, Mu \bindval) is rw {
+ my int $pos = self.map_index($p);
+ 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)
}
@@ -72,6 +87,7 @@ class Array { # declared in BOOTSTRAP
self.delete_pos(pos);
}
method delete_pos(\pos) {
+ fail "Cannot delete from a shaped array" unless nqp::istype($!shape, Whatever);
fail "Cannot use negative index {pos} on {self.WHAT.perl}" if pos < 0;
my $value := self.at_pos(pos); # needed for reification
@@ -82,7 +98,7 @@ class Array { # declared in BOOTSTRAP
my $pos = pos;
nqp::pop($items);
nqp::pop($items)
- while --$pos >= 0 && nqp::isnull(nqp::atpos($items,$pos));
+ while --$pos >= 0 && nqp::isnull(nqp::atpos($items, $pos));
}
elsif pos < $end {
nqp::bindpos($items, pos, nqp::null());
@@ -95,6 +111,48 @@ class Array { # declared in BOOTSTRAP
method flattens() { 1 }
+ method shape() { $!shape }
+
+ # FIXME: this should probably be private
+ method map_index($pos --> int) {
+ return nqp::unbox_i(nqp::decont($!index_map)($pos).floor.Int)
+ if nqp::istype($!index_map, Code);
+ return nqp::unbox_i($!index_map) if nqp::istype($!index_map, Any);
+ nqp::unbox_i($pos)
+ }
+
+ method pop() is parcel {
+ 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 parcel {
+ 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);
+ }
+
+ method exists(\pos) {
+ nqp::findmethod(List, 'exists')(self, self.map_index(pos))
+ }
+
+ method reverse() {
+ Array.new(:shape($!shape), nqp::findmethod(List, 'reverse')(self))
+ }
+
+ method rotate(Int $n = 1) {
+ Array.new(:shape($!shape), nqp::findmethod(List, 'rotate')(self, $n))
+ }
+
# introspection
method name() {
my $d := $!descriptor;
@@ -129,6 +187,13 @@ class Array { # declared in BOOTSTRAP
nqp::findmethod(List, 'REIFY')(self, parcel, nextiter)
}
+ method STORE_AT_POS(Int \p, Mu $v is copy) is rw {
+ my int $pos = self.map_index(p.Int);
+ fail "Index $pos is too large for this shaped array"
+ unless nqp::istype($!shape, Whatever) or $pos < $!shape;
+ nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, $v)
+ }
+
method STORE(|) {
# get arguments, shift off invocant
my $args := nqp::p6argvmarray();
@@ -136,22 +201,31 @@ class Array { # declared in BOOTSTRAP
# 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);
+ $!shape = * if !nqp::istype($!shape, 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
# the array we just created
nqp::bindattr(self, List, '$!items', Mu);
nqp::bindattr(self, List, '$!nextiter', nqp::p6listiter(nqp::list($list), self));
+ self = self.splice(0, $!shape, self)
+ if not nqp::istype($!shape, Whatever) and (self.infinite or self.elems > $!shape);
self
}
my role TypedArray[::TValue] does Positional[TValue] {
- method new(|) {
+ method new(:$shape = *, |) {
my Mu $args := nqp::p6argvmarray();
nqp::shift($args);
+
+ fail "Too many elements for this shaped array"
+ unless nqp::istype($shape, Whatever) or nqp::elems($args) < $shape;
my $list := nqp::p6list($args, self.WHAT, Bool::True);
+ nqp::bindattr($list, Array, '$!shape', $shape);
+
my $of = self.of;
if ( $of !=:= Mu ) {
for @$list {
@@ -167,11 +241,13 @@ class Array { # declared in BOOTSTRAP
$list;
}
- multi method at_pos($pos is copy) is rw {
- $pos = $pos.Int;
+ multi method at_pos($p is copy) is rw {
+ my int $pos = self.map_index($p.Int);
+ fail "Index $pos is too large for this shaped array"
+ unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
if self.exists_pos($pos) {
nqp::atpos(
- nqp::getattr(self, List, '$!items'), nqp::unbox_i($pos)
+ nqp::getattr(self, List, '$!items'), $pos
);
}
else {
@@ -180,11 +256,14 @@ class Array { # declared in BOOTSTRAP
Scalar,
'$!whence',
-> { nqp::bindpos(
- nqp::getattr(self,List,'$!items'), nqp::unbox_i($pos), v) }
+ nqp::getattr(self,List,'$!items'), $pos, v) }
);
}
}
- multi method at_pos(int $pos, TValue $v? is copy) is rw {
+ multi method at_pos(int $p, TValue $v? is copy) is rw {
+ my int $pos = self.map_index($p);
+ fail "Index $pos is too large for this shaped array"
+ unless nqp::istype(self.shape, Whatever) or $pos < self.shape;
if self.exists_pos($pos) {
nqp::atpos(nqp::getattr(self, List, '$!items'), $pos);
}
@@ -197,12 +276,17 @@ class Array { # declared in BOOTSTRAP
);
}
}
- multi method bind_pos($pos is copy, TValue \bindval) is rw {
- $pos = $pos.Int;
+ multi method bind_pos($p is copy, TValue \bindval) is rw {
+ my int $pos = self.map_index($p.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)
+ nqp::bindpos(nqp::getattr(self, List, '$!items'), $pos, bindval)
}
- multi method bind_pos(int $pos, TValue \bindval) is rw {
+ multi method bind_pos(int $p, TValue \bindval) is rw {
+ my int $pos = self.map_index($p);
+ 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)
}
diff --git a/src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java b/src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java
index 43dd996..26f9352 100644
--- a/src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java
+++ b/src/vm/jvm/runtime/org/perl6/rakudo/RakOps.java
@@ -47,6 +47,7 @@ public final class RakOps {
public SixModelObject ContainerDescriptor;
public SixModelObject False;
public SixModelObject True;
+ public SixModelObject Whatever;
public SixModelObject AutoThreader;
public SixModelObject EMPTYARR;
public SixModelObject EMPTYHASH;
@@ -79,6 +80,7 @@ public final class RakOps {
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 = 6;
public static SixModelObject p6init(ThreadContext tc) {
GlobalExt gcx = key.getGC(tc);
@@ -119,6 +121,7 @@ public final class RakOps {
gcx.ContainerDescriptor = conf.at_key_boxed(tc, "ContainerDescriptor");
gcx.False = conf.at_key_boxed(tc, "False");
gcx.True = conf.at_key_boxed(tc, "True");
+ gcx.Whatever = conf.at_key_boxed(tc, "Whatever");
gcx.JavaHOW = conf.at_key_boxed(tc, "Metamodel").st.WHO.at_key_boxed(tc, "JavaHOW");
SixModelObject defCD = gcx.ContainerDescriptor.st.REPR.allocate(tc,
@@ -183,6 +186,9 @@ public final class RakOps {
list.bind_attribute_boxed(tc, gcx.List, "$!nextiter", HINT_LIST_nextiter,
p6listiter(arr, list, tc));
list.bind_attribute_boxed(tc, gcx.List, "$!flattens", HINT_LIST_flattens, flattens);
+ if (type == gcx.Array)
+ list.bind_attribute_boxed(tc, gcx.Array, "$!shape", HINT_ARRAY_shape,
+ gcx.Whatever.st.REPR.allocate(tc, gcx.Whatever.st));
return list;
}
diff --git a/src/vm/parrot/guts/bind.c b/src/vm/parrot/guts/bind.c
index 44bb2f8..347c3d9 100644
--- a/src/vm/parrot/guts/bind.c
+++ b/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;
}
diff --git a/src/vm/parrot/guts/types.c b/src/vm/parrot/guts/types.c
index 67c2f29..660dc5a 100644
--- a/src/vm/parrot/guts/types.c
+++ b/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; }
diff --git a/src/vm/parrot/guts/types.h b/src/vm/parrot/guts/types.h
index e082e9f..166f0d3 100644
--- a/src/vm/parrot/guts/types.h
+++ b/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);
diff --git a/src/vm/parrot/ops/perl6.ops b/src/vm/parrot/ops/perl6.ops
index 65a3214..8c40c5d 100644
--- a/src/vm/parrot/ops/perl6.ops
+++ b/src/vm/parrot/ops/perl6.ops
@@ -656,6 +656,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")));
Rakudo_types_nil_set(VTABLE_get_pmc_keyed_str(interp, $1,
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment