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.
#
# ClassHOW instances are shared between lexical instantiations of a class.
#
# class ClassHOW {
#     has Array[Frame] $.outers;
#
#     # TODO
#     has Array[Sub] $.scoped-parents;
#     has Array[Sub] $.scoped-roles;
#
#     # used to stage for composition - not yet
#     has Dictionary[str,int] $.method-scopes;
#     has Dictionary[str,Sub] $.methods;
#
#     has DynProtoMetaObject $.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 {
#         $Foo_HOW.push-scope(callframe);
#         $Foo_HOW.add-super(...);
#         $Foo_HOW.add-role(...);
#         $Foo_HOW.add-scoped-method("bar", 0, sub { ... });
#         $Foo_HOW.compose;
#     }
#     my ::Foo will begin { $Foo_HOW.create-protoobject(callframe) }
#              will enter { $Foo_HOW.create-protoobject(callframe) };
#
# to augment:
#     BEGIN my $scopenum = $Foo_HOW.push-scope(callframe);
#     BEGIN { $Foo_HOW.add-scoped-method("baz", $scopenum, sub { ... }); }
#     Foo.^bind-outer($scopenum, callframe);
my class ClassHOW { ... }

PRE-INIT {
    # ClassHOW.new($name) --> meta class instance
    sub new { Q:NIL {
        LEXICALS: $pmo : DynProtoMetaObject, $self : DynObject
        new/0:DynProtoMetaObject L!$pmo
        new/0:DynObject L!$self

        L@$pmo L@$self !.how
        L@$pmo =[1] @ unwrap:String !.name

        L@$self @.slots  L@$pmo wrap  ![meta-object]
        L@$self =[0] @ cast:DynObject @.klass !.klass

        L@$self wrapobj
    } }

    # $how.push-scope($outer)
    sub push-scope { Q:NIL {
        =[0] @ @!meta-object unwrap:DynProtoMetaObject @.def_outers
            =[1] @ unwrap:Frame .virtcall/1:Add
        null:Variable
    } }

    # $how.add-super($how)
    sub add-super { Q:NIL {
        =[0] @ @!meta-object unwrap:DynProtoMetaObject @.superclasses
            =[1] @ @!meta-object unwrap:DynProtoMetaObject  .virtcall/1:Add
        null:Variable
    } }

    # $how.add-scoped-method($name, $index, $sub)
    sub add-scoped-method { Q:NIL {
        LEXICALS: $name : String, $index : Int32, $sub : DynObject
        LEXICALS: $mo : DynProtoMetaObject
        =[0] @ @!meta-object unwrap:DynProtoMetaObject L!$mo
        =[1] @ unwrap:String L!$name
        =[2] @ unwrap:Int32 L!$index
        =[3] @ cast:DynObject L!$sub

        LEXICALS: $proto : Frame, $code : DynBlockDelegate
        L@$sub @.slots @[code]  cast:DynBlockDelegate L!$code
        L@$sub @.slots @[proto] cast:Frame L!$proto

        LEXICALS: $m : DynProtoMetaObject.Method
        L@$code L@$proto L@$index new/3:DynProtoMetaObject.Method L!$m

        L@$mo @.local  L@$name  L@$m ![]
        null:Variable
    } }

    # $how.create-protoobject($callframe, $superlist)
    sub create-protoobject { Q:NIL {
        LEXICALS: $p : DynObject, $pmo : DynProtoMetaObject, $mo : DynMetaObject
        new/0:DynObject L!$p
        =[0] @ @!meta-object unwrap:DynProtoMetaObject L!$pmo
        L@$pmo new/1:DynMetaObject L!$mo
        L@$mo @.outers  =[1] @ unwrap:Frame  .virtcall/1:Add
        L@$mo =[2] @ unwrap:List<DynMetaObject>  .virtcall/1:BuildC3MRO

        L@$p null:Dictionary<string,object> !.slots
        L@$p L@$mo !.klass

        L@$p wrapobj
    } }

    sub compose { Q:NIL { null:Variable } }

    Q:NIL {
        LEXICALS: $chpmo : DynProtoMetaObject, $ch : DynObject
        new/0:DynProtoMetaObject L!$chpmo
        new/0:DynObject L!$ch

        L@$chpmo L@$ch !.how
        L@$chpmo "ClassHOW" !.name
        L@$ch @.slots L@$chpmo wrap ![meta-object]

        L@&push-scope @  L@$ch wrapobj  callframe wrap  .call/2:v
        L@&add-scoped-method @  L@$ch wrapobj  "new" wrap  0 wrap
            L@&new  .call/4:v
        L@&add-scoped-method @  L@$ch wrapobj  "push-scope" wrap  0 wrap
            L@&push-scope  .call/4:v
        L@&add-scoped-method @  L@$ch wrapobj  "add-scoped-method" wrap  0 wrap
            L@&add-scoped-method  .call/4:v
        L@&add-scoped-method @  L@$ch wrapobj  "add-super" wrap  0 wrap
            L@&add-super  .call/4:v
        L@&add-scoped-method @  L@$ch wrapobj  "compose" wrap  0 wrap
            L@&compose  .call/4:v
        L@&add-scoped-method @  L@$ch wrapobj  "create-protoobject" wrap  0 wrap
            L@&create-protoobject  .call/4:v

        L@&create-protoobject @  L@$ch wrapobj  callframe wrap
            new/0:List<DynMetaObject> wrap  .call/3 L!^ClassHOW

        L@$ch  L@^ClassHOW @ cast:DynObject @.klass  !.klass
        L@$ch wrapobj  L!^'ClassHOW!HOW'

        null:Variable
    }
}

