SAFE.setting

# vim: ft=perl6 fdm=marker
my module SAFE;
use MONKEY_TYPING;

# Note that a few of these functions are defined as themselves.  That
# means that the true definitions are in the optimizer, and the subs
# are only used for non-primitivizable cases.

# Fundamental types {{{
my class Mu {
    method head() { @(self).head }
    method typename() {  # should be ^name
        Q:CgOp { (box Str (obj_typename (@ {self}))) }
    }
    method Str() {
        my $tn := Q:CgOp { (box Str (obj_typename (@ {self}))) };
        if defined(self) {
            $tn ~ "()<instance>"
        } else {
            $tn ~ "()"
        }
    }
    method perl() { defined(self) ?? self.Str !! self.typename }
    method so() { ?self }
    method not() { !self }
    method RAWCREATE(\|$vars) { Q:CgOp {
        (letn ar  (unbox fvarlist (@ {$vars}))
              max (fvarlist_length (l ar))
              i   (int 1)
              obj (obj_newblank (obj_llhow (@ (fvarlist_item (i 0) (l ar)))))
          [whileloop 0 0 (< (l i) (l max)) (prog
              [setslot
                (unbox str (@ (fvarlist_item (l i) (l ar)))) (l obj)
                (nsw (@ (fvarlist_item (+ (l i) (int 1)) (l ar))))]
              [l i (+ (l i) (int 2))])]
          [ns (l obj)])
    } }
    method CREATE(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
    method new(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
}

my class Any is Mu {
    method flat() { @(self) }

    method sort($cmp = &infix:<leg>) { @(self).sort($cmp) }

    method ACCEPTS($t) { self === $t }
    method !butWHENCE($cr) {
        Q:CgOp { (newvsubvar (class_ref mo Any) (@ {$cr}) (@ {self})) }
    }
}

my class Cursor { ... }
my class Regex  { ... }
my class Num    { ... }
my class Cool {
    method grep($sm)  { grep $sm, @(self) }
    method map($func) { map $func, @(self) }
    method for (&cb) {
        Q:CgOp {
            (rnull (letn it (unbox vvarlist (@ {self.iterator}))
                  cb (@ {&cb})
              (whileloop 0 0 (iter_hasflat (l it))
                (sink (subcall (l cb) (vvarlist_shift (l it)))))))
        };
    }

    method split($matcher, $limit = 1_000_000_000, :$all?) {
        my $matchrx = (($matcher ~~ Regex) ?? $matcher !! /$matcher/);
        my $str = ~self;
        my $C = Cursor.new($str);
        my @out;
        my $i = 0;
        my $last = 0;
        my $limctr = $limit;
        my $M;
        while ($i <= chars $str) && ($limctr > 1) {
            $M = first($matchrx($C.cursor($i++)));
            if $M {
                push @out, substr($str, $last, ($M.from - $last));
                push @out, $M if $all;
                $i = ($last = $M.to);
                $limctr = ($limctr - 1);
            }
        }
        push @out, substr($str, $last, (chars($str) - $last));
        @out;
    }

    method index($substring, $pos = 0) {
        my $str = ~self;
        my $fromc = $pos;
        my $len = chars $substring;
        my $maxi = chars($str) - $len;
        while $fromc <= $maxi {
            if substr($str,$fromc,$len) eq $substring {
                return $fromc;
            }
            $fromc++;
        }
        Num; # XXX StrPos
    }

    method rindex($substring, $from?) {
        my $str = ~self;
        my $len = chars $substring;
        my $fromc = (($from // 1_000_000_000) min (chars($str) - $len));
        while $fromc >= 0 {
            if substr($str,$fromc,$len) eq $substring {
                return $fromc;
            }
            $fromc = $fromc - 1;
        }
        Num; # XXX StrPos
    }

    my $char = /./;
    method comb($matcher = $char, $limit = 1_000_000_000, :$match) {
        my $str = ~self;
        my $C = Cursor.new($str);
        my $i = 0;
        my $limctr = $limit;
        my @out;
        while ($i < chars $str) && $limctr {
            my $M = first($matcher($C.cursor($i++)));
            if $M {
                $i max= $M.to;
                push @out, ($match ?? $M !! (~$M));
                $limctr = $limctr - 1;
            }
        }
        @out
    }

    method lines($limit = 1_000_000_000) {
        self.comb(/ ^^ \N* /, $limit);
    }

    method words($limit = 1_000_000_000) {
        self.comb(/ \S+ /, $limit);
    }
    method say() { (~self).say }
    method chars() { chars(self) }
    method substr($x,$y) { substr(self,$x,$y) }
    method lc() { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
    method uc() { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}


    method at-pos(\$self: $ix) {
        defined($self)
            ?? $self.list.at-pos($ix)
            !! _vivify_array_at_pos($self, $ix)
    }
    method elems() { self.flat.elems }
    method iterator() { self.flat.iterator }
    method join($sep) { self.flat.join($sep) }
}

my class Capture {
    has $!positionals;
    has $!named;

    method Capture () { self }
    method list () { @( Q:CgOp { (box Parcel (getslot positionals fvarlist
        (@ {self}))) } ) }
    method hash () { unitem( Q:CgOp { (box Hash (getslot named varhash
        (@ {self}))) } // {} ) }
}
# }}}
# Scalar types {{{
my class Num is Cool {
    method Str () { Q:CgOp {
        (box Str (num_to_string (unbox num (@ {self}))))
    } }
    method Bool() { Q:CgOp {
        (box Bool (compare != (double 0) (unbox num (@ {self}))))
    } }
    method Numeric() { self }
    method ACCEPTS($t) { self == $t }
}

#TODO use a power from the standard library
sub infix:<**>($num,$power) {
    my $ret = 1;
    my $p = $power;
    while ($p > 0) {
        $ret *= $num;
        $p--;
    }
    $ret;
}

my class Str is Cool {
    method Str () { self }
    method ACCEPTS($t) { self eq $t }
    method Bool () { self ne "" }
    method chars() { chars(self) }
    method say() { Q:CgOp {
        (prog [say (unbox str (@ {self}))]
              [box Bool (bool 1)]
        )
    } }
    method Numeric() { Q:CgOp { (box Num (str_tonum (obj_getstr {self}))) } }
    method substr($from, $len) { substr(self, $from, $len) }
    # XXX .trans
    method perl() { defined(self) ?? '"' ~ self ~ '"' !! 'Str' }
}

my class Scalar {
}

my class Sub {
    has $!outer;
    has $!info;

    # Should be for Block, not Sub
    method ACCEPTS($t) { (self)($t) }
}

my class ClassHOW {
    method isa($obj, $type) { Q:CgOp {
        (box Bool (obj_isa (@ {$obj}) (obj_llhow (@ {$type}))))
    } }
    method does($obj, $role) { self.isa($obj, $role) } #no roles yet
}

my class EnumType is Cool { }
my class Bool is EnumType {
    method Str() { self ?? "Bool::True" !! "Bool::False" }
    method Bool() { self }
    method ACCEPTS($) { self }
    method Numeric() { self ?? 1 !! 0 }
    our constant True  = Q:CgOp { (box Bool (bool 1)) };
    our constant False = Q:CgOp { (box Bool (bool 0)) };
}
# TODO: import
constant True  = Q:CgOp { (box Bool (bool 1)) };
constant False = Q:CgOp { (box Bool (bool 0)) };
# }}}
# Fundamental scalar operators {{{
sub infix:<~>(\|$bits) { Q:CgOp {
    (letn buf (strbuf_new)
          i   (int 0)
          ar  (unbox fvarlist (@ {$bits}))
          max (fvarlist_length (l ar))
      [whileloop 0 0 (< (l i) (l max)) (prog
          [strbuf_append (l buf)
            (obj_getstr (fvarlist_item (l i) (l ar)))]
          [l i (+ (l i) (int 1))])]
      [box Str (strbuf_seal (l buf))])
} }

sub infix:<+>($l,$r) { $l + $r }
sub infix:<->($l,$r) { $l - $r }
sub infix:<*>($l,$r) { $l * $r }
sub infix:</>($l,$r) { $l / $r }

sub infix:<< < >>($l,$r)  { $l <  $r }
sub infix:<< > >>($l,$r)  { $l >  $r }
sub infix:<< <= >>($l,$r) { $l <= $r }
sub infix:<< >= >>($l,$r) { $l >= $r }
sub infix:<< == >>($l,$r) { $l == $r }
sub infix:<< != >>($l,$r) { $l != $r }

sub infix:<max>($a,$b) { $a < $b ?? $b !! $a }
sub infix:<min>($a,$b) { $a > $b ?? $b !! $a }

sub warn($str) { Q:CgOp {
    (prog [note (obj_getstr {$str})]
          [box Bool (bool 1)]
    )
} }

sub say(*@text)   { Q:CgOp { (rnull (say   (obj_getstr {@text.join('')}))) }; True }
sub print(*@text) { Q:CgOp { (rnull (print (obj_getstr {@text.join('')}))) }; True }
sub note(*@text)  { Q:CgOp { (rnull (note  (obj_getstr {@text.join('')}))) }; True }

sub exit($status = 0) { Q:CgOp {
    (rnull [exit (cast int (obj_getnum {$status}))])
} }

sub infix:<=>(\$a, \$b) { Q:CgOp { (prog [assign {$a} {$b}] {$a}) } }

sub chars($str) { chars($str) }
sub substr($str, $start, $len = chars($str) - $start) { substr($str, $start, $len) }

sub item($x) { $x }

sub prefix:<not>($x) { not($x) }
sub defined($x) { defined($x) }

# Buglet in STD: standard infix operators look custom inside the setting, and
# forget their precedence.
sub prefix:<-->($v is rw) { $v = (($v // 0) - 1); $v }
sub prefix:<++>($v is rw) { $v = (($v // 0) + 1); $v }
sub postfix:<-->($v is rw) { my $old = $v; $v = (($v // 0) - 1); $old }
sub postfix:<++>($v is rw) { my $old = $v; $v = (($v // 0) + 1); $old }

sub prefix:<~>($v) { ~$v }
sub prefix:<?>($v) { ?$v }
sub prefix:<->($v) { -$v }
sub prefix:<+>($v) { +$v }
sub prefix:<!>($v) { !$v }

sub not($v) { not($v) }

sub infix:<x>($str, $ct) {
    my $i = +$ct;
    my $j = ''; # XXX use strbuf
    while $i >= 1 {
        $i--;
        $j ~= $str;
    }
    $j;
}

sub infix:<leg>($s1, $s2) {
    Q:CgOp { (box Num (cast num (strcmp (obj_getstr {$s1}) (obj_getstr {$s2})))) }
}

sub infix:<ge>($s1, $s2) { $s1 ge $s2 }
sub infix:<gt>($s1, $s2) { $s1 gt $s2 }
sub infix:<le>($s1, $s2) { $s1 le $s2 }
sub infix:<lt>($s1, $s2) { $s1 lt $s2 }
sub infix:<eq>($s1, $s2) { $s1 eq $s2 }
sub infix:<ne>($s1, $s2) { $s1 ne $s2 }
sub lc($s) { (~$s).lc }
sub uc($s) { (~$s).uc }
# this one is horribly wrong and only handles the ref eq case.
sub infix:<===>($l,$r) { Q:CgOp {
    (box Bool (compare == (@ {$l}) (@ {$r})))
} }

sub _param_role_inst(\|$t) {
    Q:CgOp { (instrole (unbox fvarlist (@ {$t}))) }
}

sub infix:<but>($obj, $role) { Q:CgOp {
    (ns (stab_what (role_apply (obj_llhow (@ {$obj})) (obj_llhow (@ {$role})))))
} }

sub infix:<~~>($t,$m) { defined($m) ?? ($m.ACCEPTS($t)) !! ($t.^does($m)) }

sub ord($x) { Q:CgOp { (bif_ord {$x}) } }
sub chr($x) { Q:CgOp { (bif_chr {$x}) } }
sub infix:<+&>($x, $y) { Q:CgOp { (bif_numand {$x} {$y}) } }
sub infix:<+|>($x, $y) { Q:CgOp { (bif_numor {$x} {$y}) } }
sub infix:<+^>($x, $y) { Q:CgOp { (bif_numxor {$x} {$y}) } }
sub infix:<< +< >>($x, $y) { Q:CgOp { (bif_numlshift {$x} {$y}) } }
sub infix:<< +> >>($x, $y) { Q:CgOp { (bif_numrshift {$x} {$y}) } }
sub prefix:<< +^ >>($x) { Q:CgOp { (bif_numcompl {$x}) } }
sub gettimeofday() { Q:CgOp { (bif_gettimeofday) } }

# }}}
# Flow inspection and control {{{
my class CallFrame {
    method caller() { Q:CgOp {
        (letn c (frame_caller (cast frame (@ {self})))
          (ternary
            (!= (l c) (null frame))
            (ns (l c))
            {Any}))
    } }

    method file() { Q:CgOp { (box Str (frame_file
        (cast frame (@ {self})))) } }
    method line() { Q:CgOp { (box Num (cast num (frame_line
        (cast frame (@ {self}))))) } }

    method hints($var) { Q:CgOp { (frame_hint (cast frame (@ {self}))
        (obj_getstr {$var})) } }
}

sub caller() { Q:CgOp { (ns (frame_caller (frame_caller (callframe)))) } }
sub callframe() { Q:CgOp { (ns (frame_caller (callframe))) } }

sub die($msg) { Q:CgOp { (die (@ {$msg})) } }

# XXX multi dispatch
sub next() {
    Q:CgOp { (control 1 (null frame) (int -1) (null str) (null var)) }
}
sub last() {
    Q:CgOp { (control 2 (null frame) (int -1) (null str) (null var)) }
}
sub redo() {
    Q:CgOp { (control 3 (null frame) (int -1) (null str) (null var)) }
}
sub return(\$obj) is return-pass {
    Q:CgOp { (control 4 (null frame) (int -1) (null str) {$obj}) }
}
sub nextsame() {
    Q:CgOp { (control 9 (null frame) (int -1) (null str) (null obj)) }
}
sub nextwith(|$cap) {
    Q:CgOp { (control 9 (null frame) (int -1) (null str) (@ {$cap})) }
}

sub assignop($fn) {
    anon sub _assign(\$lhs, \$rhs) {
        $lhs = $fn($lhs, $rhs)
    }
}

sub notop(&fn) { -> \$x, \$y { !(fn($x,$y)) } }

# }}}
# Aggregate types {{{
# Parcel: immutable list of boxes which have no context - may flatten, may
# autovivify, don't rebind or push/shift/etc
# List: mutable list of boxes without much context.  accessing off end returns
# undefined.  lazy.
# coercion makes the elements of a List read-only and maybe fetches them too.
# Array: mutable list of read-write scalar boxes

sub unitem(\$a) { Q:CgOp { (newrwlistvar (@ {$a})) } }
sub first(\$x) { for $x -> $elt { return $elt }; Any }

my class Iterator {
    method list () {
        Q:CgOp {
            (letn n (obj_newblank (class_ref mo List))
              (iter_to_list (l n) (unbox vvarlist (@ {self})))
              (newrwlistvar (l n)))
        }
    }

    method flat () {
        Q:CgOp {
            (letn n (obj_newblank (class_ref mo List))
              (iter_to_list (l n) (iter_flatten (unbox vvarlist (@ {self}))))
              (newrwlistvar (l n)))
        }
    }
}

my class IterCursor {
    # subclasses must provide .reify, return parcel
}

sub flat(*@x) { @x }

my class Whatever { }

my class EMPTY { }

my class List { ... }
my class Array { ... }

my class Parcel is Cool {
    method flat() { self.iterator.flat }

    method elems() { Q:CgOp {
        (box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
    } }

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
              (setslot positionals (l n) (unbox fvarlist (@ {self})))
              (ns (l n)))
        }
    }

    method LISTSTORE(*@in) {
        my @values = @in;

        # TODO: proper (sized) handling of sub-parcels
        Q:CgOp {
            (rnull
              (letn i    (i 0)
                    tgts (unbox fvarlist (@ {self}))
                    ntgt (fvarlist_length (l tgts))
                    tgt  (null var)
                (whileloop 0 0 (< (l i) (l ntgt))
                  (prog
                    (l tgt (fvarlist_item (l i) (l tgts)))
                    (l i (+ (l i) (i 1)))
                    (ternary (var_islist (l tgt))
                      (prog
                        (sink (methodcall (l tgt) LISTSTORE {@values.clone}))
                        (sink {@values = ()}))
                      (assign (l tgt) {@values ?? @values.shift !! Any}))))))
        };

        @in;
    }
}

constant Nil = Q:CgOp { (newrwlistvar (@ (box Parcel (fvarlist_new)))) };

my class List is Cool {
    has @!items;
    has @!rest;
    has $!flat;

    method new() {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {self})))
              (setslot items (l n) (vvarlist_new_empty))
              (setslot rest  (l n) (vvarlist_new_empty))
              (newrwlistvar (l n)))
        };
    }

    method flat() {
        self.iterator.flat
    }

    method Seq () {
        Q:CgOp { (box Iterator (iter_copy_elems (unbox vvarlist (@ {self.eager.iterator})))) }.list
    }

    method clone() { Q:CgOp {
        (letn selfo (@ {self})
              new (obj_newblank (obj_llhow (l selfo)))
          (setslot items (l new) (vvarlist_clone
              (getslot items vvarlist (l selfo))))
          (setslot rest (l new) (vvarlist_clone
              (getslot rest vvarlist (l selfo))))
          (newrwlistvar (l new)))
    } }

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
              (setslot positionals (l n) (vvarlist_to_fvarlist
                  (getslot items vvarlist (@ {self.eager}))))
              (ns (l n)))
        }
    }

    method perl() { defined(self) ?? '[' ~ self.map(*.perl).join(', ') ~ ']'
        !! self.typename }

    method !shift-item() { Q:CgOp {
        (vvarlist_shift (getslot items vvarlist (@ {self})))
    } }

    method !pop-item() { Q:CgOp {
        (vvarlist_pop (getslot items vvarlist (@ {self})))
    } }

    method !unshift-item(\$x) { Q:CgOp {
        (rnull (vvarlist_unshift (getslot items vvarlist (@ {self})) {$x}))
    } }

    method shift() { self ?? self!shift-item !! Any }

    method eager() { +self; self }

    method head() { self ??
        Q:CgOp { (vvarlist_item (i 0) (getslot items vvarlist (@ {self}))) } !!
        Any
    }

    method elems()    { +self }

    method join($sep) {
        my $t;
        for unitem(self) -> $x {
            $t = (defined($t) ?? ($t ~ ($sep ~ $x)) !! $x);
        }
        $t // '';
    }

    method Str() { self.join(" ") }

    method sort($cmp = &infix:<leg>) {
        my $l = @(self).eager;
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {List})))
              (setslot items (l n) (vvarlist_sort (@ {$cmp})
                  (getslot items vvarlist (@ {$l}))))
              (setslot rest (l n) (vvarlist_new_empty))
              (newrwlistvar (l n)))
        }
    }

    method plan(*@items) {
        Q:CgOp {
            (rnull
              (vvarlist_append (getslot rest vvarlist (@ {self}))
                (unbox vvarlist (@ {@items.iterator}))))
        }
    }

    method push(\|$args) { Q:CgOp {
        (letn iter (vvarlist_from_fvarlist (unbox fvarlist (@ {$args})))
              targ (getslot rest vvarlist (@ {self}))
          (sink (vvarlist_shift (l iter)))
          (ternary (== (i 0) (vvarlist_count (l targ)))
            (l targ (getslot items vvarlist (@ {self})))
            (prog))
          (whileloop 0 0 (iter_hasflat (l iter))
            (vvarlist_push (l targ) (nsw (@ (vvarlist_shift (l iter))))))
          {Nil})
    } }

    method pop() { +self; self!pop-item; }

    method unshift(*@a) {
        for reverse(@a) -> $v { self!unshift-item(anon $new = $v) }
    }
}

my class Array is List {
    method LISTSTORE(\$in) {
        Q:CgOp {
            (letn iter (vvarlist_new_empty)
                  into (vvarlist_new_empty)
                  sobj (@ {self})
              (vvarlist_push (l iter) {$in})
              (whileloop 0 0 (iter_hasflat (l iter))
                (vvarlist_push (l into) (vvarlist_shift (l iter))))
              (setslot items (l sobj) (iter_copy_elems (l into)))
              (setslot rest  (l sobj) (l iter))
              (newrwlistvar (l sobj)))
        };
    }
}

my class Hash {
    method new() { unitem(Q:CgOp { (box Hash (varhash_new)) }) }
    method hash() { unitem(self) }

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
              (setslot positionals (l n) (fvarlist_new))
              (setslot named (l n) (varhash_dup
                  (unbox varhash (@ {self}))))
              (ns (l n)))
        }
    }

    method keys()   { Q:CgOp { (bif_hash_keys   {self}) } }
    method values() { Q:CgOp { (bif_hash_values {self}) } }
    method pairs()  { Q:CgOp { (bif_hash_pairs  {self}) } }
    method list()   { Q:CgOp { (bif_hash_pairs  {self}) } }
    method kv()     { Q:CgOp { (bif_hash_kv     {self}) } }

    method invert() {
        my %new;
        for self.keys -> $k { %new{self{$k}} = $k }
        %new
    }

    method LISTSTORE(\$in) {
        Q:CgOp {
            (letn iter (vvarlist_new_empty)
                  into (varhash_new)
                  sobj (@ {self})
              (vvarlist_push (l iter) {$in})
              (whileloop 0 0 (iter_hasflat (l iter))
                (letn elt (@ (vvarlist_shift (l iter)))
                  (varhash_setindex (obj_getstr (getslot key var (l elt)))
                    (l into) (nsw (@ (getslot value var (l elt)))))))
              (setbox (l sobj) (l into))
              (newrwlistvar (l sobj)))
        };
    }

    method delete-key($str) {
        Q:CgOp {
            (ternary (obj_is_defined (@ {self}))
              (letn r   (unbox varhash (@ {self}))
                    k   (obj_getstr {$str})
                    old (ternary (varhash_contains_key (l r) (l k))
                                 (varhash_getindex (l k) (l r))
                                 {Any})
                (varhash_delete_key (l r) (l k))
                (l old))
              {Any})
        };
    }

    method perl () { defined(self) ?? '{' ~ @(self).map(*.perl).join(', ') ~ '}' !! self.typename }
}

augment class Any {
    method exists-key($) {
        defined(self) ?? die("Cannot use hash access on an object of type $.typename") !! False
    }
    method delete-key($) {
        defined(self) ?? die("Cannot use hash access on an object of type $.typename") !! Any
    }
}

my class Enum is Cool {
    has $.key;
    has $.value;

    method Capture () {
        Q:CgOp {
            (letn n (obj_newblank (obj_llhow (@ {Capture})))
                  d (varhash_new)
              (setslot positionals (l n) (fvarlist_new))
              (setslot named (l n) (l d))
              (varhash_setindex (obj_getstr {$!key})
                (l d) {$!value})
              (ns (l n)))
        }
    }

    method kv() {
        ($.key, $.value);
    }

    method perl() { defined(self) ?? (self.key.perl ~ ' => ' ~ self.value.perl) !! self.typename }

    method pairs() {
        self.flat;
    }
}

my class Pair is Enum {
}
# }}}
# List utilities {{{
sub _vivify_array_at_pos(\$self, $ix) {
    Q:CgOp { (newvnewarrayvar (class_ref mo Any) {$self} (cast int (obj_getnum {$ix})) (@ {Any})) };
}

sub postcircumfix:<[ ]>(\$container, $index) {
    $container.at-pos($index)
}

sub postcircumfix:<{ }>(\$container, $key, :$exists, :$delete) {
    $exists ?? $container.exists-key($key) !!
    $delete ?? $container.delete-key($key) !!
    $container.at-key($key)
}

my class GatherIterator is IterCursor {
    has $!frame;
    has $!reify;

    method reify() {
        my $*nextframe;
        $!reify // ($!reify = (
            Q:CgOp {
                (letn getv (cotake (cast frame (@ {$!frame})))
                  (box Parcel (ternary (== (@ {EMPTY}) (@ (l getv)))
                    (fvarlist_new)
                    (fvarlist_new
                      (l getv)
                      {GatherIterator.RAWCREATE("frame", $*nextframe, "reify", Any)}))))
            }));
    }
}

