CORE.setting

# vim: ft=perl6 fdm=marker
my module CORE;
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 flattens(\$self:) {
        Q:CgOp { (box Bool (var_islist {$self})) }
    }
    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 Stringy() { defined(self) ?? self.Str !! "" }
    method succ() { defined(self) ?? die("cannot increment a value of type {self.typename()}") !! 1 }
    method pred() { defined(self) ?? die("cannot decrement a value of type {self.typename()}") !! -1 }
    method notdef() { !defined(self) }
    method ACCEPTS(\$x) { defined(self) ?? self === $x !! $x.^does(self) }
    method perl() { defined(self) ?? "{self.typename}.new(...)" !! self.typename }
    method so() { ?self }
    method not() { !self }
    method bless($, *%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
    method CREATE() { Q:CgOp { (ns (obj_newblank (obj_llhow (@ {self})))) } }
    method new(*%_) { Q:CgOp { (default_new (@ {self}) (unbox varhash (@ {%_}))) } }
}

my class Any is Mu {
    method flat() { @(self) }
    method Numeric() {
        die "Cannot use value like $.typename as a number" if defined(self);
        0;
    }

    method any() { any @(self) }
    method none() { none @(self) }
    method all() { all @(self) }
    method one() { one @(self) }
    method sort($cmp = &infix:<cmp>) { @(self).sort($cmp) }
    method first(Mu $filter) { for @(self) { return $_ if $_ ~~ $filter } }

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

    method hash() { anon %hash = @(self) }
}

