setting

# vim: ft=perl6

# XXX fakes out STD.pm6 into doing more or less the right thing
# need to understand this better
my class CORE { ... }

# We have to do this directly due to the circularity saw.  Same
# reason forces uncontainerized .NET values.
#
# class ClassHOW {
#     has DynMetaObject $.meta-object;
# }
#
# Due to concerns of screwing up composition, adding new superclasses, roles,
# or attributes in an augment is not allowed at this time.  Methods only.
#
# to create a class:
#     BEGIN my $Foo_HOW ::= ClassHOW.new("Foo");
#     BEGIN my $Foo;
#     BEGIN {
#         $Foo_HOW.add-super(...);
#         $Foo_HOW.add-role(...);
#         $Foo_HOW.add-method("bar", anon method bar { ... });
#         $Foo_HOW.compose;
#         $Foo ::= $Foo_HOW.create-protoobject;
#     }
#
# to augment:
#     BEGIN { $Foo_HOW.add-method("baz", anon method baz { ... }); }
my class ClassHOW { ... }

PRE-INIT {
    # ClassHOW.new($name) --> meta class instance
    sub new { Q:CgOp {
        (prog
          [lextypes $mo DynMetaObject $self DynObject]
          [l $mo   (rawnew DynMetaObject (unwrap String (@ (pos 1))))]
          [l $self (rawnew DynObject (getfield klass
            (cast DynObject (@ (pos 0)))))]

          [setfield how (l $mo) (l $self)]
          [setindex meta-object (getfield slots (l $self))
            (nsw (rawnew CLRImportObject (l $mo)))]

          [ns (l $self)])
    } }

    # $how.add-super($how)
    sub add-super { Q:CgOp { (prog
        [rawcall
          (getfield superclasses (unwrap DynMetaObject
            (getattr meta-object (@ (pos 0))))) Add
          (unwrap DynMetaObject (getattr meta-object (@ (pos 1))))]
        [null Variable])
    } }

    # $how.add-method($name, $sub)
    sub add-method { Q:CgOp {
        (prog
          [setindex (unwrap String (@ (pos 1)))
            (getfield local (unwrap DynMetaObject (getattr meta-object
              (@ (pos 0)))))
            (@ (pos 2))]

          [null Variable])
    } }

    # $how.create-protoobject()
    sub create-protoobject { Q:CgOp {
        (prog
          [lextypes $p DynObject $mo DynMetaObject]
          [l $mo (unwrap DynMetaObject (getattr meta-object (@ (pos 0))))]
          [l $p (rawnew DynObject (l $mo))]

          [rawcall (l $mo) BuildC3MRO]

          [setfield slots (l $p) (null Dictionary<string,object>)]
          [setfield typeObject (l $mo) (l $p)]

          [newscalar (l $p)])
    } }

    sub compose { Q:CgOp { (null Variable) } }

    Q:CgOp {
        (prog
          [lextypes $chmo DynMetaObject $chch Variable]
          [l $chmo (rawnew DynMetaObject (clr_string "ClassHOW"))]
          [l $chch (ns (rawnew DynObject (l $chmo)))]

          [setfield how (l $chmo) (@ (l $chch))]
          [setindex meta-object (getfield slots (cast DynObject (@ (l $chch))))
            (w (l $chmo))]

          [sink (subcall (@ (l &add-method)) (l $chch)
            (wrap (clr_string "new")) (l &new))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (wrap (clr_string "add-method")) (l &add-method))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (wrap (clr_string "add-super")) (l &add-super))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (wrap (clr_string "compose")) (l &compose))]
          [sink (subcall (@ (l &add-method)) (l $chch)
            (wrap (clr_string "create-protoobject")) (l &create-protoobject))]

          [l ClassHOW (subcall (@ (l &create-protoobject)) (l $chch))]
          [l ClassHOW!HOW (l $chch)]

          [null Variable])
    }
}