sub _gather($fr) {
    &infix:<,>(GatherIterator.RAWCREATE("frame", $fr, "reify", Any)).list
}

sub take(\$p) { # should be \|$p
    Q:CgOp { (take {$p}) }
}

sub infix:<< => >>($k, $v) { Pair.RAWCREATE("key", $k, "value", $v) }

sub reverse(*@arr) {
    my @acc;
    while @arr { @acc.push(@arr.pop) }
    @acc;
}

sub push(@arr, *@stuff) { @arr.push(@stuff) }
sub unshift(@arr, *@stuff) { @arr.unshift(@stuff) }
sub pop(@arr) { @arr.pop }
sub shift(@arr) { @arr.shift }
sub join($tween, *@stuff) { @stuff.join($tween) }

sub invert(%h) { %h.invert }
sub keys(%h) { %h.keys }
sub values(%h) { %h.values }

sub grep($filter, *@items) { grep($filter, @items) }
sub map($callback, *@items) { map($callback, @items) }

sub sort(*@bits) { @bits.sort }

sub _array_constructor(\$parcel) { _array_constructor($parcel) }
sub _hash_constructor(\$parcel)  { my $r := (anon %hash = $parcel); $r }
# }}}
# Regular expression support {{{
my class Cursor {
    method suppose($rx) {
        my $*IN_SUPPOSE = True;
        my $*FATALS = 0;
        my @*WORRIES;
        my %*WORRIES;
        my $*HIGHWATER = -1;
        my $*HIGHEXPECT = {};
        try {
            my $ret = first($rx(self));
            if ($ret) { return $ret }
        };
        return ();
    }
    method O (*%hash) {
        Q:CgOp { (cursor_O (cast cursor (@ {self}))
                           (unbox varhash (@ {%hash}))) }
    }
    method ast () { Q:CgOp { (ns (cursor_ast (cast cursor (@ {self})))) } }
    method list () { @( self.Capture ) }
    method flat () { @( self.Capture ) }
    method iterator () { self.flat.iterator }
    method hash () { %( self.Capture ) }
    method Capture () { Q:CgOp {
        (letn cap (obj_newblank (obj_llhow (@ {Capture})))
          (cursor_unpackcaps (cast cursor (@ {self})) (l cap))
          (newscalar (l cap)))
    } }
    method new($str, $act?) { Q:CgOp { (ns (cursor_start
        (@ {self}) (obj_getstr {$str}) (@ {$act}))) } }
    method pos() { Q:CgOp { (box Num (cast num (cursor_pos
        (cast cursor (@ {self}))))) } }
    method to() { Q:CgOp { (box Num (cast num (cursor_pos
        (cast cursor (@ {self}))))) } }
    method cursor($np) { Q:CgOp { (ns (cursor_butpos
        (cast cursor (@ {self}))
          (cast int (unbox num (@ {$np}))))) } }
    method orig() { Q:CgOp {
        (box Str (cursor_backing (cast cursor (@ {self})))) } }
    method ws() { Q:CgOp { (cursor_dows (cast cursor (@ {self}))) } }
    token alpha { <+INTERNAL::alpha> }
}