my class Cursor { ... }
my class Regex  { ... }
my class Num    { ... }
my class Str    { ... }
my class Code   { ... }
my class Cool {
    method Rat($eps = 1e-6) { Q:CgOp { (rat_approx {self} {$eps}) } }
    method Int() { Q:CgOp { (coerce_to_int {self}) } }
    method Num() { Q:CgOp { (coerce_to_num {self}) } }
    method abs() { abs self }
    method floor() { floor self }
    method ceiling() { ceiling self }
    method round($scale = 1) { round self, $scale }
    method sqrt() { sqrt self }
    method sign() { sign self }
    method conjugate() { self }

    method grep(Mu $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?, :$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 // Inf;
        my $M;
        while ($i <= chars $str) && ($limctr > 1) {
            $M = head($matchrx($C.cursor($i++)));
            if $M {
                push @out, substr($str, $last, ($M.from - $last));
                push @out, $M if $all;
                $i = $i max ($last = $M.to);
                $limctr = ($limctr - 1);
            }
        }
        push @out, substr($str, $last, (chars($str) - $last));
        @out;
    }
    method subst(\$: $matcher_, $replacement, :g(:$global), :$inplace) {
        my $str = ~self;
        my $C = Cursor.new($str);
        my $matcher = $matcher_ ~~ Regex ?? $matcher_ !! /$matcher_/;
        my $i = 0;
        my $to = 0;
        my $changes = 0;
        my $limctr = $global ?? Inf !! 1;
        my @out;
        while $i < chars($str) && $limctr {
            my $M = head($matcher($C.cursor($i++)));
            if $M && $M.chars {
                Q:CgOp { (rnull (set_status (s '$*/') {$M})) };
                $changes++;
                push @out, substr($str,$to,$M.from-$to);
                push @out, ($replacement ~~ Str ?? $replacement !! $replacement());
                $to = $i = $M.to;
                $limctr = $limctr - 1;
            }
        }
        my $res = join "", @out, substr($str,$to,chars($str)-$to);
        if $inplace {
            self = $res;
            ?$changes;
        } else {
            $res;
        }
    }
    method capitalize() { self.lc.subst(:g, /\w+/, { ucfirst $0 }) }

    method index($substring, $pos?) {
        my $str = ~self;
        my $fromc = defined($pos) ?? ($pos min chars $str) !! 0;
        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?, $limit?, :$match) {
        my $str = ~self;
        my $C = Cursor.new($str);
        my $i = 0;
        $matcher := $matcher // $_char;
        my $limctr = $limit // Inf;
        my @out;
        while ($i < chars $str) && $limctr > 0 {
            my $M = head($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 codes() { chars(self) }
    method bytes() { chars(self) * 2 }
    method chomp() {
        my $s = ~self;
        my $l = chars($s);
        --$l if $l && substr($s, $l-1, 1) eq "\x0A";
        --$l if $l && substr($s, $l-1, 1) eq "\x0D";
        substr($s,0,$l);
    }
    method p5chomp($self is rw:) {
        my $s = ~$self;
        my $l = chars($s);
        my $ol = $l;
        --$l if $l && substr($s, $l-1, 1) eq "\x0A";
        --$l if $l && substr($s, $l-1, 1) eq "\x0D";
        $self = substr($s,0,$l);
        $ol - $l;
    }
    method chop() {
        my $s = ~self;
        substr($s, 0, chars($s) - 1)
    }
    method p5chop($self is rw:) {
        my $str = ~$self;
        return '' if $str eq '';
        my $end = substr($str, chars($str)-1, 1);
        $self = substr($str, 0, chars($str)-1);
        $end;
    }
    method substr(\$str: $start, $len?, $repl?) {
        $start := $start(chars $str) if $start.^does(Code);
        $len := $len.^does(Code) ?? ($len(chars $str) - $start) !!
            $len // (chars($str) - $start);
        defined($repl) ??
            substr($str, $start, $len) = $repl !!
            substr($str, $start, $len)
    }
    method lc()   { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
    method uc()   { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}
    method flip() { Q:CgOp { (box Str (str_flip    (obj_getstr {self}))) }}
    method ucfirst() { ucfirst(self) }
    method lcfirst() { lcfirst(self) }

    method postcircumfix:<[ ]>(\$key) { @(self).[$key] }
    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 Parcel() {
        Q:CgOp { (box Parcel (getslot positionals fvarlist (@ {self}))) }
    }
    method perl() {
        self // return self.typename;
        my $pos = self.Parcel.perl;
        $pos = substr($pos, 2, chars($pos) - 3);
        $pos = substr($pos, 0, chars($pos) - 2) if substr($pos, chars($pos) - 2, 2) eq ', ';
        my $h := self.hash;
        if $h {
            $pos ~= ", " if $pos ne "";
            $pos ~= "|" ~ $h.perl;
        }
        '\(' ~ $pos ~ ')';
    }

    method Capture () { self }
    method item () {
        if self.hash || self.Parcel.raw_elems != 1 {
            die "Can only use .item on captures representing a single value"
        }
        self.Parcel.raw_at(0)
    }
    method list () { @(self.Parcel) }
    method hash () { unitem( Q:CgOp {
        (letn h (getslot named varhash (@ {self}))
          (ternary (== (l h) (null varhash)) {{}} (box Hash (l h))))
    }) }
}
# }}}
# Scalar types {{{
my class Numeric is Cool { }
my class Real is Numeric { }
my class Num is Real {
    our constant pi = 3.14159_26535_89793_238e0;
    our constant e  = 2.71828_18284_59045_235e0;
    our constant i  = sqrt(-1);
    method Num() { self }
    method perl() { defined(self) ?? ~self !! self.typename }
    method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
our constant pi = 3.14159_26535_89793_238e0;
our constant e  = 2.71828_18284_59045_235e0;
our constant i  = sqrt(-1);
my class Int is Real {
    method niecza_quantifier_max() { self }
    method niecza_quantifier_min() { self }
    method Int() { self }
    method perl() { defined(self) ?? ~self !! self.typename }
    method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
my class Rat is Real {
    method new($n,$d) { $n / $d }
    method perl() { defined(self) ?? ~self !! self.typename }
    method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
    method numerator() { Q:CgOp { (rat_nu {self}) } }
    method denominator() { Q:CgOp { (rat_de {self}) } }
    method nude() { [ self.numerator, self.denominator ] }
}
my class Complex is Numeric {
    method new($re,$im) { $re + $im\i }
    method perl() { defined(self) ?? ~self !! self.typename }
    method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
    method re() { Q:CgOp { (complex_re {self}) } }
    method im() { Q:CgOp { (complex_im {self}) } }
    method conjugate() { self.re - (self.im)i }
}
my class FatRat is Real {
    method new($n,$d) { FatRat.succ * $n / $d }
    method perl() { defined(self) ?? ~self !! self.typename }
    method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
    method numerator() { Q:CgOp { (fatrat_nu {self}) } }
    method denominator() { Q:CgOp { (fatrat_de {self}) } }
    method nude() { [ self.numerator, self.denominator ] }
}

my class Str is Cool {
    method ACCEPTS(Mu $t) { defined(self) ?? self eq $t !! $t.^does(self) }
    method chars() { chars(self) }
    method say() { $PROCESS::OUTPUT_USED := 1; 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 = chars(self)-$from) { substr(self, $from, $len) }
    # XXX .trans
    method perl() { defined(self) ?? '"' ~ self ~ '"' !! self.typename }
}

my class Scalar {
}

my class Callable { }
my class Code is Callable {
    has $!outer;
    has $!info;

    method outer() { Q:CgOp { (ns (getslot outer frame (@ {self}))) } }
    method perl() { defined(self) ?? '{ ... }' !! self.typename }
}

my class Block is Code {
    method ACCEPTS(Mu $t) { defined(self) ?? (self)($t) !! $t.^does(self) }
    method count() { Q:CgOp { (count (@ {self})) } }
    method arity() { Q:CgOp { (arity (@ {self})) } }
}

my class Routine is Block {
    # XXX should use outer cap too, but how to remove "self"?
    method assuming(*@_, *%_) { sub (|$_) { self.(|@_, |%_, |$_) } }
    # wrap, unwrap, cando, candidates NYI
}

my class Sub is Routine { }
my class Method is Routine { }
my class Submethod is Routine { }
my class WhateverCode is Block { }

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

# These should be refactored as roles once those become available
my class CommonEnum {
    has $!index;

    method perl()  {
        defined(self) ?? (self.typename ~ "::" ~ self.key) !! self.typename
    }
    method Str()   {
        defined(self) ?? (self.typename ~ "::" ~ self.key) !!
            (self.typename ~ "()")
    }
    method key()   { self.enums._index_to_key($!index) }
    method value() { self.enums._index_to_value($!index) }
    method kv()    { self.key, self.value }
    method pair()  { self.key => self.value }

    method succ() {
        my $index = defined(self) ?? $!index !! 0;
        return self if $index == self.enums - 1;
        self.from-index($index + 1)
    }

    method pred() {
        my $index = defined(self) ?? $!index !! 0;
        $index ?? self.from-index($index - 1) !! self;
    }

    method from-index($ix) { self._create($ix,self.enums._index_to_value($ix)) }

    method postcircumfix:<( )> ($key) {
        self.from-index(self.enums._lookup($key));
    }
}

my class IntBasedEnum is CommonEnum {
    method Numeric() { Q:CgOp { (box Int (unbox int (@ {self}))) } }
    method Int() { self.Numeric }
    method Stringy() { self.key }
    method _create($ix,$val) { Q:CgOp {
        (letn obj (box (@ {self}) (unbox int (@ {$val.Int})))
          (setslot index (@ (l obj)) {$ix.Int})
          (l obj))
    } }
}

my class StrBasedEnum is CommonEnum {
    method Stringy() { Q:CgOp { (box Str (unbox str (@ {self}))) } }
    method _create($ix,$val) { Q:CgOp {
        (letn obj (box (@ {self}) (unbox str (@ {$val.Str})))
          (setslot index (@ (l obj)) {$ix.Int})
          (l obj))
    } }
}

my enum Bool < False True >;
augment class Bool {
    method ACCEPTS(Mu $t) { defined(self) ?? self !! $t.^does(self) }
}
# }}}
# Fundamental scalar operators {{{
sub infix:<~> is Niecza::absprec<r=> is assoc<list> (\|$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) is Niecza::builtin('plus',2,2) { $l + $r }
sub infix:<->($l,$r) is Niecza::builtin('minus',2,2) { $l - $r }
sub infix:<*> is Niecza::builtin('mul',2,2) is Niecza::absprec<u=> ($l,$r) { $l * $r }
sub infix:</> is Niecza::builtin('divide',2,2) is equiv<*> ($l,$r) { $l / $r }
sub infix:<%> is Niecza::builtin('mod',2,2) is equiv<*> ($l,$r) { $l % $r }
sub infix:<**> is Niecza::builtin('pow',2,2)  is Niecza::absprec<w=> is assoc<right> ($l,$r) { $l ** $r }

sub infix:<< == >>($l,$r) is Niecza::builtin('numeq',2,2)
    is Niecza::absprec<m=> is assoc<chain> { $l == $r }
sub infix:<< != >>($l,$r) is Niecza::builtin('numne',2,2)
    is equiv<==> { $l != $r }
sub infix:<< < >>($l,$r)  is Niecza::builtin('numlt',2,2)
    is equiv<==> { $l <  $r }
sub infix:<< > >>($l,$r)  is Niecza::builtin('numgt',2,2)
    is equiv<==> { $l >  $r }
sub infix:<< <= >>($l,$r) is Niecza::builtin('numle',2,2)
    is equiv<==> { $l <= $r }
sub infix:<< >= >>($l,$r) is Niecza::builtin('numge',2,2)
    is equiv<==> { $l >= $r }

sub infix:<max>($a,$b) is Niecza::absprec<k=> is assoc<list> { $a < $b ?? $b !! $a }
sub infix:<min>($a,$b) is Niecza::absprec<k=> is assoc<list> { $a > $b ?? $b !! $a }

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

sub say(*@text)   { $PROCESS::OUTPUT_USED := True; Q:CgOp { (rnull (say   (obj_getstr {@text.join('')}))) }; True }
sub print(*@text) { $PROCESS::OUTPUT_USED := True; Q:CgOp { (rnull (print (obj_getstr {@text.join('')}))) }; True }
sub note(*@text)  { $PROCESS::OUTPUT_USED := True; 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) is Niecza::absprec<i=> is assoc<right> is Niecza::builtin('assign',2,2) { $a = $b }

sub chars($str) is Niecza::builtin('chars',1,1) { chars($str) }
sub substr(\$str, $start, $len?, $repl?) is Niecza::builtin('substr3', 3, 3) {
    $start := $start(chars $str) if $start.^does(Code);
    $len := $len.^does(Code) ?? ($len(chars $str) - $start) !!
        $len // (chars($str) - $start);
    defined($repl) ??
        substr($str, $start, $len) = $repl !!
        substr($str, $start, $len)
}
sub index($haystack,$needle,$pos?) { $haystack.index($needle,$pos) }
sub rindex($haystack,$needle,$pos?) { $haystack.rindex($needle,$pos) }
sub comb($matcher,$str,$limit?,:$match) { (~$str).comb($matcher,$limit,:$match) }
sub split($matcher,$str,$limit?,:$all) { (~$str).split($matcher,$limit,:$all) }

sub item(Mu $x) { $x }

sub prefix:<not> is Niecza::absprec<h=> (Mu $x) { not($x) }
sub defined(Mu $x) is Niecza::builtin('defined',1,1) { defined($x) }

sub prefix:<-->  is Niecza::absprec<x=> ($v is rw) { $v = $v.pred; $v }
sub prefix:<++>  is Niecza::absprec<x=> ($v is rw) { $v = $v.succ; $v }
sub postfix:<--> is Niecza::absprec<x=> ($v is rw) { my $old = $v; $v = $v.pred; $old }
sub postfix:<++> is Niecza::absprec<x=> is Niecza::builtin('postinc',1,1) ($v is rw) { my $old = $v; $v = $v.succ; $old }

sub prefix:<~>(Mu $v) is Niecza::builtin('asstr', 1, 1) { ~$v }
sub prefix:<?>(Mu $v) is Niecza::builtin('asbool', 1, 1) { ?$v }
sub prefix:<->(Mu $v) is Niecza::builtin('negate', 1, 1) { -$v }
sub prefix:<+>(Mu $v) is Niecza::builtin('num', 1, 1) { +$v }
sub prefix:<!>(Mu $v) is Niecza::builtin('not', 1, 1) { !$v }

sub not(Mu $v) is Niecza::builtin('not', 1, 1)    { not($v) }
sub so(Mu $v)  is Niecza::builtin('asbool', 1, 1) { so $v }

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

sub infix:<leg> is Niecza::absprec<n=> is assoc<non> ($s1, $s2) {
    Q:CgOp { (box Num (cast num (strcmp (obj_getstr {$s1}) (obj_getstr {$s2})))) }
}

sub infix:<ge>($s1, $s2) is Niecza::builtin('strge',2,2)
    is equiv<==> { $s1 ge $s2 }
sub infix:<gt>($s1, $s2) is Niecza::builtin('strgt',2,2)
    is equiv<==> { $s1 gt $s2 }
sub infix:<le>($s1, $s2) is Niecza::builtin('strle',2,2)
    is equiv<==> { $s1 le $s2 }
sub infix:<lt>($s1, $s2) is Niecza::builtin('strlt',2,2)
    is equiv<==> { $s1 lt $s2 }
sub infix:<eq>($s1, $s2) is Niecza::builtin('streq',2,2)
    is equiv<==> { $s1 eq $s2 }
sub infix:<ne>($s1, $s2) is Niecza::builtin('strne',2,2)
    is equiv<==> { $s1 ne $s2 }
sub lc($string)    { (~$string).lc }
sub uc($string)    { (~$string).uc }
sub chop($string)  { (~$string).chop }
sub chomp($string) { (~$string).chomp }
sub capitalize($string) { (~$string).capitalize }
sub p5chop(*@strs) { my $r = ''; $r = .p5chop for @strs; $r }
sub p5chomp(*@strs) { my $r = 0; $r += .p5chomp for @strs; $r }
sub flip($string)  { (~$string).flip }
sub lcfirst($o) { my $s = ~$o; lc(substr($s,0,1)) ~ substr($s,1) }
sub ucfirst($o) { my $s = ~$o; uc(substr($s,0,1)) ~ substr($s,1) }
# this one is horribly wrong and only handles the ref eq case.
sub infix:<===>($l,$r) is equiv<==> { Q:CgOp {
    (box Bool (compare == (@ {$l}) (@ {$r})))
} }
sub infix:<=:=>(\$l,\$r) is equiv<==> { Q:CgOp {
    (box Bool (compare == {$l} {$r}))
} }

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

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

sub infix:<~~>($t,$m) is equiv<==> { $m.ACCEPTS($t) }

sub ord($x) { Q:CgOp { (ord {$x}) } }
sub chr($x) { Q:CgOp { (chr {$x}) } }
sub infix:<+&> is Niecza::builtin('numand',2,2) is Niecza::absprec<u=> ($x, $y) { $x +& $y }
sub infix:<+|>($x, $y) is Niecza::builtin('numor',2,2) { $x +| $y }
sub infix:<+^>($x, $y) is Niecza::builtin('numxor',2,2) { $x +^ $y }
sub infix:<< +< >>($x, $y) is Niecza::absprec<u=>
    is Niecza::builtin('numlshift',2,2) { $x +< $y }
sub infix:<< +> >>($x, $y) is Niecza::absprec<u=>
    is Niecza::builtin('numrshift',2,2) { $x +> $y }
sub prefix:<< +^ >>($x) is Niecza::builtin('numcompl',1,1) { +^$x }

# }}}
# 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 dynamic-caller() { Q:CgOp {
        (letn c (frame_dyn_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 subname() { Q:CgOp { (box Str (frame_subname
        (cast frame (@ {self})))) } } 
    method args() { Q:CgOp { (frame_args (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})) } }

my class Label {
    has $!target;
    has $!name;

    method goto() { _lexotic(8, self, ()) }
    method next() { _lexotic(1, self, ()) }
    method last() { _lexotic(2, self, ()) }
    method redo() { _lexotic(3, self, ()) }
}

# XXX multi dispatch
sub _lexotic ($id, $x, Mu $val) {
    Q:CgOp {
        (letn fr (null frame)
              nm (null str)
              id (@ {$x})
          (ternary (obj_isa (l id) (class_ref mo Label))
            (prog (l fr (getslot target frame (l id)))
                  (l nm (getslot name str (l id))))
            (ternary (obj_isa (l id) (class_ref mo Str))
              (l nm (obj_getstr {$x}))
              (prog)))
          (control (cast int (obj_getnum {$id})) (l fr) (int -1) (l nm) {$val}))
    }
}
sub next ($x?) { _lexotic(1, $x, ()) }
sub last ($x?) { _lexotic(2, $x, ()) }
sub redo ($x?) { _lexotic(3, $x, ()) }
sub goto ($x)  { _lexotic(8, $x, ()) }

sub return(\|@pcl) is return-pass { Q:CgOp {
    (control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub succeed(\|@pcl) {
    Q:CgOp { (control 6 (null frame) (int -1) (null str) {@pcl.unwrap-single}) }
}
sub proceed() {
    Q:CgOp { (control 7 (null frame) (int -1) (null str) {()}) }
}
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 callsame () { Q:CgOp { (callnext (null obj)) } }
sub callwith (|$cap) { Q:CgOp { (callnext (@ {$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 head(\$x) { for $x -> Mu $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 }
sub hash(\|@x) { %(@x.unwrap-single) }

my class Whatever {
    method ACCEPTS(Mu $x) { defined(self) || $x.^isa(Whatever) }
}

my class EMPTY { }

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

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

    # LoLly usage
    method raw_elems() { Q:CgOp {
        (box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
    } }
    method raw_at($ix) {
        Q:CgOp { (fvarlist_item (cast int (obj_getnum {$ix})) (unbox fvarlist (@ {self}))) }
    }

    method unwrap-single(@self:) { Q:CgOp {
        (letn p (unbox fvarlist (@ {@self}))
          (ternary (== (i 1) (fvarlist_length (l p)))
            (fvarlist_item (i 0) (l p)) {@self}))
    } }

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

    method perl(\$self:) {
        $self // return $self.typename;
        my @tok;
        push @tok, '$' if !$self.flattens;
        push @tok, '(';
        loop (my $i = 0; $i < $self.raw_elems; $i++) {
            push @tok, self.raw_at($i).perl;
            push @tok, ', ' unless $i == $self.raw_elems - 1 && $i;
        }
        push @tok, ')';
        @tok.join;
    }

    method elems  () { + @(self) }
    method Numeric() { + @(self) }
    method Str    () { ~ @(self) }
    method Bool   () { ? @(self) }
}

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(\$self:) {
        $self // return $self.typename;
        my @tok;
        push @tok, '(';
        push @tok, .perl, ', ' for @$self;
        pop @tok if @tok >= 5;
        push @tok, ').list';
        push @tok, '.item' if !$self.flattens;
        @tok.join
    }

    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:<cmp>) {
        my $cmp = $cmp_;
        if $cmp_.count == 1 {
            $cmp = sub (\$x, \$y) { $cmp_($x) cmp $cmp_($y) }
        }
        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 reverse() { reverse( @(self) ); }

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

    method kv() { my $i = 0; self.map({ $i++, $_ }) }
}

my class Array is List {
    method perl(\$self:) {
        $self // return $self.typename;
        "[" ~ $self.map(*.perl).join(', ') ~ "]" ~ ($self.flattens ?? ".list" !! "");
    }
}

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

    method any() { any self.keys }
    method none() { none self.keys }
    method all() { all self.keys }
    method one() { one self.keys }

    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 { (hash_keys   {self}) } }
    method values() { Q:CgOp { (hash_values {self}) } }
    method pairs()  { Q:CgOp { (hash_pairs  {self}) } }
    method list()   { Q:CgOp { (hash_pairs  {self}) } }
    method kv()     { Q:CgOp { (hash_kv     {self}) } }

    method Numeric() { +@(self) }
    method Str() { @(self).map(* ~ "\n").join }

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

    # Rakudo extensions compatibility - DO NOT USE
    method delete($key) { self.{$key}:delete }
    method exists($key) { self.{$key}:exists }

    method perl(\$self:) {
        $self // return $self.typename;
        '{' ~ @($self).map(*.perl).join(', ') ~ '}' ~
            ($self.flattens ?? ".hash" !! "")
    }
}

my class Enum is Cool {
    has $.key;
    has Mu $.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 {
    method Str() {
        $.key ~ "\t" ~ $.value
    }
}

# XXX This ought to be more read-only
my class EnumMap {
    has %!by-key;
    has %!by-value;
    has @!values;
    has @!keys;

    method new(*@pairs) {
        self := self.bless(*);
        my $last = -1;
        my $ixn = 0;
        for @pairs -> $p {
            my ($k, $v);
            if $p ~~ Pair {
                $k ::= $p.key;
                $v ::= $p.value;
            } else {
                $k ::= $p;
                $v ::= $last.succ;
            }
            $last = $v;
            %!by-key{$k} = $ixn;
            %!by-value{$v} //= $ixn;
            push @!keys, $k;
            push @!values, $v;
            $ixn++;
        }
        unitem(self);
    }

    method Numeric() { +@!keys }
    method _index_to_key($i) { @!keys[$i] }
    method _index_to_value($i) { @!values[$i] }
    method _lookup($w) {
        %!by-key{$w} // %!by-value{$w} // die "No match"
    }
    method iterator() { self.list.iterator }
    method list() { @!keys Z=> @!values }
    method hash() { %!by-key }
    method keys() { @!keys }
    method values() { @!values }
    method invert() { @!values Z=> @!keys }
    method kv() { @!keys Z @!values }
    method pairs() { self.list }
    method postcircumfix:<{ }>(\$k) { @!values[%!by-key.{$k}] }
}

my class Junction is Mu {
    has $!kind_;
    has $!eigenstates_;

    method !create($kind, $eigenstates) { Q:CgOp {
        (letn ob (obj_newblank (obj_llhow (@ {self})))
          (setslot kind_ (l ob) (@ {$kind}))
          (setslot eigenstates_ (l ob) (@ {$eigenstates}))
          (ns (l ob)))
    } }
    method !kind() { Q:CgOp { (ns (getslot kind_ obj (@ {self}))) } }
    method !eigenstates() { Q:CgOp { (ns (getslot eigenstates_ obj (@ {self}))) } }

    my @kinds = <all none one any>;
    method perl() {
        defined(self) ?? (@kinds[self!kind] ~ "(" ~
            join(", ", map -> Mu $x { $x.perl }, @$!eigenstates) ~ ")") !! "Junction"
    }

    method Str() { defined(self) ?? self.perl !! "Junction()" }
    method Stringy() { self.FALLBACK("Stringy") }

    method from-parcel(Int $kind, Mu $pcl) {
        self!create($kind, $pcl)
    }

    method ACCEPTS(Mu \$other) {
        defined(self) ??
            ?(self.FALLBACK("ACCEPTS", $other)) !!
            $other.^isa(self)
    }
}
sub infix:<&> is Niecza::absprec<q=> is assoc<list>
    (\|$p) { Junction.from-parcel(0, $p) }
sub infix:<^> is Niecza::absprec<p=> is assoc<list>
    (\|$p) { Junction.from-parcel(2, $p) }
sub infix:<|> is Niecza::absprec<p=> is assoc<list>
    (\|$p) { Junction.from-parcel(3, $p) }
sub all  (*@p) { all @p }
sub none (*@p) { none @p }
sub one  (*@p) { one @p }
sub any  (*@p) { any @p }
# }}}
# 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, *%adverbs) {
    $container.postcircumfix:<[ ]>($index, |%adverbs)
}

sub postcircumfix:<{ }>(\$container, $index, *%adverbs) {
    $container.postcircumfix:<{ }>($index, |%adverbs)
}

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.new(frame => $*nextframe)}))))
            }));
    }
}

sub _gather($fr) {
    &infix:<,>(GatherIterator.new(frame => $fr)).list
}

sub take(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }

sub infix:<< => >>($k, Mu $v) is equiv<=>
    is Niecza::builtin('pair', 2, 2) { $k => $v }

sub reverse(*@array) {
    my @acc;
    push @acc, pop(@array) while @array;
    @acc;
}

sub push(@array, *@stuff) is Niecza::builtin('push', 1) { @array.push(@stuff) }
sub unshift(@array, *@stuff) is Niecza::builtin('unshift', 1) { @array.unshift(@stuff) }
sub pop(@array) is Niecza::builtin('pop', 1, 1) { @array.pop }
sub shift(@array) is Niecza::builtin('shift', 1, 1) { @array.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(Mu $filter, *@items) is Niecza::builtin('grep',1) { grep($filter, @items) }
sub map($callback, *@items) is Niecza::builtin('map',1) { map($callback, @items) }

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

sub first(Mu $test, *@bits) { @bits.first($test) }

sub _array_constructor(\$parcel) is Niecza::builtin('array_constructor', 1,
    1) { _array_constructor($parcel) }
sub _hash_constructor(\$parcel)  { my $r := (anon %hash = $parcel); $r }
sub _make_capture(|$c) { $c }

sub _newtiedscalar(Mu $type, $bind, $fetch, $store) {
    Q:CgOp { (var_new_tied (obj_llhow (@ {$type})) (@ {$bind}) (@ {$fetch}) (@ {$store})) }
}

sub infix:<X>(\|$pcl) is Niecza::absprec<f=> is assoc<list> {
    Q:CgOp { (cross (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub infix:<Z>(\|$pcl) is equiv<X> {
    Q:CgOp { (zip (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub zipop(\|$pcl) {
    Q:CgOp { (zip (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub crossop(\|$pcl) {
    Q:CgOp { (cross (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub reduceop($triangle, $list, $right, $chain, $func, *@items) {
    if $triangle {
        if $chain {
            gather {
                my $ok = True;
                if @items {
                    take True;
                    my Mu $last = shift @items;
                    while @items {
                        my Mu $next = shift @items;
                        my Mu $val ::= ($ok &&= $func($last, $next));
                        take $val;
                        $last = $next;
                    }
                }
            }
        }
        elsif $list {
            my @pool;
            gather {
                while @items {
                    push @pool, shift @items;
                    take reduceop(False, $list, $right, $chain, $func, @pool);
                }
            }
        }
        elsif $right {
            gather {
                while @items >= 2 {
                    my Mu $right ::= pop @items;
                    take $right;
                    my Mu $left  = pop @items;
                    push @items, $func($left,$right);
                }
                if @items {
                    my Mu $last ::= shift @items;
                    take $last;
                }
            }
        }
        else { # left assoc 
            gather {
                if @items {
                    my Mu $cumu ::= shift @items;
                    take $cumu;
                    while @items {
                        my Mu $new ::= ($cumu ::= $func($cumu, shift @items));
                        take $new;
                    }
                }
            }
        }
    }
    else {
        if $list {
            $func(|@items);
        }
        elsif $chain {
            my $ok = True;
            while @items >= 2 {
                $ok &&= $func(@items[0], @items[1]);
                shift @items;
            }
            $ok;
        }
        elsif $right {
            while @items >= 2 {
                my Mu $r = pop @items;
                my Mu $l = pop @items;
                push @items, $func($l,$r);
            }
            @items ?? @items[0] !! 0; # XXX identity
        }
        else { # left
            while @items >= 2 {
                my Mu $l = shift @items;
                my Mu $r = shift @items;
                unshift @items, $func($l,$r);
            }
            @items ?? @items[0] !! 0; # XXX identity
        }
    }
}
# }}}
# 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 = head($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 (obj_getnum {$np})))) } }
    method orig() { Q:CgOp {
        (box Str (cursor_backing (cast cursor (@ {self})))) } }
    method ws() { Q:CgOp { (cursor_dows (cast cursor (@ {self}))) } }
    method CURSOR() { self }
    token alpha { <+INTERNAL::alpha> } #OK
}

my class Match is Cool {
    method ACCEPTS($) { self // nextsame }
    method list () { @( self.Capture ) }
    method hash () { %( self.Capture ) }
    method flat () { @( self.Capture ) }
    method iterator () { self.flat.iterator }
    method Numeric() { +(~self) }
    method keys () { keys %(self) }
    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 CURSOR() { Q:CgOp { (ns (cursor_unmatch (cast cursor (@ {self})))) } }
    method cursor() { Q:CgOp { (ns (cursor_unmatch (cast cursor (@ {self})))) } }
    method reduced() { Q:CgOp { (box Str (cursor_reduced (cast cursor (@ {self})))) } }
    method synthetic(:$cursor!, :$method!, :@captures!, :$from!, :$to!) {
        my $*match;
        Q:CgOp {
            (prog
              (cursor_synthetic
                (cast cursor (@ {$cursor})) (obj_getstr {$method})
                (cast int (obj_getnum {$from}))
                (cast int (obj_getnum {$to}))
                {@captures})
              {$*match})
        };
    }
}

my class Regex is Method {
    method Bool() {
        return False unless defined self;
        my $fr = caller;
        # Hack - skip ExitRunloop frame
        $fr = $fr.caller unless $fr.line;
        Q:CgOp {
            (letn res {self.ACCEPTS($fr.hints('$_'))}
              (set_status (s $*/) {$/})
              (asbool (l res)))
        };
    }

    method ACCEPTS($st) {
        return $st.^does(self) unless defined self;
        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))) (l val)))
                  (prog))))
              (set_status (s $*/) {Match})
              {Match})
        };
    }
}

sub make($x) is Niecza::builtin('make', 1, 1) { make $x }

my class Grammar is Cursor {
    method parse($text, :$rule = "TOP", :$actions) {
        my $match = (head grep { $_.to == chars $text },
            self.new($text, $actions)."$rule"()) // self;
        Q:CgOp { (rnull (set_status (s '$*/') {$match})) };
        $match;
    }
}
# }}}
# Other operators {{{
# TODO: these should be macros
sub WHAT(Mu $x) { $x.WHAT }
sub HOW(Mu $x) { $x.HOW }
constant Inf = 1 / 0;
my class RangeIter is IterCursor {
    has $.current;
    has $.limit;
    has $.exclusive;

    method reify() {
        my $c = $!current;
        my $cmp = $c cmp $!limit;
        ($cmp < 0) ?? ($c, RangeIter.new(current => $c.succ,
                    limit => $!limit, exclusive => $!exclusive)) !!
        ($cmp > 0 || $!exclusive) ?? Nil !!
            ($c,);
    }
}

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.bless(*, 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.succ !! $!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 niecza_quantifier_min() {
        ($!min == -Inf ?? 0 !! $!min + $!excludes_min)
    }

    method niecza_quantifier_max() {
        ($!max == Inf ?? 2_147_483_647 !! $!max - $!excludes_max)
    }

    method !max_test($topic) {
        $topic before $.max || (!$.excludes_max && !($topic after $.max));
    }

    method !min_test($topic) {
        $.min before $topic || (!$.excludes_min && !($.min after $topic));
    }
}

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

sub _hyper_type($val) {
    #FIXME rewrite using roles
    given $val {
        when Hash { return 1 }
        when List { return 2 }
        when Parcel { return 2 }
        when Range { return 2 }
        default { return 0 }
    }
}

sub hyperunary(&fun, \$obj) {
    given _hyper_type($obj) {
        when 1 {
            my %out;
            for $obj.kv -> $k, \$v {
                %out{$k} = hyperunary(&fun, $v);
            }
            return %out;
        }
        when 2 {
            my @out;
            push @out, $( hyperunary(&fun, $_) ) for @$obj;
            return @out;
        }
        when 3 {
            my @out;
            push @out, $( hyperunary(&fun, $_) ) for @$obj;
            return $obj.new(@out);
        }
        when 0 {
            return fun($obj);
        }
    }
}

sub _hyper_hash($dwiml, $dwimr, $fun, $left, $right) {
    my %keys;
    for $left.keys {
        %keys{$_} = True if !$dwiml || ($right{$_}:exists);
    }
    for $right.keys {
        %keys{$_} = True if !$dwimr || ($left{$_}:exists);
    }
    for %keys.keys {
        %keys{$_} = hyper($dwiml, $dwimr, $fun, $left{$_}, $right{$_});
    }
    %keys
}

sub _hyper_posi($dwiml, $dwimr, $fun, $left, $right) {
    my $lex = $left[*-1] ~~ Whatever;
    my $rex = $right[*-1] ~~ Whatever;
    my @out;
    my $ix = 0;
    loop {
        my $lend; my $lv; my $rend; my $rv;
        if $ix >= ($lex ?? $left - 1 !! $left) {
            $lend = True;
            $lv := $left[$lex ?? $left - 2 !! $left ?? $ix % $left !! 0];
        } else {
            $lv := $left[$ix];
        }
        if $ix >= ($rex ?? $right - 1 !! $right) {
            $rend = True;
            $rv := $right[$rex ?? $right - 2 !! $right ?? $ix % $right !! 0];
        } else {
            $rv := $right[$ix];
        }
        last if $lend && $rend;
        die "Ran off end of non-dwimmy left" if $lend && !$dwiml && !$dwimr;
        die "Ran off end of non-dwimmy right" if $rend && !$dwiml && !$dwimr;
        last if $lend && !$dwiml;
        last if $rend && !$dwimr;
        push @out, $( hyper($dwiml, $dwimr, $fun, $lv, $rv) );
        $ix++;
    }
    @out;
}

sub hyper($dwiml, $dwimr, $fun, \$left, \$right) {
    constant @htnames = 'scalar', 'Associative', 'Positional', #OK
        'non-Positional Iterable';
    my $h1 = _hyper_type($left);
    my $h2 = _hyper_type($right);

    if $h1 && $h2 && $h1 != $h2 {
        die "Cannot mix @htnames[$h1] and @htnames[$h2] in hyperop";
    }

    if $h2 == 0 || $h1 == 0 {
        if $h1 == 0 && $h2 == 0 { return $fun($left, $right) }
        if $h2 {
            if $dwiml {
                return hyperunary(sub (\$x) { $fun($left,$x) }, $right);
            }
        } else {
            if $dwimr {
                return hyperunary(sub (\$x) { $fun($x,$right) }, $left);
            }
        }
        die "Non-dwimmy scalar used with complex item";
    }

    given $h1 {
        when 1 { return _hyper_hash($dwiml, $dwimr, $fun, $left, $right) }
        when 2 { return _hyper_posi($dwiml, $dwimr, $fun, @$left, @$right) }
        when 3 { die "Cannot hyper two unordered collections" }
    }
}

# tweaked from Rakudo
our sub Niecza::generate-series(@lhs, $rhs, :$exclude-limit) {
    my sub get-next-closure (@lhs, $limit? ) {
        die "Need something on the LHS" unless @lhs.elems;
        die "Need more items on the LHS" if @lhs[*-1] ~~ Code && @lhs[*-1].count != Inf && @lhs.elems - 1 < @lhs[*-1].arity;

        #BEWARE: Here be ugliness
        if @lhs[* - 1] ~~ Code { # case: (a,b,c,{code}) ... *
            return @lhs[*-1];
        }
        return { .succ } if @lhs.elems == 1 && $limit ~~ Code;
        return { $_ } if @lhs.elems > 1 && @lhs[*-1] cmp @lhs[*-2] == 0 ;  # case: (a , a) ... *

        if  @lhs[*-1] ~~ Str || $limit ~~ Str {
            if @lhs[*-1].chars == 1 && $limit.defined && $limit.chars == 1 {
                return { .ord.succ.chr } if @lhs[*-1] lt  $limit;# case (... , non-number) ... limit
                return { .ord.pred.chr } if @lhs[*-1] gt  $limit;# case (... , non-number) ... limit
            }
            return { .succ } if $limit.defined && @lhs[*-1] lt  $limit;# case (... , non-number) ... limit
            return { .pred } if $limit.defined && @lhs[*-1] gt  $limit;# case (... , non-number) ... limit
            return { .pred } if @lhs.elems > 1 && @lhs[*-2] gt  @lhs[*-1];# case (non-number , another-smaller-non-number) ... *
            return { .succ } ;# case (non-number , another-non-number) ... *
        }
        return { .pred } if @lhs.elems == 1 && $limit.defined && $limit before @lhs[* - 1];  # case: (a) ... b where b before a
        return { .succ } if @lhs.elems == 1 ;  # case: (a) ... *

        my $diff = @lhs[*-1] - @lhs[*-2];
        return { $_ + $diff } if @lhs.elems == 2 || @lhs[*-2] - @lhs[*-3] == $diff ; #Case Arithmetic series

        if @lhs[*-2] / @lhs[*-3] == @lhs[*-1] / @lhs[*-2] { #Case geometric series
            my $factor = @lhs[*-2] / @lhs[*-3];
            if $factor ~~ Rat && $factor.denominator == 1 {
                $factor = $factor.Int;
            }
            return { $_ * $factor } ;
        }
        die "Unable to figure out pattern of series";
    }

    my sub infinite-series (@lhs, $limit ) {
        gather {
            my $i = 0;
            while @lhs[$i+1].defined { take @lhs[$i]; $i++; } #We blindly take all elems of the LHS except last one.
            if @lhs[$i] !~~ Code { take @lhs[$i]; $i++; }     #We take the last element only when it is not code

            my $next = get-next-closure(@lhs , $limit );
            my $arity = $next.count;
            my @args=@lhs[$i-($arity ~~ Inf ?? $i !! $arity) .. $i-1]; #We make sure there are $arity elems in args

            loop {                         #Then we extrapolate using $next and the $args
                my $current = $next.(|@args) // last;
                take $current ;
                if $arity {
                    @args.push($current) ;
                    @args.shift if @args.elems > $arity
                }
            }
        }
    }

    my $limit = ($rhs ~~ Whatever ?? Any !! $rhs);
    return infinite-series(@lhs , $limit) if $rhs ~~ Whatever; #shortcut infinite series so we avoid the comparisions

    my $series = infinite-series(@lhs , $limit);

    gather {
        if $limit ~~ Code && $limit.count > 1 {
            my @limit-args;
            while $series {
                @limit-args.shift if @limit-args == $limit.count;
                my $val = $series.shift;
                @limit-args.push($val);
                my $done = @limit-args >= $limit.arity && $limit(|@limit-args);
                take $val unless $done && $exclude-limit;
                last if $done;
            }
        }
        else {
            while $series {
                my $val = $series.shift();
                if $val ~~ $limit {
                    take $val unless $exclude-limit ;
                    last ;
                };
                take $val;
            }
        }
    }
}

our sub Niecza::series-listop(Parcel $lists, $exclude-limit) {
    if $lists.raw_elems <= 1 { return unitem($lists) }
    my @l := ( $lists.raw_at($lists.raw_elems - 1), ).flat;
    loop (my $i = $lists.raw_elems - 2; $i >= 0; $i = $i - 1) {
        @l || die "Need something on the RHS";
        my @mo := &Niecza::generate-series(($lists.raw_at($i),).flat, @l.shift,
            :$exclude-limit);
        @l := ( @mo, @l ).flat;
    }
    @l
}

sub infix:<%%> is Niecza::absprec<u=> ($x,$y) { $x % $y == 0 }
sub infix:<?&> is Niecza::absprec<u=> ($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> is Niecza::absprec<h=> (Mu $item) { ?$item }
sub infix:<xx> is Niecza::absprec<s=> (\$list, $ct) { map { $list }, ($ct ~~ Whatever) ?? ^Inf !! ^$ct }
sub prefix:<abs> ($x) { Q:CgOp { (abs {$x}) } }
sub abs($x) { Q:CgOp { (abs {$x}) } }
sub floor($x) { Q:CgOp { (floor {$x}) } }
sub ceiling($x) { -floor(-$x) }
sub conjugate($x) { $x.conjugate }
sub round($x, $scale=1) { floor($x / $scale + 0.5) * $scale }
sub truncate($x) { $x.Int }
sub sign($x) { $x < 0 ?? -1 !! $x > 0 ?? 1 !! 0 }
sub sqrt($x) { Q:CgOp { (sqrt {$x}) } }
# XXX 'Order' type
sub infix:« <=> » is equiv<leg> ($a, $b) { $a < $b ?? -1 !! $a > $b ?? 1 !! 0 }
# XXX polymorphic equality
sub infix:<cmp> is equiv<leg> ($a, $b) {
    return $a - $b if $a ~~ Numeric && $b ~~ Numeric;
    return $a.WHAT leg $b.WHAT unless $a.WHAT === $b.WHAT;
    return $a leg $b if $a ~~ Str;
    return $a - $b;
}
sub infix:<eqv> is equiv<==> ($a, $b) { ($a cmp $b) == 0 }
sub infix:<before> ($a, $b) is equiv<==> { ($a cmp $b) < 0 }
sub infix:<after> ($a, $b) is equiv<==> { ($a cmp $b) > 0 }
sub seqop($op, \$x, \$y) { $op($x,$y) } # TODO: Special case with hyper
sub reverseop($op, \$x, \$y) { $op($y, $x) }

sub infix:<div> is Niecza::absprec<u=> ($x,$y) { Q:CgOp { (divop (i 4) {$x} {$y}) } }
sub infix:<mod> is Niecza::absprec<u=> ($x,$y) { Q:CgOp { (divop (i 5) {$x} {$y}) } }
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> is Niecza::absprec<y=> ($item) { $item * i }
sub prefix:<sleep> ($x) { die "Asynchronous programming NYI" } #OK
sub infix:<does> ($obj, \$roles) { die "Retyping NYI" } #OK
sub infix:<minmax> is equiv<X> (\|$args) { die "minmax NYI" } #OK
sub infix:<...> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, False) }
sub infix:<...^> is equiv<X> (\|$lists) { &Niecza::series-listop($lists, True) }
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

sub eval($str) is return-pass { Q:CgOp { (simple_eval {$str}) } }

sub rungather($ ) { die "Run NYI" }
# }}}

# I/O stuff {{{
sub slurp($path) is unsafe { Q:CgOp { (box Str (slurp (unbox str (@ {$path})))) } }

sub spew($path,$text) is unsafe { Q:CgOp { (rnull (spew (unbox str (@ {$path.Str})) (unbox str (@ {$text.Str})))) } }

my class Instant {
    has $.val;
    method to-posix() { ($!val, False) }
}
sub term:« now »() {
    Instant.new( val => Q:CgOp { (now) } );
}
sub times() { Q:CgOp { (times) } }
sub term:« time »() { Q:CgOp { (now) } }
sub term:« rand »() { Q:CgOp { (rand) } }

my class IO {
    has $.path; # Str

    method Str() { $.path }
    method IO() { self }

    method slurp() { slurp $.path }
    method spew($text) { spew $.path, $text }

    method combine(*@paths) {
        die "Sorry, paths do not form a monoid." unless @paths;
        my $acc = shift(@paths).IO;
        for @paths { $acc = $acc.append($_) }
        $acc
    }

    method perl() { $.path.perl ~ ".IO" }

    method f() is unsafe { Q:CgOp { (box Bool (path_file_exists (obj_getstr {$!path}))) } }
    method d() is unsafe { Q:CgOp { (box Bool (path_dir_exists (obj_getstr {$!path}))) } }
    method e() is unsafe { Q:CgOp { (box Bool (path_any_exists (obj_getstr {$!path}))) } }
    method relative($base) { $base.IO.append(self) }
    method append($sub) { Q:CgOp { (box Str (path_combine (obj_getstr {self}) (obj_getstr {$sub}))) }.IO }
    method but-extension($ext) { Q:CgOp { (box Str (path_change_ext (obj_getstr {self}) (obj_getstr {$ext}))) }.IO }
    method realpath() is unsafe { Q:CgOp { (box Str (path_realpath (obj_getstr {self}))) }.IO }
    method modified() is unsafe { Instant.new(val => Q:CgOp { (path_modified (obj_getstr {self})) }) }
}

augment class Str {
    method IO() { IO.new(path => self) }
}

my class TextWriter {
    method say(*@bits) { say @bits }
    method print(*@bits) { print @bits }
}

my class TextReader {
    method get() {
        Q:CgOp {
            (letn line (treader_getline (unbox treader (@ {self})))
              (ternary (== (l line) (null str)) {Str} (box Str (l line))))
        };
    }

    method slurp() {
        Q:CgOp { (box Str (treader_slurp (unbox treader (@ {self})))) }
    }

    method getc() {
        Q:CgOp {
            (letn chi (treader_getc (unbox treader (@ {self})))
              (ternary (>= (l chi) (int 0))
                (box Str (str_chr (l chi)))
                {Str}))
        };
    }

    method lines() {
        gather take my $l while ($l = self.get).defined;
    }
}

# the following class stolen from Rakudo, but butchered
class IO::ArgFiles {
    has $!args;
    has $!reader;

    method lines() {
        gather take my $l while ($l = self.get).defined;
    }

    method get() {
        unless defined $!args {
            $!args = [ @*ARGS ];
            $!reader = $*IN unless $!args;
        }
      again:
        $!reader //= open(shift($!args) // return Str);
        if defined my $line = $!reader.get {
            return $line;
        } else {
            $!reader = Any;
            goto again;
        }
    }
}
sub open($filename) is unsafe {
    Q:CgOp { (box TextReader (treader_open (obj_getstr {$filename}))) }
}

# TODO $*ARGFILES, multi
sub get($handle = $*IN) { $handle.get }
sub lines($filehandle = $*IN) { $filehandle.lines }
sub prompt($msg) { print $msg; $*IN.get }
sub getc($handle) { $handle.getc }

INIT {
    $PROCESS::IN ::= Q:CgOp { (box TextReader (treader_stdin)) };
    $PROCESS::OUT ::= TextWriter.new;
    $PROCESS::ARGFILES ::= IO::ArgFiles.new;
    @PROCESS::ARGS = Q:CgOp { (sysquery (i 0)) };
    %PROCESS::ENV = Q:CgOp { (sysquery (i 4)) };
    $PROCESS::EXECUTABLE_NAME ::= Q:CgOp { (sysquery (i 2)) };
    $PROCESS::PROGRAM_NAME ::= Q:CgOp { (sysquery (i 1)) };
    $PROCESS::BASE_DIRECTORY ::= Q:CgOp { (sysquery (i 3)) };
}
# }}}

# This needs to be at the end because it screws up the parsing of everything
# after it.
sub infix:<,> is Niecza::builtin('comma',0) is Niecza::absprec<g=> is assoc<list> (\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }

{YOU_ARE_HERE}