# cannot be a normal class - it has no parents
my class Mu { ... }
my class Any { ... }
my class Cool { ... }
# these are really defined in the kernel
my class Scalar { ... }
my class Sub { ... }
PRE-INIT {
    # (DynMetaObject $dmo, ClassHOW $super --> ClassHOW)
    sub wrap-dpmo { Q:CgOp {
        (prog
          [lextypes $ch Variable $dm DynMetaObject]
          [l $ch (methodcall (l ClassHOW) new (w (clr_string "")))]
          [l $dm (unwrap DynMetaObject (@ (pos 0)))]

          [assign (varattr meta-object (@ (l $ch))) (w (l $dm))]
          [setfield how (l $dm) (@ (l $ch))]
          [sink (methodcall (l $ch) add-super (pos 1))]
          [l $ch])
    } }

Q:CgOp {
    (prog
      [lextypes !plist List<DynMetaObject>]

      [l Mu!HOW (methodcall (l ClassHOW) new (w (clr_string Mu)))]
      [l Mu (methodcall (l Mu!HOW) create-protoobject)]

      [l Any!HOW (methodcall (l ClassHOW) new (w (clr_string Any)))]
      [sink (methodcall (l Any!HOW) add-super (l Mu!HOW))]
      [l Any (methodcall (l Any!HOW) create-protoobject)]

      [l Cool!HOW (methodcall (l ClassHOW) new (w (clr_string Cool)))]
      [sink (methodcall (l Cool!HOW) add-super (l Any!HOW))]
      [l Cool (methodcall (l Cool!HOW) create-protoobject)]

      [sink (methodcall (l ClassHOW!HOW) add-super (l Any!HOW))]
      [rawcall (getfield klass (cast DynObject (@ (l ClassHOW)))) BuildC3MRO]

      [l Sub!HOW (subcall (@ (l &wrap-dpmo))
        (w (rawsget Kernel.SubMO)) (l Any!HOW))]
      [l Sub (methodcall (l Sub!HOW) create-protoobject)]

      [l Scalar!HOW (subcall (@ (l &wrap-dpmo))
        (w (rawsget Kernel.ScalarMO)) (l Any!HOW))]
      [l Scalar (methodcall (l Scalar!HOW) create-protoobject)]

      [null Variable])
} }

my class Junction is Mu { }
my class Num {
    method Str () { Q:CgOp {
        (box Str (rawcall (unbox Double (fetch (scopedlex self))) ToString))
    } }
    method Bool() { Q:CgOp {
        (box Bool (compare != (double 0)
                    (unbox Double (fetch (scopedlex self)))))
    } }
    method ACCEPTS($t) { self == $t }
}
my class Str {
    method Str () { self }
    method ACCEPTS($t) { self eq $t }
    method chars() { Q:CgOp {
        (box Num (cast Double (getfield Length (unbox String (@ (l self))))))
    } }
    method substr($from, $len) { Q:CgOp {
        (box Str (rawcall [unbox String (@ (l self))] Substring
                    [cast Int32 (unbox Double (@ (l $from)))]
                    [cast Int32 (unbox Double (@ (l $len)))]))
    } }
}
my class Blob { }
my class Char { }
my class CharLingua { }
my class AnyChar { }
my class Codepoint { }
my class Grapheme { }
my class StrPos { }
my class StrLen { }
my class Rat { }
my class FatRat { }
my class Complex { }
my class Int { }
my class UInt { }
my class Bit { }
my class Instant { }
my class Duration { }
my class Enum { }
my class Bool is Enum {
    method Str() { if self { "Bool::True" } else { "Bool::False" } }
    method Bool() { self }
    method ACCEPTS($) { self }
}

# ought to take a slurpy
sub infix:<~>($l,$r) { Q:CgOp {
    (box Str (rawscall String.Concat
        (unbox String (fetch (methodcall (scopedlex $l) Str)))
        (unbox String (fetch (methodcall (scopedlex $r) Str)))))
} }