my class Match is Cool {
    method list () { @( self.Capture ) }
    method hash () { %( self.Capture ) }
    method flat () { @( self.Capture ) }
    method iterator () { self.flat.iterator }
    method Capture () { Q:CgOp {
        (letn cap (obj_newblank (obj_llhow (@ {Capture})))
          (cursor_unpackcaps (cast cursor (@ {self})) (l cap))
          (newscalar (l cap)))
    } }
    method new($) { die "Match.new NYI" }
    method from() { Q:CgOp { (box Num (cast num (cursor_from
        (cast cursor (@ {self}))))) } }
    method to() { Q:CgOp { (box Num (cast num (cursor_pos
        (cast cursor (@ {self}))))) } }
    method pos() { self.to }
    method orig() { Q:CgOp {
        (box Str (cursor_backing (cast cursor (@ {self})))) } }
    method ast () { Q:CgOp { (ns (cursor_ast (cast cursor (@ {self})))) } }
    method chars() { defined(self) ?? $.to - $.from !! 0 }
    method perl() {
        !defined(self) ?? self.typename !!
        "#<match from({ self.from }) to({ self.to }) text({ self }) pos({ @(self).perl }) named({ %(self).perl })>"
    }
    method synthetic(:$cursor!, :$method!, :@captures!, :$from!, :$to!) {
        Q:CgOp {
            (newscalar (cursor_synthetic
                (cast cursor (@ {$cursor})) (obj_getstr {$method})
                (cast int (obj_getnum {$from}))
                (cast int (obj_getnum {$to}))
                {@captures}))
        };
    }
}

