# EVIL hacks here! E.g. method map and sub JS::Root::map! method JS::Root::shift(@self:) is rw { JS::inline('new PIL2JS.Box.Constant(function (args) { var array = args[1].FETCH(), cc = args.pop(); var ret = array.shift(); cc(ret == undefined ? new PIL2JS.Box.Constant(undefined) : ret); })')(@self); } method JS::Root::pop(@self:) is rw { JS::inline('new PIL2JS.Box.Constant(function (args) { var array = args[1].FETCH(), cc = args.pop(); var ret = array.pop(); cc(ret == undefined ? new PIL2JS.Box.Constant(undefined) : ret); })')(@self); } method JS::Root::unshift($self is rw: *@things) is rw { JS::inline('new PIL2JS.Box.Constant(function (args) { var array = args[1].FETCH(), add = args[2].FETCH(), cc = args.pop(); if(array == undefined) args[1].STORE(new PIL2JS.Box.Constant(array = [])); if(array.referencee && array.autoderef) array = array.referencee.FETCH(); for(var i = add.length - 1; i >= 0; i--) { array.unshift(new PIL2JS.Box(add[i].FETCH())); } cc(new PIL2JS.Box.Constant(array.length)); })')($self, @things); } method JS::Root::push($self is rw: *@things) is rw { JS::inline('new PIL2JS.Box.Constant(function (args) { var array = args[1].FETCH(), add = args[2].FETCH(), cc = args.pop(); if(array == undefined) args[1].STORE(new PIL2JS.Box.Constant(array = [])); if(array.referencee && array.autoderef) array = array.referencee.FETCH(); for(var i = 0; i < add.length; i++) { array.push(new PIL2JS.Box(add[i].FETCH())); } cc(new PIL2JS.Box.Constant(array.length)); })')($self, @things); } method join(@self: Str $sep) { join $sep, @self } sub JS::Root::join(Str $sep, *@things) is primitive { JS::inline('( function (arr, sep) { return arr.join(String(sep)); } )')(@things.map:{ ~$_ }, $sep); } method JS::Root::elems(@self:) { JS::inline('(function (arr) { return arr.length })')(@self); } method JS::Root::end(@self:) { JS::inline('(function (arr) { return arr.length - 1 })')(@self); } method map(@self is rw: Code $code) { map $code, @self } sub JS::Root::map(Code $code, *@array is rw) is primitive { die "&map needs a Code as first argument!" unless $code.isa("Code"); my $arity = $code.arity; # die "Can't use 0-ary subroutine as \"map\" body!" if $arity == 0; $arity ||= 1; my @res; my @args; while +@array > 0 { @args = (); my $i; loop ($i = 0; $i < $arity; $i++) { # Slighly hacky push @args: undef; @args[-1] := @array.shift; } push @res, $code([,] @args); } @res; } # XXX XXX XXX XXX ("luckily", the fully qualified name of a method doesn't # matter. XXX XXX evil hack) method sort(@self: Code $cmp = &infix:) { sort $cmp, @self } method PIL2JS::Internals::This::Is::A::Truly::Horrible::Hack::sort(%self: Code $cmp = &infix:) { sort $cmp, %self.pairs } sub JS::Root::sort(Code $cmp is copy = &infix:, *@array) is primitive { # Hack unless $cmp.isa("Code") { unshift @array, @$cmp; $cmp := &infix:; } die "&sort needs a Code as first argument!" unless $cmp.isa("Code"); my $arity = $cmp.arity; $arity ||= 2; # hack die "Can't use $arity-ary subroutine as comparator block for &sort!" unless $arity == 2; JS::inline('new PIL2JS.Box.Constant(function (args) { // [].concat(...): Defeat modifying of the original array. var array = [].concat(args[1].FETCH()), cmp = args[2].FETCH(), cc = args.pop(); var jscmp = function (a, b) { return PIL2JS.cps2normal(cmp, [PIL2JS.Context.ItemAny, a, b]).toNative(); }; array.sort(jscmp); cc(new PIL2JS.Box.Constant(array)); })')(@array, $cmp); } method reduce(@self: Code $code) { reduce $code, @self } sub JS::Root::reduce(Code $code, *@array) is primitive { die "&reduce needs a Code as first argument!" unless $code.isa("Code"); my $arity = $code.arity; die "Can't use an unary or nullary block for &reduce!" if $arity < 2; my $ret = @array.shift; while +@array > 0 { my @args; my $i; loop ($i = 0; $i < $arity - 1; $i++) { # Slighly hacky push @args: undef; @args[-1] := @array.shift; } $ret = $code($ret, @args); } $ret; } method min(@self: Code $cmp = &infix:«<=>») { min $cmp, @self } method max(@self: Code $cmp = &infix:«<=>») { max $cmp, @self } sub JS::Root::min(Code $cmp = &infix:«<=>», *@array) is primitive { # Hack, see comment at &sort. unless $cmp.isa("Code") { unshift @array, @$cmp; $cmp := &infix:«<=>»; } @array.max:{ $cmp($^b, $^a) }; } sub JS::Root::max(Code $cmp = &infix:«<=>», *@array) is primitive { # Hack, see comment at &sort. unless $cmp.isa("Code") { unshift @array, @$cmp; $cmp := &infix:«<=>»; } my $max = @array.shift; $max = ($cmp($max, $_)) < 0 ?? $_ !! $max for @array; $max; } method grep(@self: Code $code) { grep $code, @self } sub JS::Root::grep(Code $code, *@array) is primitive { #die "Code block for \"grep\" must be unary!" unless $code.arity == 1; my @res; for @array -> $item is rw { push @res, $item if $code($item); } @res; } method sum(@self:) { sum @self } sub JS::Root::sum(*@vals) is primitive { my $sum = 0; $sum += +$_ for @vals; @vals ?? $sum !! undef; # We should return undef if we haven't been giving @vals to sum. } method uniq(@self: Code $cmp = &infix:<===>) { uniq $cmp, @self } sub JS::Root::uniq(Code $cmp is copy = &infix:, *@array) is primitive { # Hack unless $cmp.isa("Code") { unshift @array, @$cmp; $cmp := &infix:<===>; } # XXX O(n²) implementation, needing .WHICH or === hashes for a better # implementation my @res; for @array -> $elem { unless $cmp($elem, any(@res)) { push @res, $elem; } } @res; } sub JS::Root::zip(Array *@arrays) is primitive is rw { my $maxlen = max map { +$_ }, @arrays; # XXX wanting hyperops map { my $i := $_; map { @arrays[$_][$i] }, 0..@arrays.end; }, 0..$maxlen-1; } method reverse(*@things is copy:) { # Hack, should of course use context info, but that's not here yet. if @things == 1 { JS::inline('(function (str) { return str.split("").reverse().join("") })')(@things[0]); } else { JS::inline('new PIL2JS.Box.Constant(function (args) { var arr = [].concat(args[1].FETCH()), cc = args.pop(); arr.reverse(); cc(new PIL2JS.Box.Constant(arr)); })')(@things); } } sub infix:<..>(Num $from, Num $to) is primitive { my $i; my @res; loop ($i = $from; $i <= $to; $i++) { push @res, $i; } @res; } sub infix:<^..> (Num $from, Num $to) is primitive { ($from + 1)..$to } sub infix:<..^> (Num $from, Num $to) is primitive { $from..($to - 1) } sub infix:<^..^> (Num $from, Num $to) is primitive { ($from + 1)..($to - 1) } sub infix:<,>(*@xs is rw) is primitive is rw { JS::inline('new PIL2JS.Box.Constant(function (args) { var cxt = args.shift(); var cc = args.pop(); var iarr = args[0].FETCH(); // We don\'t create new containers (new PIL2JS.Boxes) *here* -- lists // don\'t create new containers. Assigning to an array will take care of // this. var mk_magicalarray = function () { var marray = []; for(var i = 0; i < iarr.length; i++) { marray[i] = new PIL2JS.Box(undefined).BINDTO( // Slighly hacky way to determine if iarr[i] is undef, i.e. // it\'s needed to make // my ($a, undef, $b) = (3,4,5); // work. iarr[i].isConstant && iarr[i].FETCH() == undefined ? new PIL2JS.Box(undefined) : iarr[i] ); } return marray; }; // Proxy needed for ($a, $b) = (3, 4) which really is // &infix:<,>($a, $b) = (3, 4); var proxy = new PIL2JS.Box.Proxy( function () { return iarr }, function (n) { var marray = mk_magicalarray(); var arr = new PIL2JS.Box([]).STORE(n).FETCH(); for(var i = 0; i < arr.length; i++) { if(marray[i]) marray[i].STORE(arr[i]); } return this; } ); proxy.BINDTO = function (other) { var arr = other.FETCH(); if(!(arr instanceof Array)) { PIL2JS.die("Can\'t bind list literal to non-array object!"); } var backup_arr = []; for(var i = 0; i < arr.length; i++) { backup_arr[i] = new PIL2JS.Box; backup_arr[i].FETCH = arr[i].FETCH; backup_arr[i].STORE = arr[i].STORE; backup_arr[i].BINDTO = arr[i].BINDTO; } for(var i = 0; i < backup_arr.length; i++) { if(iarr[i].isConstant && iarr[i].FETCH() == undefined) { // ($a, **undef**, $b) := (1,2,3); // (i.e., do nothing) } else { iarr[i].BINDTO(backup_arr[i]); } } return this; }; cc(proxy); })')(@xs); } our &list := &infix:<,>; our &pair := &infix:<,>; # XXX wrong sub circumfix:<[]>(*@xs is rw) is primitive { my @copy; @copy = @xs; \@copy } method postcircumfix:<[]>(@self: Int *@idxs) is rw { die "Can't use object of type {@self.ref} as an array!" unless @self.isa("Array"); # *Important*: We have to calculate the idx only *once*: # my @a = (1,2,3,4); # my $z := @a[-1]; # say $z; # 4 # push @a, 5; # say $z; # 4 (!!) JS::inline('new PIL2JS.Box.Constant(function (args) { var cxt = args.shift(); var cc = args.pop(); var array = args[0].FETCH(); var idxs = args[1].toNative(); var orig_value = []; for(var i = 0; i < idxs.length; i++) { idxs[i] = Number(idxs[i]); if(idxs[i] < 0) { var orig = Number(idxs[i]); idxs[i] = array.length + idxs[i]; orig_value[idxs[i]] = orig; } } if(idxs.length == 0) PIL2JS.die("No indices given to &postcircumfix:<[ ]>!"); // Relay .FETCH and .STORE to array[idx]. var proxy_for = function (idx) { var ret = new PIL2JS.Box.Proxy( function () { var ret = array[idx]; return ret == undefined ? undefined : ret.FETCH(); }, function (n) { if(idx < 0) PIL2JS.die("Modification of non-creatable array value attempted, subscript " + orig_value[idx]); // Support (in a slightly hacky manner) ($a, undef, $b) = (3,4,5). if( array[idx] == undefined || ( array[idx].isConstant && array[idx].FETCH() == undefined ) ) { array[idx] = new PIL2JS.Box(undefined); } array[idx].STORE(n); return n; } ); ret.uid = array[idx] == undefined ? undefined : array[idx].uid; // @a[$idx] := $foo should autovivify @a[$idx] if necessary. ret.BINDTO = function (other) { if(idx < 0) PIL2JS.die("Modification of non-creatable array value attempted, subscript " + orig_value[idx]); if(array[idx] == undefined) array[idx] = new PIL2JS.Box(undefined); return array[idx].BINDTO(other); }; return ret; }; if(idxs.length == 1) { cc(proxy_for(idxs[0])); } else { var ret = []; for(var i = 0; i < idxs.length; i++) { ret.push(proxy_for(idxs[i])); } // Needed for @a[1,2] = (3,4). var proxy = new PIL2JS.Box.Proxy( function () { return ret }, function (n) { var arr = new PIL2JS.Box([]).STORE(n).FETCH(); for(var i = 0; i < arr.length; i++) { if(ret[i]) ret[i].STORE(arr[i]); } return this; } ); proxy.BINDTO = function (other) { var arr = other.FETCH(); if(!(arr instanceof Array)) { PIL2JS.die("Can\'t bind array slice to non-array object!"); } var backup_arr = []; for(var i = 0; i < arr.length; i++) { backup_arr[i] = new PIL2JS.Box; backup_arr[i].FETCH = arr[i].FETCH; backup_arr[i].STORE = arr[i].STORE; backup_arr[i].BINDTO = arr[i].BINDTO; } for(var i = 0; i < backup_arr.length; i++) { ret[i].BINDTO(backup_arr[i]); } return this; }; cc(proxy); } })')(@self, @idxs); } # Array autovification # Needs PIL2 and MMD to be done without hacks sub PIL2JS::Internals::Hacks::array_postcircumfix_for_undefs ( $array is rw, Int *@idxs, ) is primitive is rw { if defined $array { die "\"$array\" can't be autovivified to an array!"; } $array = []; $array[@idxs]; } sub PIL2JS::Internals::Hacks::init_undef_array_postcircumfix_method () is primitive { JS::inline('(function () { PIL2JS.addmethod( _3aMain_3a_3aItem, "postcircumfix:[]", _26PIL2JS_3a_3aInternals_3a_3aHacks_3a_3aarray_postcircumfix_for_undefs ); })')(); } # Code from Prelude::PIR sub splice (@a is rw, $offset=0, $length?, *@list) is primitive { my $off = +$offset; my $len = $length; my $size = +@a; $off += $size if $off < 0; if $off > $size { warn "splice() offset past end of array\n"; $off = $size; } # $off is now ready $len = +$len if defined($len); $len = $size - $off if !defined($len); $len = $size + $len - $off if $len < 0; $len = 0 if $len < 0; # $len is now ready my $listlen = +@list; my $size_change = $listlen - $len; my @result; if 1 { my $i = $off; my $stop = $off + $len; while $i < $stop { push(@result,@a[$i]); $i++; } } if $size_change > 0 { my $i = $size + $size_change -1; my $final = $off + $size_change; while $i >= $final { # The .delete here is necessary to destroy all possible bindings # user code has to @a[$i], see t/operators/binding/arrays.t. @a.delete($i); @a[$i] = @a[$i-$size_change]; $i--; } } elsif $size_change < 0 { my $i = $off; my $final = $size + $size_change -1; while $i <= $final { # The .delete here is necessary to destroy all possible bindings # user code has to @a[$i], see t/operators/binding/arrays.t. @a.delete($i); @a[$i] = @a[$i-$size_change]; $i++; } # +@a = $size + $size_change; # doesnt exist yet, so... my $n = 0; while $n-- > $size_change { pop(@a); } } if $listlen > 0 { my $i = 0; while $i < $listlen { # The .delete here is necessary to destroy all possible bindings # user code has to @a[$off+$i], see t/operators/binding/arrays.t. @a.delete($off+$i); @a[$off+$i] = @list[$i]; $i++; } } # want.List ?? @result !! pop(@result) # want.List ?? @result !! +@result ?? @result[-1] !! undef; # @result; @result; }