sub infix:<+>($l,$r) { Q:CgOp {
    (box Num (arith + (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<->($l,$r) { Q:CgOp {
    (box Num (arith - (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<*>($l,$r) { Q:CgOp {
    (box Num (arith * (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:</>($l,$r) { Q:CgOp {
    (box Num (arith / (unbox Double (fetch (scopedlex $l)))
                      (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< < >>($l,$r) { Q:CgOp {
    (box Bool (compare < (unbox Double (fetch (scopedlex $l)))
                         (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< > >>($l,$r) { Q:CgOp {
    (box Bool (compare > (unbox Double (fetch (scopedlex $l)))
                         (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< <= >>($l,$r) { Q:CgOp {
    (box Bool (compare <= (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< >= >>($l,$r) { Q:CgOp {
    (box Bool (compare >= (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< == >>($l,$r) { Q:CgOp {
    (box Bool (compare == (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub infix:<< != >>($l,$r) { Q:CgOp {
    (box Bool (compare != (unbox Double (fetch (scopedlex $l)))
                          (unbox Double (fetch (scopedlex $r)))))
} }

sub warn($str) { Q:CgOp {
    (prog [rawscall Console.Error.WriteLine
            (unbox String (fetch (methodcall (scopedlex $str) Str))])
          [box Bool (bool 1)]
    )
} }

sub say($str) { Q:CgOp {
    (prog [rawscall Console.WriteLine
            (unbox String (fetch (methodcall (scopedlex $str) Str))])
          [box Bool (bool 1)]
    )
} }

sub exit() { Q:CgOp {
    (prog [rawscall Environment.Exit (int 0) ]
          [null Variable]
    )
} }

sub infix:<=> { Q:CgOp { (prog [assign (pos 0) (pos 1)] (pos 0)) } }

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

# actually a macro
# sub infix:<:=>($l,$r) { ... }

sub prefix:<~>($v) { $v.Str } # should be Stringy
sub prefix:<?>($v) { $v.Bool }

sub prefix:<!>($v) { if $v { ?0 } else { ?1 } }

sub infix:<eq>($l,$r) { Q:CgOp {
    (box Bool (compare ==
        (unbox String (fetch (methodcall (scopedlex $l) Str)))
        (unbox String (fetch (methodcall (scopedlex $r) Str)))))
} }
sub infix:<ne>($l,$r) { Q:CgOp {
    (box Bool (compare !=
        (unbox String (fetch (methodcall (scopedlex $l) Str)))
        (unbox String (fetch (methodcall (scopedlex $r) Str)))))
} }
# this one is horribly wrong and only handles the ref eq case.
sub infix:<===>($l,$r) { Q:CgOp {
    (box Bool (compare == (fetch (scopedlex $l)) (fetch (scopedlex $r))))
} }

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

# XXX: We can't use augment syntax because we don't have use working, so
# no MONKEY_TYPING.

PRE-INIT {
    Mu.HOW.add-method(Q:CgOp { (wrap (clr_string "defined")) },
        anon method defined() {
            Q:CgOp { (box Bool (!= (null Dictionary<string,object>)
                (getfield slots (cast DynObject (@ (l self)))))) }
        });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "Bool")) },
        anon method Bool() { self.defined });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "Str")) },
        anon method Str() {
            my $tn := Q:CgOp {
                (box Str (getfield name (getfield klass
                    (cast DynObject (fetch (scopedlex self))))))
            };
            if self.defined {
                $tn ~ "()<instance>"
            } else {
                $tn ~ "()"
            }
        });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "notdef")) },
        anon method notdef() { ! self.defined });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "so")) },
        anon method notdef() { self.Bool });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "not")) },
        anon method notdef() { ! self.Bool });
    Mu.HOW.add-method(Q:CgOp { (w (clr_string "RAWCREATE")) },
        anon method RAWCREATE(*@fields) {
            my $obj = Q:CgOp {
                (ns (rawnew DynObject (getfield klass
                    (cast DynObject (@ (l self))))))
            };
            while @fields {
                my $name  = @fields.shift;
                my $value = @fields.shift;

                Q:CgOp {
                    (prog
                      [setindex (unbox String (@ (l $name)))
                        (getfield slots (cast DynObject (@ (l $obj))))
                        (l $value)]
                      [null Variable])
                };
            }
            $obj;
        });

    Any.HOW.add-method(Q:CgOp { (w (clr_string "ACCEPTS")) },
        anon method ACCEPTS($t) { self === $t });

    # Should be for Block, not Sub
    Sub.HOW.add-method(Q:CgOp { (w (clr_string "ACCEPTS")) },
        anon method ACCEPTS($t) { (self)($t) });

    ClassHOW.HOW.add-method(Q:CgOp { (w (clr_string "isa")) },
        anon method isa($obj, $type) { Q:CgOp {
            (box Bool (rawcall (getfield klass (cast DynObject (@ (l $obj))))
              HasMRO (getfield klass (cast DynObject (@ (l $type))))))
        } });
    ClassHOW.HOW.add-method(Q:CgOp { (w (clr_string "does")) },
        anon method does($obj, $role) { self.isa($obj, $role) }); #no roles yet
}

# boxes a List<Variable>. SCHLIEMEL WAS HERE
my class LLArray {
    method push($x) { Q:CgOp { (prog
      [rawcall (unbox List<Variable> (@ (l self))) Add (l $x)] [l self]) } }
    method shift() { Q:CgOp { (prog
      [lextypes $f Variable $lv List<Variable>]
      [l $lv (unbox List<Variable> (@ (l self)))]
      [l $f (getindex (int 0) (l $lv))]
      [rawcall (l $lv) RemoveAt (int 0)]
      [l $f]) } }
    method unshift($x) { Q:CgOp { (prog
      [rawcall (unbox List<Variable> (@ (l self))) Insert (int 0) (l $x)]
      [l self]) } }
    method first-flattens() { Q:CgOp {
      (box Bool (getfield islist (getfield lv (getindex (int 0)
        (unbox List<Variable> (@ (l self))))))) } }
    method elems() { Q:CgOp {
      (box Num (cast Double (getfield Count (unbox List<Variable>
        (@ (l self)))))) } }
    method Bool() { ?( self.elems ) }
    method new(*@v) { Q:CgOp { (varattr rest (@ (l @v))) } }
    method at-pos($i) {
        Q:CgOp { (getindex (cast Int32 (unbox Double (@ (l $i))))
                   (unbox List<Variable> (@ (l self)))) }
    }
}

my class Iterator {
    # has $.valid
    # has $.value
    # has $.next

    # subclasses must provide .validate
    method valid() { $!valid }
    method value() { $!value }
    method next()  { $!next  }
}

my class EMPTY { }

my class Parcel {
    # $!ll

    method iterator() {
        my $ll = $!ll;
        my $it = Iterator.RAWCREATE("valid", 1, "value", Any, "next", Any);
        $it.value = EMPTY;
        my $ix = ($ll.elems - 1);

        while $ix >= 0 {
            my $nit = Iterator.RAWCREATE("valid", 1, "next", Any);
            $nit.next = $it;
            $it = $nit;
            Q:CgOp {
                (prog
                  [setindex value (getfield slots
                      (cast DynObject (@ (l $it))))
                    (methodcall (l $ll) at-pos (l $ix))]
                  [null Variable])
            };
            $ix--;
        }

        $it;
    }
}

sub infix:<,>(*@v) {
    my @r := Parcel.RAWCREATE("ll", Q:CgOp { (varattr rest (@ (l @v))) });
    @r;
}

# Maybe this should be a constant, but constants are currently forced to
# scalar-nature (TODO)
sub Nil {
    state @n;
    START {
        @n := Parcel.RAWCREATE("ll", LLArray.new);
    }
    @n;
}

my class List is Cool {
    # low level, so not declared yet
    # @!items @!rest $!flat
    method fill($nr) {
        my $i = $!items;
        my $r = $!rest;
        while $i.elems < $nr && $r {
            if $!flat && $r.first-flattens {
                $r.unshift($r.shift.iterator);
            } else {
                my $v := $r.shift;

                if $v.^isa(EMPTY) {
                    # Discard summarily
                } elsif $v.^isa(Iterator) {
                    if ! $v.valid {
                        $v.validate;
                    }
                    # we can't push anything onto items because it might be
                    # EMPTY
                    if ! $v.value.^isa(EMPTY) {
                        $r.unshift($v.next);
                        $r.unshift($v.value);
                    }
                } else {
                    $i.push($v);
                }
            }
        }

        $i.elems >= $nr;
    }

    method Bool() { self.fill(1) }
    method shift() {
        self.fill(1);
        $!items.shift;
    }
    method elems() { self.fill(1000_000_000); $!items.elems; }

    method at-pos($i) {
        self.fill($i + 1);
        $!items.at-pos($i);
    }

    # XXX this is wrong, it holds on to the entire list -> memory leaks
    my class ListIterator is Iterator {
        # $!valid $!value $!next  $!list $!index
        method validate() {
            $!valid = 1;
            # needed to copy flatness bit if not $!flat ?
            my $l = $!list;
            my $i = $!index;
            if $l.fill($i+1) {
                Q:CgOp {
                    (prog
                      [setindex value (getfield slots
                          (cast DynObject (@ (l self))))
                        (methodcall (l $l) at-pos (l $i))]
                      [null Variable])
                };
            } else {
                $!value = EMPTY;
            }
            $!next = ListIterator.RAWCREATE("valid", 0, "next", Any,
                "value", Any, "list", $!list, "index", $i+1);
        }
    }

    method iterator() {
        ListIterator.RAWCREATE("valid", 0, "next", Any, "value", Any,
            "list", self, "index", 0);
    }
}

{YOU_ARE_HERE}