my class Regex is Sub {
    method ACCEPTS($st) {
        Q:CgOp {
            (letn ix   (i 0)
                  str  (obj_getstr {$st})
                  max  (str_length (l str))
                  incr (cursor_start (@ {Cursor}) (l str) (@ {Any}))
                  csr  (null cursor)
                  iter (null vvarlist)
              (whileloop 0 0 (<= (l ix) (l max)) (prog
                (l csr (cursor_butpos (l incr) (l ix)))
                (l ix (+ (l ix) (i 1)))
                (l iter (vvarlist_new_singleton
                    (subcall (@ {self}) (ns (l csr)))))
                (ternary (iter_hasflat (l iter))
                  (letn val (vvarlist_shift (l iter))
                    (set_status (s $*/) (l val))
                    (return (newrwlistvar (@ (l val)))))
                  (prog))))
              (set_status (s $*/) {Match})
              {Any})
        };
    }
}

# used in a few parts of STD until s/// is working
sub _subst($M is rw, $text is rw, $regex, $repl) {
    $text = ~$text;
    $M = ($text ~~ $regex);
    if $M {
        $text = substr($text, 0, $M.from) ~
            (($repl ~~ Str) ?? $repl !! $repl()) ~
                substr($text, $M.to, (chars($text) - $M.to));
    }
    ?$M;
}