# cannot be a normal class - it has no parents (and must not be cloned)
my class Mu { ... }
my class Any { ... }
my class Cool { ... }
# these are really defined in the kernel
my class Scalar { ... }
my class Sub { ... }
PRE-INIT {
    # (DynProtoMetaObject $dpmo, ClassHOW $super --> ClassHOW)
    sub wrap-dpmo { Q:NIL {
        LEXICALS: $ch : Variable, $dp : DynProtoMetaObject
        L@^^ClassHOW dup@  "" wrap .method/1:new  L!$ch
        =[0] @ unwrap:DynProtoMetaObject L!$dp
        L@$ch @  L@$dp wrap @  !!meta-object
        L@$ch dup@  =[1]  .method/1:add-super:v
        L@$ch
    } }
    # (ClassHOW $me, DynMetaObject $use, DynMetaObject $p --> Variable)
    sub wrapped-protoobj { Q:NIL {
        LEXICALS: $p : DynObject, $pmo : DynProtoMetaObject, $mo : DynMetaObject
        LEXICALS: $s : List<DynMetaObject>
        new/0:DynObject L!$p
        =[0] @ @!meta-object unwrap:DynProtoMetaObject L!$pmo
        =[1] @ unwrap:DynMetaObject L!$mo

        new/0:List<DynMetaObject> L!$s
        L@$s  =[2] @ unwrap:DynMetaObject  .virtcall/1:Add
        L@$mo  L@$s  .virtcall/1:BuildC3MRO

        L@$pmo  =[0] @ !.how

        L@$p null:Dictionary<string,object> !.slots
        L@$p L@$mo !.klass

        L@$p wrapobj
    } }

Q:NIL {
    LEXICALS: $plist : List<DynMetaObject>
    L@^ClassHOW dup@  "Mu" wrap  .method/1:new  L!^'Mu!HOW'
    new/0:List<DynMetaObject> L!$plist
    L@^'Mu!HOW' dup@  callframe wrap  L@$plist wrap
        .method/2:create-protoobject  L!^Mu

    L@^ClassHOW dup@  "Any" wrap  .method/1:new  L!^'Any!HOW'
    L@^'Any!HOW' dup@  L@^'Mu!HOW'  .method/1:add-super:v
    new/0:List<DynMetaObject> L!$plist
    L@$plist  L@^Mu @ cast:DynObject @.klass  .virtcall/1:Add
    L@^'Any!HOW' dup@  callframe wrap  L@$plist wrap
        .method/2:create-protoobject  L!^Any

    L@^ClassHOW dup@  "Cool" wrap  .method/1:new  L!^'Cool!HOW'
    L@^'Cool!HOW' dup@  L@^'Any!HOW'  .method/1:add-super:v
    new/0:List<DynMetaObject> L!$plist
    L@$plist  L@^Any @ cast:DynObject @.klass  .virtcall/1:Add
    L@^'Cool!HOW' dup@  callframe wrap  L@$plist wrap
        .method/2:create-protoobject  L!^Cool

    L@&wrap-dpmo @  F@Kernel.SubPMO wrap  L@^'Any!HOW'
        .call/2 L!^'Sub!HOW'
    L@&wrapped-protoobj @  L@^'Sub!HOW'  F@Kernel.SubMO wrap
        L@^Any @ cast:DynObject @.klass wrap  .call/3 L!^Sub

    L@&wrap-dpmo @  F@Kernel.ScalarContainerPMO wrap  L@^'Any!HOW'
        .call/2 L!^'Scalar!HOW'
    L@&wrapped-protoobj @  L@^'Scalar!HOW'  F@Kernel.ScalarContainerMO wrap
        L@^Any @ cast:DynObject @.klass wrap  .call/3 L!^Scalar

    null:Variable
} }

my class Junction is Mu { }
my class Num {
    method Str { Q:NIL { =[0] @ unbox:Double .virtcall/0:ToString box:Str } }
    method Bool { Q:NIL { =[0] @ unbox:Double  0 !=  box:Bool } }
}
my class Str {
    method Str { Q:NIL { =[0] } }
}
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 Q:NIL { =[0] } { "Bool::True" } else { "Bool::False" } }
    method Bool { Q:NIL { =[0] } }
}

sub infix:<~>($l,$r) { Q:NIL {
    {$l.Str} @ unbox:String  {$r.Str} @ unbox:String  .plaincall/2:String.Concat
        box:Str
} }

sub infix:<+>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  +  box:Num
} }

sub infix:<->($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  -  box:Num
} }

sub infix:<*>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  *  box:Num
} }

sub infix:</>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  /  box:Num
} }

sub infix:<< < >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  <  box:Bool
} }

sub infix:<< > >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  >  box:Bool
} }

sub infix:<< <= >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  <=  box:Bool
} }

sub infix:<< >= >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  >=  box:Bool
} }

sub infix:<< == >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  ==  box:Bool
} }

sub infix:<< != >>($l,$r) { Q:NIL {
    {$l} @ unbox:Double  {$r} @ unbox:Double  !=  box:Bool
} }

sub say($str) { Q:NIL {
    {$str.Str} @ unbox:String .plaincall/1:Console.WriteLine null:Variable
} }

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

# 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 }

YOU_ARE_HERE;