sub make($x) { make $x }

my class Grammar is Cursor {
    method parse($text, :$rule = "TOP", :$actions) {
        flat(grep { $_.to == chars $text }, self.new($text, $actions)."$rule"()).head
    }
}
# }}}
# Other operators {{{
constant Inf = 1 / 0;
my class RangeIter is IterCursor {
    has $.current;
    has $.limit;
    has $.exclusive;

    method reify() {
        ($!exclusive ?? ($!current >= $!limit) !! ($!current > $!limit))
            ?? Nil !! ($!current, RangeIter.new(current => $!current + 1,
                    limit => $!limit, exclusive => $!exclusive));
    }
}

my class Range is Cool {
    has $.min;
    has $.max;
    has $.excludes_min = False;
    has $.excludes_max = False;

    method new($min, $max, :$excludes_min = False, :$excludes_max = False) {
        unitem(self.CREATE(min => ($min.^isa(Whatever) ?? -Inf !! $min),
            max => ($max.^isa(Whatever) ?? Inf !! $max),
            :$excludes_min, :$excludes_max));
    }

    method list() { self.iterator.list }
    method flat() { self.iterator.flat }

    method bounds() { $.min, $.max }
    method from() { $.min }
    method to() { $.max }

    method iterator() {
        &infix:<,>(RangeIter.new(:current($!excludes_min ?? $!min + 1 !! $!min),
                      :limit($!max), :exclusive($!excludes_max))).iterator
    }

    method Str() { self.perl }
    method perl() {
        ( $.min.perl,
          ('^' if $.excludes_min),
          '..',
          ('^' if $.excludes_max),
          $.max.perl
        ).join('');
    }

    method ACCEPTS($topic) {
        !defined(self) ?? ($topic.^isa(Range)) !!
        ($topic.^isa(Range) ??
            (($.min == $topic.min)
                && ($.max == $topic.max)
                && ($.excludes_min == $topic.excludes_min)
                && ($.excludes_max == $topic.excludes_min)) !!
            (self!min_test($topic) && self!max_test($topic)))
    }

    method !max_test($topic) {
        $topic < $.max || (!$.excludes_max && !($topic > $.max));
    }

    method !min_test($topic) {
        $.min < $topic || (!$.excludes_min && !($.min > $topic));
    }
}

sub infix:<..> ($a, $b)   { Range.new($a, $b) }
sub infix:<..^> ($a, $b)  { Range.new($a, $b, :excludes_max) }
sub infix:<^..> ($a, $b)  { Range.new($a, $b, :excludes_min) }
sub infix:<^..^> ($a, $b) { Range.new($a, $b, :excludes_min, :excludes_max) }

sub infix:<%%> ($x,$y) { $x % $y == 0 }
sub infix:<?&> ($a, $b) { $a && $b }
sub infix:<?|> ($a, $b) { $a || $b }
sub infix:<?^> ($a, $b) { ?( +$a +^ $b ) }
sub prefix:<?^> ($a) { !$a }
sub prefix:<|> (\$item) { $item.Capture }
sub prefix:<^> ($limit) { 0 ..^ $limit }
sub prefix:<so> ($item) { ?$item }
sub infix:<xx> (\$list, $ct) { map { $list }, ^$ct }
sub prefix:<abs> ($x) { $x > 0 ?? $x !! -$x }
# XXX 'Order' type
sub infix:« <=> » ($a, $b) { $a < $b ?? -1 !! $a > $b ?? 1 !! 0 }
# XXX polymorphic equality
sub infix:<cmp> ($a, $b) { $a leg $b }
sub infix:<eqv> ($a, $b) { $a eq $b }
sub infix:<before> ($a, $b) { $a lt $b }
sub infix:<after> ($a, $b) { $a gt $b }
sub seqop($op) { $op } # TODO: Special case with hyper
sub reverseop($op) { sub (\$x, \$y) { $op($y, $x) } }

sub infix:<%> ($x,$y) { die "Modulus calculation NYI"; } #OK
sub infix:<div> ($x,$y) { die "Modulus calculation NYI"; } #OK
sub infix:<mod> ($x,$y) { die "Modulus calculation NYI"; } #OK
sub infix:<~&> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~|> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~^> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~<» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~>» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub prefix:<~^> ($x) { die "Buffer bitops NYI"; } #OK
sub prefix:<||> (\|$args) { die "Slicels NYI" } #OK
sub postfix:<i> ($item) { die "Complex NYI" } #OK
sub infix:<&> (\|$args) { die "Junctions NYI" } #OK
sub infix:<|> (\|$args) { die "Junctions NYI" } #OK
sub infix:<^> (\|$args) { die "Junctions NYI" } #OK
sub prefix:<sleep> ($x) { die "Asynchronous programming NYI" } #OK
sub infix:<does> ($obj, \$roles) { die "Retyping NYI" } #OK
sub infix:<=:=> (\$a, \$b) { die "Binding checks NYI" } #OK
sub infix:<X> (\|$args) { die "Cross products NYI" } #OK
sub crossop($op) { die "Cross products NYI" } #OK
sub infix:<Z> (\|$args) { die "Zip operators NYI" } #OK
sub zipop($op) { die "Zip operators NYI" } #OK
sub infix:<minmax>(\|$args) { die "minmax NYI" } #OK
sub infix:<...>(\|$args) { die "Series op NYI" } #OK
sub infix:<...^>(\|$args) { die "Series op NYI" } #OK
sub infix:« ==> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« ==>> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <== »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <<== »(\|$args) { die "Feed ops NYI" } #OK
# }}}

# this needs to be at the end because it screws up the parsing of everything
# after it.
sub infix:<,>(\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }

{YOU_ARE_HERE}