diff --git a/META6.json b/META6.json index dc2a6dbe..4f9ea2e2 100644 --- a/META6.json +++ b/META6.json @@ -15,11 +15,11 @@ "_007::Parser::Actions" : "lib/_007/Parser/Actions.pm", "_007::Parser::Syntax" : "lib/_007/Parser/Syntax.pm", "_007::Precedence" : "lib/_007/Precedence.pm", - "_007::Q" : "lib/_007/Q.pm", "_007::Runtime" : "lib/_007/Runtime.pm", "_007::Builtins" : "lib/_007/Builtins.pm", "_007::Test" : "lib/_007/Test.pm", - "_007::Val" : "lib/_007/Val.pm" + "_007::Object" : "lib/_007/Object.pm", + "_007::Type" : "lib/_007/Type.pm" }, "support" : { "source" : "git://github.com/masak/007.git" } } diff --git a/bin/count-builtins b/bin/count-builtins new file mode 100755 index 00000000..1c462c92 --- /dev/null +++ b/bin/count-builtins @@ -0,0 +1,64 @@ +#!/usr/bin/env perl6 +use v6; + +my $type_count = 0; +my $bound_method_count = 0; +my $built_in_subs = 0; +my $exception_types_in_007 = 0; +my $exception_types_in_perl6 = 0; + +for -> $file { + for $file.IO.lines { + if /^ "TYPE<" (<-[>]>+) ">" \h* "=" \h* "_007::Type.new(" / { + $type_count++; + if $0 eq "Exception" || $0.starts-with("X::") { + $exception_types_in_007++; + } + } + } +} + +for -> $file { + for $file.IO.lines { + if /^ "sub bound-method(" / ff /^ "}" / { + if /^ " " ** 4 \S / { + if /^ \h* "if \$object.is-a" / { + $bound_method_count++; + } + elsif /^ \h* "}" / { + # do nothing + } + elsif /^ \h* "die " / { + # do nothing + } + else { + die "Unexpected line: `$_`"; + } + } + } + } +} + +for -> $file { + for $file.IO.lines { + if /^ \h* "my @builtins ="/ ff /^ \h* ";" \h* $/ { + if /^ \h* \S+ \h* "=>" \h* ["->" | "sub" | "macro-op" | "op"] / { + $built_in_subs++; + } + } + } +} + +for -> $file { + for $file.IO.lines { + if /^ "class X::" / { + $exception_types_in_perl6++; + } + } +} + +say "Types: $type_count"; +say "Bound methods: $bound_method_count"; +say "Built-in subs: $built_in_subs"; +say "Exception types in 007: $exception_types_in_007"; +say "Exception types in Perl 6: $exception_types_in_perl6"; diff --git a/examples/hanoi.007 b/examples/hanoi.007 index cd44a270..493e108c 100644 --- a/examples/hanoi.007 +++ b/examples/hanoi.007 @@ -8,7 +8,7 @@ constant DISK = { }; my state = [ - [DISK.huge, DISK.large, DISK.small, DISK.tiny], + [DISK["huge"], DISK["large"], DISK["small"], DISK["tiny"]], [], [] ]; diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 7b278775..ebed4ad9 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -1,5 +1,4 @@ -use _007::Val; -use _007::Q; +use _007::Object; my %builtins = "say" => q:to '----', @@ -10,14 +9,14 @@ my %builtins = ; class _007::Backend::JavaScript { - method emit(Q::CompUnit $compunit) { + method emit(_007::Object $compunit) { return "" - unless $compunit.block.statementlist.statements.elements; + unless $compunit.properties.properties.properties.value; my @builtins; my @main; - for $compunit.block.statementlist.statements.elements -> $stmt { + for $compunit.properties.properties.properties.value -> $stmt { emit-stmt($stmt); } @@ -29,38 +28,38 @@ class _007::Backend::JavaScript { \})(); PROGRAM - multi emit-stmt(Q::Statement $stmt) { - die "Cannot handle {$stmt.^name}"; - } + sub emit-stmt(_007::Object $stmt) { + if $stmt.is-a("Q::Statement::Expr") { + my $expr = $stmt.properties; + when $expr.is-a("Q::Postfix::Call") + && $expr.properties.is-a("Q::Identifier") + && $expr.properties.properties.value eq "say" { - multi emit-stmt(Q::Statement::Expr $stmt) { - my $expr = $stmt.expr; - when $expr ~~ Q::Postfix::Call - && $expr.operand ~~ Q::Identifier - && $expr.operand.name.value eq "say" { + @builtins.push(%builtins); + my @arguments = $expr.properties.properties.value.map: { + die "Cannot handle non-literal-Str arguments just yet!" + unless .is-a("Q::Literal::Str"); + q["] ~ .properties.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]; + }; + @main.push("say({@arguments.join(", ")});"); + } - @builtins.push(%builtins); - my @arguments = $expr.argumentlist.arguments.elements.map: { - die "Cannot handle non-literal-Str arguments just yet!" - unless $_ ~~ Q::Literal::Str; - .value.quoted-Str; - }; - @main.push("say({@arguments.join(", ")});"); + die "Cannot handle this type of Q::Statement::Expr yet!"; } - - die "Cannot handle this type of Q::Statement::Expr yet!"; - } - - multi emit-stmt(Q::Statement::My $stmt) { - my $name = $stmt.identifier.name.value; - if $stmt.expr !~~ NONE { - die "Cannot handle non-literal-Int rhs just yet!" - unless $stmt.expr ~~ Q::Literal::Int; - my $expr = $stmt.expr.value.Str; - @main.push("let {$name} = {$expr};"); + elsif $stmt.is-a("Q::Statement::My") { + my $name = $stmt.properties.properties.value; + if $stmt.properties !=== NONE { + die "Cannot handle non-literal-Int rhs just yet!" + unless $stmt.properties.is-a("Q::Literal::Int"); + my $expr = ~$stmt.properties.properties.value; + @main.push("let {$name} = {$expr};"); + } + else { + @main.push("let {$name};"); + } } else { - @main.push("let {$name};"); + die "Cannot handle {$stmt.type.name}"; } } } diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index e7dc4cf1..dad4d3e7 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,84 +1,99 @@ -use _007::Val; -use _007::Q; - -sub builtins(:$input!, :$output!, :$opscope!) is export { - sub wrap($_) { - when Val | Q { $_ } - when Nil { NONE } - when Bool { Val::Bool.new(:value($_)) } - when Int { Val::Int.new(:value($_)) } - when Str { Val::Str.new(:value($_)) } - when Array | Seq | List { Val::Array.new(:elements(.map(&wrap))) } - default { die "Got some unknown value of type ", .^name } - } +use _007::Type; +use _007::Object; +sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } - multi equal-value(Val::NoneType, Val::NoneType) { True } - multi equal-value(Val::Bool $l, Val::Bool $r) { $l.value == $r.value } - multi equal-value(Val::Int $l, Val::Int $r) { $l.value == $r.value } - multi equal-value(Val::Str $l, Val::Str $r) { $l.value eq $r.value } - multi equal-value(Val::Array $l, Val::Array $r) { - if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { - return $l === $r; + multi equal-value(_007::Object $l, _007::Object $r) { + return False + unless $l.type === $r.type; + if $l.is-a("Int") { + return $l.value == $r.value; } - %*equality-seen{$l.WHICH}++; - %*equality-seen{$r.WHICH}++; + elsif $l.is-a("Str") { + return $l.value eq $r.value; + } + elsif $l.is-a("Array") { + if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { + return $l === $r; + } + %*equality-seen{$l.WHICH}++; + %*equality-seen{$r.WHICH}++; + + sub equal-at-index($i) { + equal-value($l.value[$i], $r.value[$i]); + } - sub equal-at-index($i) { - equal-value($l.elements[$i], $r.elements[$i]); + return [&&] $l.value == $r.value, |(^$l.value).map(&equal-at-index); } + elsif $l.is-a("Dict") { + if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { + return $l === $r; + } + %*equality-seen{$l.WHICH}++; + %*equality-seen{$r.WHICH}++; - [&&] $l.elements == $r.elements, - |(^$l.elements).map(&equal-at-index); - } - multi equal-value(Val::Object $l, Val::Object $r) { - if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { + sub equal-at-key(Str $key) { + equal-value($l.value{$key}, $r.value{$key}); + } + + return [&&] $l.value.keys.sort.perl eq $r.value.keys.sort.perl, |($l.value.keys).map(&equal-at-key); + } + elsif $l.is-a("NoneType") { + return True; + } + elsif $l.is-a("Bool") { return $l === $r; } - %*equality-seen{$l.WHICH}++; - %*equality-seen{$r.WHICH}++; - - sub equal-at-key(Str $key) { - equal-value($l.properties{$key}, $r.properties{$key}); + elsif $l.is-a("Sub") { + return $l.properties.value eq $r.properties.value + && equal-value($l.properties, $r.properties) + && equal-value($l.properties, $r.properties); } + elsif $l.is-a("Q") { + sub same-propvalue($prop) { + equal-value($l.properties{$prop}, $r.properties{$prop}); + } - [&&] $l.properties.keys.sort.perl eq $r.properties.keys.sort.perl, - |($l.properties.keys).map(&equal-at-key); - } - multi equal-value(Val::Type $l, Val::Type $r) { - $l.type === $r.type - } - multi equal-value(Val::Sub $l, Val::Sub $r) { - $l.name eq $r.name - && equal-value($l.parameterlist, $r.parameterlist) - && equal-value($l.statementlist, $r.statementlist) - } - multi equal-value(Q $l, Q $r) { - sub same-avalue($attr) { - equal-value($attr.get_value($l), $attr.get_value($r)); + [&&] $l.type === $r.type, + |$l.type.type-chain.reverse.map({ .fields }).flat.map({ . }).grep({ $_ ne "frame" }).map(&same-propvalue); + } + else { + die "Unknown type ", $l.type.^name; } - - [&&] $l.WHAT === $r.WHAT, - |$l.attributes.map(&same-avalue); } + multi equal-value(_007::Type $l, _007::Type $r) { $l === $r } multi less-value($, $) { - die X::TypeCheck.new( + die X::Type.new( :operation, :got($_), - :expected(Val::Int)); + :expected(TYPE)); + } + multi less-value(_007::Object $l, _007::Object $r) { + die X::Type.new(:operation, :got($_), :expected(TYPE)) + unless $l.type === $r.type; + return $l.is-a("Int") + ?? $l.value < $r.value + !! $l.is-a("Str") + ?? $l.value lt $r.value + !! die "Unknown type ", $l.type.Str; } - multi less-value(Val::Int $l, Val::Int $r) { $l.value < $r.value } - multi less-value(Val::Str $l, Val::Str $r) { $l.value le $r.value } multi more-value($, $) { - die X::TypeCheck.new( + die X::Type.new( :operation, :got($_), - :expected(Val::Int)); + :expected(TYPE)); + } + multi more-value(_007::Object $l, _007::Object $r) { + die X::Type.new(:operation, :got($_), :expected(TYPE)) + unless $l.type === $r.type; + return $l.is-a("Int") + ?? $l.value > $r.value + !! $l.is-a("Str") + ?? $l.value gt $r.value + !! die "Unknown type ", $l.type.Str; } - multi more-value(Val::Int $l, Val::Int $r) { $l.value > $r.value } - multi more-value(Val::Str $l, Val::Str $r) { $l.value ge $r.value } my role Placeholder { has $.qtype; @@ -100,7 +115,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my @builtins = say => -> $arg { - $output.print($arg ~ "\n"); + $output.print(stringify($arg, $runtime) ~ "\n"); Nil; }, prompt => sub ($arg) { @@ -108,28 +123,30 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { $output.flush(); return wrap($input.get()); }, - type => -> $arg { Val::Type.of($arg.WHAT) }, + type => sub ($arg) { + $arg.type; + }, # OPERATORS (from loosest to tightest within each category) # assignment precedence 'infix:=' => macro-op( - :qtype(Q::Infix::Assignment), + :qtype(TYPE), :assoc, ), # disjunctive precedence 'infix:||' => macro-op( - :qtype(Q::Infix::Or), + :qtype(TYPE), ), 'infix://' => macro-op( - :qtype(Q::Infix::DefinedOr), + :qtype(TYPE), :precedence{ equal => "infix:||" }, ), # conjunctive precedence 'infix:&&' => macro-op( - :qtype(Q::Infix::And), + :qtype(TYPE), ), # comparison precedence @@ -138,21 +155,21 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my %*equality-seen; return wrap(equal-value($lhs, $rhs)); }, - :qtype(Q::Infix::Eq), + :qtype(TYPE), ), 'infix:!=' => op( sub ($lhs, $rhs) { my %*equality-seen; return wrap(!equal-value($lhs, $rhs)) }, - :qtype(Q::Infix::Ne), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:<' => op( sub ($lhs, $rhs) { return wrap(less-value($lhs, $rhs)) }, - :qtype(Q::Infix::Lt), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:<=' => op( @@ -160,14 +177,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my %*equality-seen; return wrap(less-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, - :qtype(Q::Infix::Le), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:>' => op( sub ($lhs, $rhs) { return wrap(more-value($lhs, $rhs) ) }, - :qtype(Q::Infix::Gt), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:>=' => op( @@ -175,257 +192,240 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my %*equality-seen; return wrap(more-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, - :qtype(Q::Infix::Ge), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:~~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) - unless $rhs ~~ Val::Type; + die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Type"); - return wrap($lhs ~~ $rhs.type); + return wrap(?$lhs.is-a($rhs)); }, - :qtype(Q::Infix::TypeMatch), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:!~~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) - unless $rhs ~~ Val::Type; + die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Type"); - return wrap($lhs !~~ $rhs.type); + return wrap(!$lhs.is-a($rhs)); }, - :qtype(Q::Infix::TypeNonMatch), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), # cons precedence 'infix:::' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<::>, :got($rhs), :expected(Val::Array)) - unless $rhs ~~ Val::Array; - return wrap([$lhs, |$rhs.elements]); + die X::Type.new(:operation<::>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Array"); + return wrap([$lhs, |$rhs.value]); }, - :qtype(Q::Infix::Cons), + :qtype(TYPE), :assoc, ), # additive precedence 'infix:+' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(Val::Int)) - unless $lhs ~~ Val::Int; - die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation<+>, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Int"); + die X::Type.new(:operation<+>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); return wrap($lhs.value + $rhs.value); }, - :qtype(Q::Infix::Addition), + :qtype(TYPE), ), 'infix:~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~>, :got($lhs), :expected(Val::Str)) - unless $lhs ~~ Val::Str; - die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(Val::Str)) - unless $rhs ~~ Val::Str; + die X::Type.new(:operation<~>, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Str"); + die X::Type.new(:operation<~>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Str"); return wrap($lhs.value ~ $rhs.value); }, - :qtype(Q::Infix::Concat), + :qtype(TYPE), :precedence{ equal => "infix:+" }, ), 'infix:-' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<->, :got($lhs), :expected(Val::Int)) - unless $lhs ~~ Val::Int; - die X::TypeCheck.new(:operation<->, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation<->, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Int"); + die X::Type.new(:operation<->, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); return wrap($lhs.value - $rhs.value); }, - :qtype(Q::Infix::Subtraction), + :qtype(TYPE), ), # multiplicative precedence 'infix:*' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(Val::Int)) - unless $lhs ~~ Val::Int; - die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation<*>, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Int"); + die X::Type.new(:operation<*>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); return wrap($lhs.value * $rhs.value); }, - :qtype(Q::Infix::Multiplication), + :qtype(TYPE), ), 'infix:%' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<%>, :got($lhs), :expected(Val::Int)) - unless $lhs ~~ Val::Int; - die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation<%>, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Int"); + die X::Type.new(:operation<%>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value % $rhs.value); }, - :qtype(Q::Infix::Modulo), + :qtype(TYPE), ), 'infix:%%' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<%%>, :got($lhs), :expected(Val::Int)) - unless $lhs ~~ Val::Int; - die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation<%%>, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Int"); + die X::Type.new(:operation<%%>, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); }, - :qtype(Q::Infix::Divisibility), + :qtype(TYPE), ), 'infix:x' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation, :got($lhs), :expected(Val::Str)) - unless $lhs ~~ Val::Str; - die X::TypeCheck.new(:operation, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; + die X::Type.new(:operation, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Str"); + die X::Type.new(:operation, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); return wrap($lhs.value x $rhs.value); }, - :qtype(Q::Infix::Replicate), + :qtype(TYPE), :precedence{ equal => "infix:*" }, ), 'infix:xx' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation, :got($lhs), :expected(Val::Array)) - unless $lhs ~~ Val::Array; - die X::TypeCheck.new(:operation, :got($rhs), :expected(Val::Int)) - unless $rhs ~~ Val::Int; - return wrap(| $lhs.elements xx $rhs.value); + die X::Type.new(:operation, :got($lhs), :expected(TYPE)) + unless $lhs.is-a("Array"); + die X::Type.new(:operation, :got($rhs), :expected(TYPE)) + unless $rhs.is-a("Int"); + return wrap(| $lhs.value xx $rhs.value); }, - :qtype(Q::Infix::ArrayReplicate), + :qtype(TYPE), :precedence{ equal => "infix:*" }, ), # prefixes 'prefix:~' => op( sub prefix-str($expr) { - Val::Str.new(:value($expr.Str)); + return wrap(stringify($expr, $runtime)); }, - :qtype(Q::Prefix::Str), + :qtype(TYPE), ), 'prefix:+' => op( - sub prefix-plus($_) { - when Val::Str { - return wrap(.value.Int) - if .value ~~ /^ '-'? \d+ $/; - proceed; + sub prefix-plus($expr) { + if $expr.is-a("Str") { + return wrap($expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; } - when Val::Int { - return $_; + elsif $expr.is-a("Int") { + return $expr; } - die X::TypeCheck.new( + die X::Type.new( :operation("prefix:<+>"), - :got($_), - :expected(Val::Int)); + :got($expr), + :expected(TYPE)); }, - :qtype(Q::Prefix::Plus), + :qtype(TYPE), ), 'prefix:-' => op( - sub prefix-minus($_) { - when Val::Str { - return wrap(-.value.Int) - if .value ~~ /^ '-'? \d+ $/; - proceed; + sub prefix-minus($expr) { + if $expr.is-a("Str") { + return wrap(-$expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; } - when Val::Int { - return wrap(-.value); + elsif $expr.is-a("Int") { + return wrap(-$expr.value); } - die X::TypeCheck.new( + die X::Type.new( :operation("prefix:<->"), - :got($_), - :expected(Val::Int)); + :got($expr), + :expected(TYPE)); }, - :qtype(Q::Prefix::Minus), + :qtype(TYPE), ), 'prefix:?' => op( - sub ($a) { - return wrap(?$a.truthy) + sub ($arg) { + return wrap(boolify($arg, $runtime)); }, - :qtype(Q::Prefix::So), + :qtype(TYPE), ), 'prefix:!' => op( - sub ($a) { - return wrap(!$a.truthy) + sub ($arg) { + return wrap(!boolify($arg, $runtime)); }, - :qtype(Q::Prefix::Not), + :qtype(TYPE), ), 'prefix:^' => op( sub ($n) { - die X::TypeCheck.new(:operation<^>, :got($n), :expected(Val::Int)) - unless $n ~~ Val::Int; - return wrap([^$n.value]); + die X::Type.new(:operation<^>, :got($n), :expected(TYPE)) + unless $n.is-a("Int"); + return wrap([(^$n.value).map(&wrap)]); }, - :qtype(Q::Prefix::Upto), + :qtype(TYPE), ), # postfixes 'postfix:[]' => macro-op( - :qtype(Q::Postfix::Index), + :qtype(TYPE), ), 'postfix:()' => macro-op( - :qtype(Q::Postfix::Call), + :qtype(TYPE), ), 'postfix:.' => macro-op( - :qtype(Q::Postfix::Property), + :qtype(TYPE), ), ; - sub tree-walk(%package) { - for %package.keys.map({ %package ~ "::$_" }) -> $name { - my $type = ::($name); - push @builtins, ($type.^name.subst("Val::", "") => Val::Type.of($type)); - tree-walk($type.WHO); - } + for TYPE.keys -> $type { + push @builtins, ($type => TYPE{$type}); } - tree-walk(Val::); - tree-walk(Q::); - push @builtins, "Q" => Val::Type.of(Q); sub install-op($name, $placeholder) { $name ~~ /^ (prefix | infix | postfix) ':' (.+) $/ or die "This shouldn't be an op"; my $type = ~$0; my $opname = ~$1; - my $qtype = $placeholder.qtype; + my %properties = hash($placeholder.qtype.type-chain.reverse.map({ .fields }).flat.map({ . }).map({ $_ => NONE })); + my $q = create($placeholder.qtype, |%properties); my $assoc = $placeholder.assoc; my %precedence = $placeholder.precedence; - $opscope.install($type, $opname, $qtype, :$assoc, :%precedence); + $opscope.install($type, $opname, $q, :$assoc, :%precedence); } my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(Val::Str.new(:$^value))))) }; + my ¶meter = { create(TYPE, :identifier(create(TYPE, :name(wrap($^value))))) }; return @builtins.map: { - when .value ~~ Val::Type { + when .value ~~ _007::Type { .key => .value; } when .value ~~ Block { - my @elements = .value.signature.params».name».&ditch-sigil».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); - my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(.value, .key, $parameterlist, $statementlist); + .key => wrap-fn(.value, .key); } when .value ~~ Placeholder::MacroOp { my $name = .key; install-op($name, .value); - my @elements = .value.qtype.attributes».name».substr(2).grep({ $_ ne "identifier" })».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); - my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(sub () {}, $name, $parameterlist, $statementlist); + .key => wrap-fn(sub () {}, $name); } when .value ~~ Placeholder::Op { my $name = .key; install-op($name, .value); my &fn = .value.fn; - my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); - my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); + .key => wrap-fn(&fn, $name); } default { die "Unknown type {.value.^name}" } }; diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 6a1875d5..0dda1102 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -1,5 +1,4 @@ -use _007::Val; -use _007::Q; +use _007::Object; role Lint { method message { ... } @@ -47,112 +46,106 @@ class _007::Linter { { my $root = $.parser.parse($program); - traverse($root); - my @blocks; - multi traverse(Q::Statement::Block $stblock) { - traverse($stblock.block); - } - - multi traverse(Q::Block $block) { - @blocks.push: $block; - traverse($block.parameterlist); - traverse($block.statementlist); - @blocks.pop; - } - - multi traverse(Q::ParameterList $parameterlist) { - } - - multi traverse(Q::StatementList $statementlist) { - for $statementlist.statements.elements -> $stmt { - traverse($stmt); - } - } - - multi traverse(Q::Statement::Sub $sub) { - my $name = $sub.identifier.name; - %declared{"{@blocks[*-1].WHICH.Str}|$name"} = L::SubNotUsed; - } - - multi traverse(Q::Statement::Expr $stexpr) { - traverse($stexpr.expr); - } - - multi traverse(Q::Postfix::Call $call) { - traverse($call.operand); - traverse($call.argumentlist); - } - sub ref(Str $name) { for @blocks.reverse -> $block { - my $pad = $block.static-lexpad; - if $pad.properties{$name} { - return "{$block.WHICH.Str}|$name"; + my $pad = $block.properties; + if $pad.value{$name} { + return "{$block.id}|$name"; } } fail X::AssertionFailure.new("A thing that is used must be declared somewhere"); } - multi traverse(Q::Identifier $identifier) { - my $name = $identifier.name.value; - # XXX: what we should really do is whitelist all of he built-ins - return if $name eq "say"; - my $ref = ref $name; - - %used{ref $name} = True; - if !%assigned{ref $name} { - %readbeforeassigned{$ref} = True; + sub traverse(_007::Object $node) { + if $node.is-a("Q::Statement::Block") -> $stblock { + traverse($stblock.properties); } - } - - multi traverse(Q::ArgumentList $argumentlist) { - for $argumentlist.arguments.elements -> $expr { - traverse($expr); + elsif $node.is-a("Q::Block") -> $block { + @blocks.push: $block; + traverse($block.properties); + traverse($block.properties); + @blocks.pop; } - } - - multi traverse(Q::Literal $literal) { - } - - multi traverse(Q::Term $term) { - } - - multi traverse(Q::Statement::For $for) { - traverse($for.expr); - traverse($for.block); - } - - multi traverse(Q::Statement::My $my) { - my $name = $my.identifier.name; - my $ref = "{@blocks[*-1].WHICH.Str}|$name"; - %declared{$ref} = L::VariableNotUsed; - if $my.expr !~~ NONE { - traverse($my.expr); - %assigned{$ref} = True; - if $my.expr ~~ Q::Identifier && $my.expr.name eq $name { + elsif $node.is-a("Q::StatementList") -> $statementlist { + for $statementlist.properties.value -> $stmt { + traverse($stmt); + } + } + elsif $node.is-a("Q::Statement::Sub") -> $sub { + my $name = $sub.properties.properties.value; + %declared{"{@blocks[*-1].id}|$name"} = L::SubNotUsed; + } + elsif $node.is-a("Q::Statement::Expr") -> $stexpr { + traverse($stexpr.properties); + } + elsif $node.is-a("Q::Postfix::Call") -> $call { + traverse($call.properties); + traverse($call.properties); + } + elsif $node.is-a("Q::Identifier") -> $identifier { + my $name = $identifier.properties.value; + # XXX: what we should really do is whitelist all of he built-ins + return if $name eq "say"; + my $ref = ref $name; + + %used{ref $name} = True; + if !%assigned{ref $name} { + %readbeforeassigned{$ref} = True; + } + } + elsif $node.is-a("Q::ArgumentList") -> $argumentlist { + for $argumentlist.properties.value -> $expr { + traverse($expr); + } + } + elsif $node.is-a("Q::Statement::For") -> $for { + traverse($for.properties); + traverse($for.properties); + } + elsif $node.is-a("Q::Statement::My") -> $my { + my $name = $my.properties.properties.value; + my $ref = "{@blocks[*-1].id}|$name"; + %declared{$ref} = L::VariableNotUsed; + if $my.properties !=== NONE { + traverse($my.properties); + %assigned{$ref} = True; + if $my.properties.is-a("Q::Identifier") && $my.properties.properties.value eq $name { + @complaints.push: L::RedundantAssignment.new(:$name); + %readbeforeassigned{$ref} :delete; + } + } + } + elsif $node.is-a("Q::Infix::Assignment") -> $infix { + traverse($infix.properties); + die "LHS was not an identifier" + unless $infix.properties.is-a("Q::Identifier"); + my $name = $infix.properties.properties.value; + if $infix.properties.is-a("Q::Identifier") && $infix.properties.properties.value eq $name { @complaints.push: L::RedundantAssignment.new(:$name); - %readbeforeassigned{$ref} :delete; } + %assigned{ref $name} = True; } - } - - multi traverse(Q::Infix::Assignment $infix) { - traverse($infix.rhs); - die "LHS was not an identifier" - unless $infix.lhs ~~ Q::Identifier; - my $name = $infix.lhs.name.value; - if $infix.rhs ~~ Q::Identifier && $infix.rhs.name eq $name { - @complaints.push: L::RedundantAssignment.new(:$name); + elsif $node.is-a("Q::Infix::Addition") -> $infix { + traverse($infix.properties); + traverse($infix.properties); + } + elsif $node.is-a("Q::ParameterList") -> $parameterlist { + # nothing + } + elsif $node.is-a("Q::Literal") -> $literal { + # nothing + } + elsif $node.is-a("Q::Term") -> $term { + # nothing + } + else { + die "Couldn't handle ", $node.type; } - %assigned{ref $name} = True; } - multi traverse(Q::Infix::Addition $infix) { - traverse($infix.lhs); - traverse($infix.rhs); - } + traverse($root); } for %declared.keys -> $ref { diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm new file mode 100644 index 00000000..e87fd8a5 --- /dev/null +++ b/lib/_007/Object.pm @@ -0,0 +1,1219 @@ +use _007::Type; + +class X::Uninstantiable is Exception { + has Str $.name; + + method message() { " is abstract and uninstantiable"; } +} + +class X::Property::NotDeclared is Exception { + has Str $.type; + has Str $.property; + + method message { "The property '$.property' is not defined on type '$.type'" } +} + +class X::Property::Required is Exception { + has Str $.type; + has Str $.property; + + method message { "The property '$.property' is required on type '$.type'" } +} + +class X::Property::Duplicate is Exception { + has Str $.property; + + method message { "The property '$.property' was declared more than once in a property list" } +} + +class X::Control::Return is Exception { + has $.frame; + has $.value; +} + +class X::_007::RuntimeException is Exception { + has $.msg; + + method message { + $.msg.Str; + } +} + +class X::Subscript::TooLarge is Exception { + has $.value; + has $.length; + + method message() { "Subscript ($.value) too large (array length $.length)" } +} + +class X::Subscript::NonInteger is Exception { +} + +class X::Subscript::NonString is Exception { +} + +class X::ParameterMismatch is Exception { + has $.type; + has $.paramcount; + has $.argcount; + + method message { + "$.type with $.paramcount parameters called with $.argcount arguments" + } +} + +# We previously used Perl 6's X::TypeCheck, but it wants the .expected attribute to be a Perl 6 type. +# This is insufficient after switching to 007 having its own object system where basically everything is +# a _007::Object. Instead we use our own exception type, which is otherwise identical. +class X::Type is Exception { + has $.operation; + has $.got; + has _007::Type $.expected; + + method message { + "Type check failed in {$.operation}; expected {$.expected.name} but got {$.got.type.name} ({$.got.Str})" + } +} + +class X::Property::NotFound is Exception { + has $.propname; + has $.type; + + method message { + "Property '$.propname' not found on object of type $.type" + } +} + +class X::Regex::InvalidMatchType is Exception { + method message { "A regex can only match strings" } +} + +class _007::Object does Typable { + has $.id = unique-id; + has %.properties; +} + +sub create(_007::Type $type, *%properties) is export { + die X::Uninstantiable.new(:name($type.name)) + if $type.is-abstract; + + # XXX: For Dict and Array, we might instead want to do a shallow copy + if $type === TYPE || $type === TYPE || $type === TYPE || $type === TYPE { + return %properties; + } + + if $type === TYPE { + return _007::Type.new( + :name(%properties ?? %properties.value !! ""), + :base(%properties // TYPE), + :fields(%properties ?? %properties.value !! []), + :is-abstract(%properties // False), + ); + } + + my %fields = $type.type-chain.map({ .fields }).flat.map({ . => $_ }); + my $seen = set(); + PROPERTY: + for %properties.keys.sort -> $property { + die X::Property::NotDeclared.new(:type($type.name), :$property) + unless %fields{$property}; + + die X::Property::Duplicate.new(:type($type.name), :$property) + if $property (elem) $seen; + + $seen (|)= $property; + + my $value = %properties{$property}; + my $type-union = %fields{$property}; + my @type-union = $type-union.split(/ \h* "|" \h* /); + if %fields{$property} { + @type-union.push("NoneType"); + } + for @type-union -> $fieldtypename { + my $fieldtype = TYPE{$fieldtypename} + or die "No such type {$fieldtypename}"; + next PROPERTY + if $value.is-a($fieldtype); + } + die X::Type.new( + :operation("instantiation of {$type.name} with property $property"), + :got($value), + :expected(_007::Type.new(:name(@type-union.join(" | ")))), + ); + } + + for %fields.kv -> $name, $field { + next if $name (elem) $seen; + + if $field { + %properties{$name} = none(); + } + else { + die "Need to pass property '$name' when creating a {$type.name}"; + } + } + + # XXX: ditto for property default values + + return _007::Object.new(:$type, :%properties); +} + +class _007::Object::Wrapped is _007::Object { + has $.value; +} + +constant NONE is export = create(TYPE, :name(_007::Object::Wrapped.new(:type(TYPE), :value("None")))); +sub none() { NONE } + +# Now we can install NONE into TYPE.base +TYPE.install-base(NONE); + +constant TRUE is export = create(TYPE, :name(_007::Object::Wrapped.new(:type(TYPE), :value("True")))); +constant FALSE is export = create(TYPE, :name(_007::Object::Wrapped.new(:type(TYPE), :value("False")))); + +sub escaped($name) { + sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } + sub escape-less-thans($s) { $s.subst(/"<"/, "\\<", :g) } + + return $name + unless $name ~~ /^ (prefix | infix | postfix) ':' (.+) /; + + return "{$0}:<{escape-less-thans escape-backslashes $1}>" + if $1.contains(">") && $1.contains("»"); + + return "{$0}:«{escape-backslashes $1}»" + if $1.contains(">"); + + return "{$0}:<{escape-backslashes $1}>"; +} + +sub pretty($parameterlist) { + return sprintf "(%s)", $parameterlist.properties.value.map({ + .properties.properties.value + }).join(", "); +} + +sub stringify($object, $runtime) is export { + my $s = bound-method($object, "Str", $runtime)(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.is-a("Str"); + return $s.value; +} + +sub reprify($object, $runtime) is export { + my $s = bound-method($object, "repr", $runtime)(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.is-a("Str"); + return $s.value; +} + +sub boolify($object, $runtime) is export { + my $s = bound-method($object, "Bool", $runtime)(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.is-a("Bool"); + return $s === TRUE; +} + +my $str-array-depth = 0; +my $str-array-seen; + +my $str-dict-depth = 0; +my $str-dict-seen; + +# XXX: now need the same thing done with objects + +# XXX: this is not optimal -- I wanted to declare these as part of the types themselves, but +# a rakudobug currently prevents subs in constants from being accessed from another module +sub bound-method($object, $name, $runtime) is export { + die "The invocant is undefined" + if $object === Any; + + if $object.is-a("Q::Statement::Block") && $name eq "run" { + return sub run-q-statement-block() { + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + bound-method($object.properties.properties, "run", $runtime)(); + $runtime.leave; + }; + } + + if $object.is-a("Q::StatementList") && $name eq "run" { + return sub run-q-statementlist() { + for $object.properties.value -> $statement { + my $value = bound-method($statement, "run", $runtime)(); + LAST if $statement.is-a("Q::Statement::Expr") { + return $value; + } + } + }; + } + + if $object.is-a("Q::Statement::Expr") && $name eq "run" { + return sub run-q-statement-expr() { + return bound-method($object.properties, "eval", $runtime)(); + }; + } + + if $object.is-a("Q::Identifier") && $name eq "eval" { + return sub eval-q-identifier() { + return $runtime.get-var($object.properties.value, $object.properties); + }; + } + + if $object.is-a("Q::Literal::Int") && $name eq "eval" { + return sub eval-q-literal-int() { + return $object.properties; + }; + } + + if $object.is-a("Q::Literal::Str") && $name eq "eval" { + return sub eval-q-literal-str() { + return $object.properties; + }; + } + + if $object.is-a("Q::Term::Dict") && $name eq "eval" { + return sub eval-q-term-dict() { + return wrap(hash($object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval", $runtime)(); + }))); + }; + } + + if $object.is-a("Q::Identifier") && $name eq "put-value" { + return sub put-value-q-identifier($value) { + $runtime.put-var($object, $value); + }; + } + + if $object.is-a("Q::Statement::Class") && $name eq "run" { + return sub run-q-statement-class() { + # a class block does not run at runtime + }; + } + + if $object.is-a("Q::Statement::Sub") && $name eq "run" { + return sub run-q-statement-sub() { + # a sub declaration does not run at runtime + }; + } + + if $object.is-a("Q::Statement::Macro") && $name eq "run" { + return sub run-q-statement-macro() { + # a macro declaration does not run at runtime + }; + } + + if $object.is-a("Q::Statement::For") && $name eq "run" { + return sub run-q-statement-for() { + my $count = $object.properties.properties.properties.value.elems; + die X::ParameterMismatch.new( + :type("For loop"), :paramcount($count), :argcount("0 or 1")) + if $count > 1; + + my $array = bound-method($object.properties, "eval", $runtime)(); + die X::Type.new(:operation("for loop"), :got($array), :expected(TYPE)) + unless $array.is-a("Array"); + + for $array.value -> $arg { + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + if $count == 1 { + $runtime.declare-var($object.properties.properties.properties.value[0].properties, $arg.list[0]); + } + bound-method($object.properties.properties, "run", $runtime)(); + $runtime.leave; + } + }; + } + + if $object.is-a("Q::Statement::While") && $name eq "run" { + return sub run-q-statement-while() { + while boolify(my $expr = bound-method($object.properties, "eval", $runtime)(), $runtime) { + my $paramcount = $object.properties.properties.properties.value.elems; + die X::ParameterMismatch.new( + :type("While loop"), :$paramcount, :argcount("0 or 1")) + if $paramcount > 1; + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + for @($object.properties.properties.properties.value) Z $expr -> ($param, $arg) { + $runtime.declare-var($param.properties, $arg); + } + bound-method($object.properties.properties, "run", $runtime)(); + $runtime.leave; + } + }; + } + + if $object.is-a("Q::Term::Object") && $name eq "eval" { + return sub eval-q-term-object() { + my $type = $runtime.get-var( + $object.properties.properties.value, + $object.properties.properties); + if $type ~~ _007::Type { + return create($type, |hash($object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval", $runtime)() + }))); + } + return create($type, $object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval", $runtime)() + })); + }; + } + + if $object.is-a("Q::Infix::Assignment") && $name eq "eval" { + return sub eval-q-infix-assignment() { + my $value = bound-method($object.properties, "eval", $runtime)(); + bound-method($object.properties, "put-value", $runtime)($value); + return $value; + }; + } + + if $object.is-a("Q::Infix::And") && $name eq "eval" { + return sub eval-q-infix-and() { + my $l = bound-method($object.properties, "eval", $runtime)(); + return boolify($l, $runtime) + ?? bound-method($object.properties, "eval", $runtime)() + !! $l; + }; + } + + if $object.is-a("Q::Infix::Or") && $name eq "eval" { + return sub eval-q-infix-or() { + my $l = bound-method($object.properties, "eval", $runtime)(); + return boolify($l, $runtime) + ?? $l + !! bound-method($object.properties, "eval", $runtime)(); + }; + } + + if $object.is-a("Q::Infix::DefinedOr") && $name eq "eval" { + return sub eval-q-infix-definedor() { + my $l = bound-method($object.properties, "eval", $runtime)(); + return $l !=== NONE + ?? $l + !! bound-method($object.properties, "eval", $runtime)(); + }; + } + + if $object.is-a("Q::Infix") && $name eq "eval" { + return sub eval-q-infix() { + my $l = bound-method($object.properties, "eval", $runtime)(); + my $r = bound-method($object.properties, "eval", $runtime)(); + my $c = bound-method($object.properties, "eval", $runtime)(); + return internal-call($c, $runtime, [$l, $r]); + }; + } + + if $object.is-a("Q::Prefix") && $name eq "eval" { + return sub eval-q-prefix() { + my $e = bound-method($object.properties, "eval", $runtime)(); + my $c = bound-method($object.properties, "eval", $runtime)(); + return internal-call($c, $runtime, [$e]); + }; + } + + if $object.is-a("Q::Postfix::Property") && $name eq "eval" { + return sub eval-q-postfix-property() { + my $obj = bound-method($object.properties, "eval", $runtime)(); + my $propname = $object.properties.properties.value; + my @props = $obj.type.type-chain.map({ .fields }).flat.map({ . }); + if $propname (elem) @props { + if $obj.is-a("Type") && $propname eq "name" { + return wrap($obj.name); + } + return $obj.properties{$propname}; + } + else { + # XXX: don't want to do it like this + # think I want a BoundMethod type instead + my &fn = bound-method($obj, $propname, $runtime); + return wrap-fn(&fn); + } + }; + } + + if $object.is-a("Q::Postfix::Index") && $name eq "eval" { + return sub eval-q-postfix-index() { + given bound-method($object.properties, "eval", $runtime)() { + if .is-a("Array") { + my $index = bound-method($object.properties, "eval", $runtime)(); + die X::Subscript::NonInteger.new + unless $index.is-a("Int"); + die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) + if $index.value >= .value; + die X::Subscript::Negative.new(:$index, :type([])) + if $index.value < 0; + return .value[$index.value]; + } + if .is-a("Dict") -> $dict { + my $property = bound-method($object.properties, "eval", $runtime)(); + die X::Subscript::NonString.new + unless $property.is-a("Str"); + my $propname = $property.value; + die X::Property::NotFound.new(:$propname, :type) + unless $dict.value{$propname} :exists; + return $dict.value{$propname}; + } + die X::Type.new(:operation, :got($_), :expected(TYPE)); + } + }; + } + + if $object.is-a("Q::Postfix::Call") && $name eq "eval" { + return sub eval-q-postfix-call() { + my $c = bound-method($object.properties, "eval", $runtime)(); + die "macro is called at runtime" + if $c.is-a("Macro"); + die "Trying to invoke a {$c.type.name}" # XXX: make this into an X:: + unless $c.is-a("Sub"); + my @arguments = $object.properties.properties.value.map({ + bound-method($_, "eval", $runtime)() + }); + return internal-call($c, $runtime, @arguments); + }; + } + + if $object.is-a("Q::Postfix") && $name eq "eval" { + return sub eval-q-postfix() { + my $e = bound-method($object.properties, "eval", $runtime)(); + my $c = bound-method($object.properties, "eval", $runtime)(); + return internal-call($c, $runtime, [$e]); + }; + } + + if $object.is-a("Q::Statement::My") && $name eq "run" { + return sub run-q-statement-my() { + return + if $object.properties === NONE; + + my $value = bound-method($object.properties, "eval", $runtime)(); + bound-method($object.properties, "put-value", $runtime)($value); + }; + } + + if $object.is-a("Q::Statement::Constant") && $name eq "run" { + return sub run-q-statement-constant() { + # value has already been assigned + }; + } + + if $object.is-a("Q::Statement::If") && $name eq "run" { + return sub run-q-statement-if() { + my $expr = bound-method($object.properties, "eval", $runtime)(); + if boolify($expr, $runtime) { + my $paramcount = $object.properties.properties.properties.value.elems; + die X::ParameterMismatch.new(:type("If statement"), :$paramcount, :argcount("0 or 1")) + if $paramcount > 1; + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + if $object.properties.properties.properties.value == 1 { + $runtime.declare-var( + $object.properties.properties.properties.value[0].properties, + $expr); + } + bound-method($object.properties.properties, "run", $runtime)(); + $runtime.leave; + } + else { + given $object.properties { + when .is-a("Q::Statement::If") { + bound-method($object.properties, "run", $runtime)() + } + when .is-a("Q::Block") { + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + bound-method($object.properties.properties, "run", $runtime)(); + $runtime.leave; + } + } + } + }; + } + + if $object.is-a("Q::Statement::Return") && $name eq "run" { + return sub run-q-statement-return() { + my $value = $object.properties === NONE + ?? $object.properties + !! bound-method($object.properties, "eval", $runtime)(); + my $frame = $runtime.get-var("--RETURN-TO--"); + die X::Control::Return.new(:$value, :$frame); + }; + } + + if $object.is-a("Q::Term::Quasi") && $name eq "eval" { + return sub eval-q-term-quasi() { + sub interpolate($thing) { + return wrap($thing.value.map(&interpolate)) + if $thing.is-a("Array"); + + sub interpolate-entry($_) { .key => interpolate(.value) } + return wrap(hash($thing.value.map(&interpolate-entry))) + if $thing.is-a("Dict"); + + return $thing + if $thing ~~ _007::Type; + + return $thing + if $thing.is-a("Int") || $thing.is-a("Str"); + + return $thing + if $thing.is-a("Sub"); + + return create($thing.type, :name($thing.properties), :frame($runtime.current-frame)) + if $thing.is-a("Q::Identifier"); + + if $thing.is-a("Q::Unquote::Prefix") { + my $prefix = bound-method($thing.properties, "eval", $runtime)(); + die X::Type.new(:operation("interpolating an unquote"), :got($prefix), :expected(TYPE)) + unless $prefix.is-a("Q::Prefix"); + return create($prefix.type, :identifier($prefix.properties), :operand($thing.properties)); + } + elsif $thing.is-a("Q::Unquote::Infix") { + my $infix = bound-method($thing.properties, "eval", $runtime)(); + die X::Type.new(:operation("interpolating an unquote"), :got($infix), :expected(TYPE)) + unless $infix.is-a("Q::Infix"); + return create($infix.type, :identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); + } + + if $thing.is-a("Q::Unquote") { + my $ast = bound-method($thing.properties, "eval", $runtime)(); + die "Expression inside unquote did not evaluate to a Q" # XXX: turn into X:: + unless $ast.is-a("Q"); + return $ast; + } + + my %properties = $thing.properties.keys.map: -> $key { $key => interpolate($thing.properties{$key}) }; + + create($thing.type, |%properties); + } + + if $object.properties.value eq "Q::Unquote" && $object.properties.is-a("Q::Unquote") { + return $object.properties; + } + return interpolate($object.properties); + }; + } + + if $object.is-a("Q::Term::Sub") && $name eq "eval" { + return sub eval-q-term-sub() { + my $name = $object.properties === NONE + ?? wrap("") + !! $object.properties.properties; + my $parameterlist = $object.properties.properties; + my $statementlist = $object.properties.properties; + my $static-lexpad = $object.properties.properties; + my $outer-frame = $runtime.current-frame; + return create(TYPE, :$name, :$parameterlist, :$statementlist, :$static-lexpad, :$outer-frame); + }; + } + + if $object.is-a("Q::Term::Array") && $name eq "eval" { + return sub eval-q-term-array() { + return wrap($object.properties.value.map({ bound-method($_, "eval", $runtime)() })); + }; + } + + if $object.is-a("Q::Statement::Throw") && $name eq "run" { + return sub eval-q-statement-throw() { + my $value = $object.properties === NONE + ?? create(TYPE, :message(wrap("Died"))) + !! bound-method($object.properties, "eval", $runtime)(); + die X::Type.new(:got($value), :expected(TYPE)) + unless $value.is-a("Exception"); + + die X::_007::RuntimeException.new(:msg($value.properties.value)); + }; + } + + if $object.is-a("Q::Postfix::Index") && $name eq "put-value" { + return sub put-value-q-postfix-index($value) { + given bound-method($object.properties, "eval", $runtime)() { + if .is-a("Array") { + my $index = bound-method($object.properties, "eval", $runtime)(); + die X::Subscript::NonInteger.new + unless $index.is-a("Int"); + die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) + if $index.value >= .value; + die X::Subscript::Negative.new(:$index, :type([])) + if $index.value < 0; + .value[$index.value] = $value; + return; + } + if .is-a("Dict") || .is-a("Q") { + my $property = bound-method($object.properties, "eval", $runtime)(); + die X::Subscript::NonString.new + unless $property.is-a("Str"); + my $propname = $property.value; + $runtime.put-property($_, $propname, $value); + return; + } + die X::Type.new(:operation, :got($_), :expected(TYPE)); + } + }; + } + + if $object.is-a("Q::Postfix::Property") && $name eq "put-value" { + return sub put-value-q-postfix-property($value) { + given bound-method($object.properties, "eval", $runtime)() { + if .is-a("Dict") || .is-a("Q") { + my $propname = $object.properties.properties.value; + $runtime.put-property($_, $propname, $value); + return; + } + die "We don't handle this case yet"; # XXX: think more about this case + } + }; + } + + if $object.is-a("Q::Statement::BEGIN") && $name eq "run" { + return sub run-q-statement-begin() { + # a BEGIN block does not run at runtime + }; + } + + if $object.is-a("Q::Term::Regex") && $name eq "eval" { + return sub eval-q-term-regex() { + create(TYPE, :contents($object.properties)); + }; + } + + if $object.is-a("Q::Literal::None") && $name eq "eval" { + return sub eval-q-literal-none() { + NONE; + }; + } + + if $object.is-a("Q::Literal::Bool") && $name eq "eval" { + return sub eval-q-literal-bool() { + $object.properties; + }; + } + + if $object.is-a("Q::Expr::StatementListAdapter") && $name eq "eval" { + return sub eval-q-expr-statementlistadapter() { + return bound-method($object.properties, "run", $runtime)(); + }; + } + + if $object.is-a("Str") && $name eq "Str" { + return sub str-str() { + return $object; + } + } + + if $object.is-a("Int") && $name eq "Str" { + return sub str-int() { + return wrap(~$object.value); + } + } + + if $object.is-a("Bool") && $name eq "Str" { + return sub str-bool() { + return $object.properties; + } + } + + if $object.is-a("NoneType") && $name eq "Str" { + return sub str-nonetype() { + return $object.properties; + } + } + + if $object.is-a("Type") && $name eq "Str" { + return sub str-type() { + return wrap(""); + } + } + + if $object.is-a("Array") && $name eq "Str" { + return sub str-array() { + if $str-array-depth++ == 0 { + $str-array-seen = {}; + } + LEAVE $str-array-depth--; + + if $str-array-seen{$object.id}++ { + return wrap("[...]"); + } + + return wrap("[" ~ $object.value.map({ reprify($_, $runtime) }).join(", ") ~ "]"); + }; + } + + if $object.is-a("Dict") && $name eq "Str" { + return sub str-dict() { + if $str-dict-depth++ == 0 { + $str-dict-seen = {}; + } + LEAVE $str-dict-depth--; + + if $str-dict-seen{$object.id}++ { + return wrap(q[{...}]); + } + + return wrap('{' ~ $object.value.map({ + my $key = .key ~~ /^ [\w+]+ % '::'$/ + ?? .key + !! reprify(wrap(.key), $runtime); + "{$key}: {reprify(.value, $runtime)}"; + }).sort.join(', ') ~ '}'); + }; + } + + if $object.is-a("Str") && $name eq "repr" { + return sub repr-str() { + return wrap(q["] ~ $object.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]); + } + } + + if $object.is-a("Object") && $name eq "repr" { + return sub repr-object() { + return wrap(stringify($object, $runtime)); + } + } + + if $object.is-a("Macro") && $name eq "Str" { + return sub str-sub() { + return wrap( + sprintf "", + escaped($object.properties.value), + pretty($object.properties) + ); + }; + } + + if $object.is-a("Sub") && $name eq "Str" { + return sub str-sub() { + return wrap( + sprintf "", + escaped($object.properties.value), + pretty($object.properties) + ); + }; + } + + if $object.is-a("Q") && $name eq "Str" { + return sub str-q() { + my @props = $object.type.type-chain.reverse.map({ .fields }).flat.map({ . }); + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($object.is-a("Q::Identifier") && $_ eq "frame") && + !($object.is-a("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return wrap("{$object.type.name} { reprify($object.properties{@props[0]}, $runtime) }"); + } + sub keyvalue($prop) { $prop ~ ": " ~ reprify($object.properties{$prop}, $runtime) } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return wrap("{$object.type.name} \{\n$contents\n\}"); + }; + } + + if $object.is-a("Bool") && $name eq "Bool" { + return sub bool-bool() { + return $object; + }; + } + + if $object.is-a("NoneType") && $name eq "Bool" { + return sub bool-nonetype() { + return FALSE; + }; + } + + if $object.is-a("Int") && $name eq "Bool" { + return sub bool-int() { + return wrap($object.value != 0); + }; + } + + if $object.is-a("Str") && $name eq "Bool" { + return sub bool-str() { + return wrap($object.value ne ""); + }; + } + + if $object.is-a("Array") && $name eq "Bool" { + return sub bool-array() { + return wrap($object.value.elems > 0); + }; + } + + if $object.is-a("Dict") && $name eq "Bool" { + return sub bool-dict() { + return wrap($object.value.keys > 0); + }; + } + + if $object.is-a("Object") && $name eq "Bool" { + return sub bool-object() { + return TRUE; + }; + } + + if $object.is-a("Int") && $name eq "abs" { + return sub abs-int() { + return wrap($object.value.abs); + }; + } + + if $object.is-a("Int") && $name eq "chr" { + return sub chr-int() { + return wrap($object.value.chr); + }; + } + + if $object.is-a("Str") && $name eq "ord" { + return sub ord-str() { + return wrap($object.value.ord); + }; + } + + if $object.is-a("Str") && $name eq "chars" { + return sub chars-str() { + return wrap($object.value.chars); + }; + } + + if $object.is-a("Str") && $name eq "uc" { + return sub uc-str() { + return wrap($object.value.uc); + }; + } + + if $object.is-a("Str") && $name eq "lc" { + return sub lc-str() { + return wrap($object.value.lc); + }; + } + + if $object.is-a("Str") && $name eq "trim" { + return sub trim-str() { + return wrap($object.value.trim); + }; + } + + if $object.is-a("Str") && $name eq "split" { + return sub split-str($sep) { + die X::Type.new(:operation, :got($sep), :expected(TYPE)) + unless $sep.is-a("Str"); + return wrap($object.value.split($sep.value).map(&wrap)); + }; + } + + if $object.is-a("Array") && $name eq "join" { + return sub join-array($sep) { + die X::Type.new(:operation, :got($sep), :expected(TYPE)) + unless $sep.is-a("Str"); + return wrap($object.value.map({ stringify($_, $runtime) }).join($sep.value)); + }; + } + + if $object.is-a("Str") && $name eq "index" { + return sub index-str($substr) { + die X::Type.new(:operation, :got($substr), :expected(TYPE)) + unless $substr.is-a("Str"); + return wrap($object.value.index($substr.value) // -1); + }; + } + + if $object.is-a("Str") && $name eq "substr" { + return sub substr-str($pos, $chars) { + # XXX: typecheck $pos and $chars + return wrap($object.value.substr($pos.value, $chars.value)); + }; + } + + if $object.is-a("Str") && $name eq "prefix" { + return sub prefix-str($pos) { + # XXX: typecheck $pos + return wrap($object.value.substr(0, $pos.value)); + }; + } + + if $object.is-a("Str") && $name eq "suffix" { + return sub suffix-str($pos) { + # XXX: typecheck $pos + return wrap($object.value.substr($pos.value)); + }; + } + + if $object.is-a("Str") && $name eq "contains" { + return sub contains-str($substr) { + die X::Type.new(:operation, :got($substr), :expected(TYPE)) + unless $substr.is-a("Str"); + return wrap($object.value.contains($substr.value)); + }; + } + + if $object.is-a("Str") && $name eq "charat" { + return sub charat-str($pos) { + die X::Type.new(:operation, :got($pos), :expected(TYPE)) + unless $pos.is-a("Int"); + + my $s = $object.value; + + die X::Subscript::TooLarge.new(:value($pos.value), :length($s.chars)) + if $pos.value >= $s.chars; + + return wrap($s.substr($pos.value, 1)); + }; + } + + if $object.is-a("Array") && $name eq "concat" { + return sub concat-array($array) { + die X::Type.new(:operation, :got($array), :expected(TYPE)) + unless $array.is-a("Array"); + return wrap([|$object.value, |$array.value]); + }; + } + + if $object.is-a("Array") && $name eq "reverse" { + return sub reverse-array() { + return wrap($object.value.reverse); + }; + } + + if $object.is-a("Array") && $name eq "sort" { + return sub sort-array() { + # XXX: this method needs to be seriously reconsidered once comparison methods can be defined on + # custom objects + # XXX: should also disallow sorting on heterogenous types + return wrap($object.value.map({ + die "Cannot sort a {.type.name}" + if $_ !~~ _007::Object::Wrapped; + .value; + }).sort().map(&wrap)); + }; + } + + if $object.is-a("Array") && $name eq "shuffle" { + return sub shuffle-array() { + return wrap($object.value.pick(*)); + }; + } + + if $object.is-a("Array") && $name eq "size" { + return sub size-array() { + return wrap($object.value.elems); + }; + } + + if $object.is-a("Array") && $name eq "push" { + return sub push-array($newelem) { + $object.value.push($newelem); + return NONE; + }; + } + + if $object.is-a("Array") && $name eq "pop" { + return sub pop-array() { + die X::Cannot::Empty.new(:action, :what("Array")) + if $object.value.elems == 0; + return $object.value.pop(); + }; + } + + if $object.is-a("Array") && $name eq "shift" { + return sub shift-array() { + die X::Cannot::Empty.new(:action, :what($object.^name)) + if $object.value.elems == 0; + return $object.value.shift(); + }; + } + + if $object.is-a("Array") && $name eq "unshift" { + return sub unshift-array($newelem) { + $object.value.unshift($newelem); + return NONE; + }; + } + + if $object.is-a("Array") && $name eq "map" { + return sub map-array($fn) { + # XXX: Need to typecheck here if $fn is callable + my @elements = $object.value.map({ internal-call($fn, $runtime, [$_]) }); + return wrap(@elements); + }; + } + + if $object.is-a("Array") && $name eq "filter" { + return sub filter-array($fn) { + # XXX: Need to typecheck here if $fn is callable + my @elements = $object.value.grep({ boolify(internal-call($fn, $runtime, [$_]), $runtime) }); + return wrap(@elements); + }; + } + + if $object.is-a("Regex") && $name eq "fullmatch" { + return sub fullmatch-regex($str) { + die X::Regex::InvalidMatchType.new + unless $str.is-a("Str"); + + my $regex-string = $object.properties.value; + + return wrap($regex-string eq $str.value); + }; + } + + if $object.is-a("Regex") && $name eq "search" { + return sub search-regex($str) { + die X::Regex::InvalidMatchType.new + unless $str.is-a("Str"); + + my $regex-string = $object.properties.value; + + return wrap($str.value.contains($regex-string)); + }; + } + + if $object.is-a("Dict") && $name eq "size" { + return sub size-dict() { + return wrap($object.value.elems); + }; + } + + if $object.is-a("Q") && $name eq "detach" { + sub interpolate($thing) { + return wrap($thing.value.map(&interpolate)) + if $thing.is-a("Array"); + + sub interpolate-entry($_) { .key => interpolate(.value) } + return wrap(hash($thing.value.map(&interpolate-entry))) + if $thing.is-a("Dict"); + + return create($thing.type, :name($thing.properties)) + if $thing.is-a("Q::Identifier"); + + return $thing + if $thing.is-a("Q::Unquote"); + + my %properties = $thing.type.type-chain.reverse.map({ .fields }).flat.map: -> $field { + my $fieldname = $field; + $fieldname => interpolate($thing.properties{$fieldname}); + }; + + create($thing.type, |%properties); + } + + return sub detach-q() { + return interpolate($object); + }; + } + + if $object.is-a("Type") && $name eq "create" { + return sub create-type($properties) { + # XXX: check that $properties is an array of [k, v] arrays + create($object, |hash($properties.value.map(-> $p { + my ($k, $v) = @($p.value); + $k.value => $v; + }))); + }; + } + + if $object.is-a("Object") && $name eq "get" { + return sub get-object($propname) { + # XXX: typecheck $propname as Str + die X::Property::NotFound.new(:$propname, :type($object.type.name)) + unless $object.properties{$propname.value} :exists; + return $object.properties{$propname.value}; + }; + } + + if $object.is-a("Dict") && $name eq "keys" { + return sub keys-dict() { + return wrap($object.value.keys.map(&wrap)); + }; + } + + die X::Property::NotFound.new(:propname($name), :type($object.type.name)); +} + +# There used to be a &wrap function in Builtins.pm, which simulataneously did too much and too little. +# It did too much in that it *recursively* wrapped array types, to any depth. It did too little in that +# it silently passed over values that were already effectively wrapped. +# This new version intentionally has a much thinner interface, in that it expects an *unwrapped* +# (Perl 6-level) type, and returns a wrapped equivalent. It also does no structural recursion; the +# elements of arrays and values of dicts have to be wrapped on the caller side. +sub wrap($value) is export { + if $value ~~ Bool { + return $value ?? TRUE !! FALSE; + } + elsif $value ~~ Int { + return _007::Object::Wrapped.new(:type(TYPE), :$value); + } + elsif $value ~~ Str { + return _007::Object::Wrapped.new(:type(TYPE), :$value); + } + elsif $value ~~ Array | Seq { + return _007::Object::Wrapped.new(:type(TYPE), :value($value.Array)); + } + elsif $value ~~ Hash { + return _007::Object::Wrapped.new(:type(TYPE), :$value); + } + elsif $value ~~ Nil { + return NONE; + } + else { + die "Tried to wrap unknown value ", $value.^name; + } +} + +sub wrap-fn(&value, $name = &value.name) is export { + my &ditch-sigil = { $^str.substr(1) }; + my ¶meter = -> $name { create(TYPE, :identifier(create(TYPE, :name(wrap($name))))) }; + my @elements = &value.signature.params».name».&ditch-sigil».¶meter; + my $parameterlist = create(TYPE, :parameters(wrap(@elements))); + my $statementlist = create(TYPE, :statements(wrap([]))); + my %properties = + name => wrap($name), + :$parameterlist, + :$statementlist, + ; + return _007::Object::Wrapped.new(:type(TYPE), :&value, :%properties); +} + +sub internal-call(_007::Object $sub, $runtime, @arguments) is export { + die "Tried to call a {$sub.^name}, expected a Sub" + unless $sub.is-a("Sub"); # XXX: should do subtyping check + + if $sub ~~ _007::Object::Wrapped && $sub.type === TYPE { + die "Don't handle the wrapped macro case yet"; + } + + if $sub ~~ _007::Object::Wrapped && $sub.type === TYPE { + return $sub.value()(|@arguments); + } + + my $paramcount = $sub.properties.properties.value.elems; + my $argcount = @arguments.elems; + die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) + unless $paramcount == $argcount; + $runtime.enter($sub.properties, $sub.properties, $sub.properties, $sub); + for @($sub.properties.properties.value) Z @arguments -> ($param, $arg) { + $runtime.declare-var($param.properties, $arg); + } + $runtime.register-subhandler; + my $frame = $runtime.current-frame; + my $value = bound-method($sub.properties, "run", $runtime)(); + $runtime.leave; + CATCH { + when X::Control::Return { + $runtime.unroll-to($frame); + $runtime.leave; + return .value; + } + } + return $value || NONE; +} diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 45dba72a..3bef5af5 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -1,7 +1,11 @@ -use _007::Val; -use _007::Q; +use _007::Type; +use _007::Object; use _007::Precedence; +class X::Associativity::Conflict is Exception { + method message { "The operator already has a defined associativity" } +} + class _007::OpScope { has %.ops = prefix => {}, @@ -15,12 +19,12 @@ class _007::OpScope { method install($type, $op, $q?, :%precedence, :$assoc) { my $name = "$type:$op"; - my $identifier = Q::Identifier.new(:name(Val::Str.new(:value($name)))); + my $identifier = create(TYPE, :name(wrap($name))); %!ops{$type}{$op} = $q !=== Any ?? $q !! { - prefix => Q::Prefix.new(:$identifier), - infix => Q::Infix.new(:$identifier), - postfix => Q::Postfix.new(:$identifier), + prefix => create(TYPE, :$identifier, :operand(NONE)), + infix => create(TYPE, :$identifier, :lhs(NONE), :rhs(NONE)), + postfix => create(TYPE, :$identifier, :operand(NONE)), }{$type}; sub prec { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 8e8d87f9..3234f74d 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -1,7 +1,6 @@ -use _007::Val; -use _007::Q; +use _007::Type; +use _007::Object; use _007::Parser::Syntax; -use MONKEY-SEE-NO-EVAL; class X::String::Newline is Exception { method message { "Found a newline inside a string literal" } @@ -52,29 +51,12 @@ class X::Precedence::Incompatible is Exception { method message { "Trying to relate a pre/postfix operator with an infix operator" } } -class X::Property::NotDeclared is Exception { - has Str $.type; - has Str $.property; - - method message { "The property '$.property' is not defined on type '$.type'" } -} - -class X::Property::Required is Exception { - has Str $.type; - has Str $.property; - - method message { "The property '$.property' is required on type '$.type'" } -} - -class X::Property::Duplicate is Exception { - has Str $.property; - - method message { "The property '$.property' was declared more than once in a property list" } -} +sub empty-array() { wrap([]) } +sub empty-dict() { wrap({}) } class _007::Parser::Actions { method finish-block($block) { - $block.static-lexpad = $*runtime.current-frame.properties; + $block.properties = $*runtime.current-frame.value; $*runtime.leave; } @@ -83,20 +65,24 @@ class _007::Parser::Actions { } method compunit($/) { - my $cu = Q::CompUnit.new(:block(Q::Block.new( - :parameterlist(Q::ParameterList.new), - :statementlist($.ast) - ))); - make $cu; - self.finish-block($cu.block); + my $block = create(TYPE, + :parameterlist(create(TYPE, + :parameters(empty-array()), + )), + :statementlist($.ast), + :static-lexpad(empty-dict()), + ); + make create(TYPE, :$block); + self.finish-block($block); } method statementlist($/) { - make Q::StatementList.new(:statements(Val::Array.new(:elements($».ast)))); + my $statements = wrap($».ast); + make create(TYPE, :$statements); } method statement:my ($/) { - make Q::Statement::My.new( + make create(TYPE, :identifier($.ast), :expr($ ?? $.ast !! NONE)); } @@ -105,37 +91,37 @@ class _007::Parser::Actions { die X::Syntax::Missing.new(:what("initializer on constant declaration")) unless $; - make Q::Statement::Constant.new( + make create(TYPE, :identifier($.ast), :expr($.ast)); - my $value = $.ast.eval($*runtime); - $.ast.put-value($value, $*runtime); + my $value = bound-method($.ast, "eval", $*runtime)(); + bound-method($.ast, "put-value", $*runtime)($value); } method statement:expr ($/) { # XXX: this is a special case for macros that have been expanded at the # top level of an expression statement, but it could happen anywhere # in the expression tree - if $.ast ~~ Q::Block { - make Q::Statement::Expr.new(:expr(Q::Postfix::Call.new( - :identifier(Q::Identifier.new(:name(Val::Str.new(:value("postfix:()"))))), - :operand(Q::Term::Sub.new(:identifier(NONE), :block($.ast))), - :argumentlist(Q::ArgumentList.new) + if $.ast.is-a("Q::Block") { + make create(TYPE, :expr(create(TYPE, + :identifier(create(TYPE, :name(wrap("postfix:()")))), + :operand(create(TYPE, :identifier(NONE), :block($.ast))), + :argumentlist(create(TYPE)) ))); } else { - make Q::Statement::Expr.new(:expr($.ast)); + make create(TYPE, :expr($.ast)); } } method statement:block ($/) { die X::PointyBlock::SinkContext.new if $; - make Q::Statement::Block.new(:block($.ast)); + make create(TYPE, :block($.ast)); } - sub maybe-install-operator($identname, @trait) { + sub maybe-install-operator(Str $identname, @trait) { return unless $identname ~~ /^ (< prefix infix postfix >) ':' (.+) /; @@ -147,26 +133,26 @@ class _007::Parser::Actions { my @prec-traits = ; my $assoc; for @trait -> $trait { - my $name = $trait.ast.name; + my $name = $trait.ast.properties.value; if $name eq any @prec-traits { my $identifier = $trait.ast; my $prep = $name eq "equal" ?? "to" !! "than"; die "The thing your op is $name $prep must be an identifier" - unless $identifier ~~ Q::Identifier; - sub check-if-op($s) { + unless $identifier.is-a("Q::Identifier"); + sub check-if-op(Str $s) { die "Unknown thing in '$name' trait" unless $s ~~ /^ < pre in post > 'fix:' /; die X::Precedence::Incompatible.new if $type eq ('prefix' | 'postfix') && $s ~~ /^ in/ || $type eq 'infix' && $s ~~ /^ < pre post >/; %precedence{$name} = $s; - }($identifier.name); + }($identifier.properties.value); } elsif $name eq "assoc" { my $string = $trait.ast; die "The associativity must be a string" - unless $string ~~ Q::Literal::Str; - my $value = $string.value.value; + unless $string.is-a("Q::Literal::Str"); + my Str $value = $string.properties.value; die X::Trait::IllegalValue.new(:trait, :$value) unless $value eq any "left", "non", "right"; $assoc = $value; @@ -187,42 +173,46 @@ class _007::Parser::Actions { method statement:sub-or-macro ($/) { my $identifier = $.ast; - my $name = $.ast.name; + my $name = $identifier.properties; my $parameterlist = $.ast; my $traitlist = $.ast; my $statementlist = $.ast; - my $block = Q::Block.new(:$parameterlist, :$statementlist); - my $static-lexpad = $*runtime.current-frame.properties; + my $block = create(TYPE, + :$parameterlist, + :$statementlist, + :static-lexpad(empty-dict()), + ); + my $static-lexpad = $*runtime.current-frame.value; self.finish-block($block); my $outer-frame = $*runtime.current-frame; my $val; if $ eq "sub" { - make Q::Statement::Sub.new(:$identifier, :$traitlist, :$block); - $val = Val::Sub.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + make create(TYPE, :$identifier, :$traitlist, :$block); + $val = create(TYPE, :$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); } elsif $ eq "macro" { - make Q::Statement::Macro.new(:$identifier, :$traitlist, :$block); - $val = Val::Macro.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + make create(TYPE, :$identifier, :$traitlist, :$block); + $val = create(TYPE, :$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); } else { die "Unknown routine type $"; # XXX: Turn this into an X:: exception } - $identifier.put-value($val, $*runtime); + bound-method($identifier, "put-value", $*runtime)($val); - maybe-install-operator($name, $); + maybe-install-operator($name.value, $); } method statement:return ($/) { die X::ControlFlow::Return.new unless $*insub; - make Q::Statement::Return.new(:expr($ ?? $.ast !! NONE)); + make create(TYPE, :expr($ ?? $.ast !! NONE)); } method statement:throw ($/) { - make Q::Statement::Throw.new(:expr($ ?? $.ast !! NONE)); + make create(TYPE, :expr($ ?? $.ast !! NONE)); } method statement:if ($/) { @@ -231,61 +221,64 @@ class _007::Parser::Actions { ?? $.ast !! NONE; - make Q::Statement::If.new(|%parameters); + make create(TYPE, |%parameters); } method statement:for ($/) { - make Q::Statement::For.new(|$.ast); + make create(TYPE, |$.ast); } method statement:while ($/) { - make Q::Statement::While.new(|$.ast); + make create(TYPE, |$.ast); } method statement:BEGIN ($/) { my $block = $.ast; - make Q::Statement::BEGIN.new(:$block); - $*runtime.run(Q::CompUnit.new(:$block)); + make create(TYPE, :$block); + $*runtime.run(create(TYPE, :$block)); } method statement:class ($/) { my $identifier = $.ast; my $block = $.ast; - make Q::Statement::Class.new(:$block); - my $val = Val::Type.of(EVAL qq[class :: \{ - method attributes \{ () \} - method ^name(\$) \{ "{$identifier.name.value}" \} - \}]); - $identifier.put-value($val, $*runtime); + make create(TYPE, :$block); + my $name = $identifier.properties.value; + my $val = _007::Type.new(:$name); + bound-method($identifier, "put-value", $*runtime)($val); } method traitlist($/) { my @traits = $».ast; - if bag( @traits.map: *.identifier.name.value ).grep( *.value > 1 )[0] -> $p { + if bag( @traits.map: *.properties.properties.value ).grep( *.value > 1 )[0] -> $p { my $trait = $p.key; die X::Trait::Duplicate.new(:$trait); } - make Q::TraitList.new(:traits(Val::Array.new(:elements(@traits)))); + my $traits = wrap(@traits); + make create(TYPE, :$traits); } method trait($/) { - make Q::Trait.new(:identifier($.ast), :expr($.ast)); + make create(TYPE, :identifier($.ast), :expr($.ast)); } method blockoid ($/) { make $.ast; } method block ($/) { - my $block = Q::Block.new( - :parameterlist(Q::ParameterList.new), - :statementlist($.ast)); + my $block = create(TYPE, + :parameterlist(create(TYPE, + :parameters(empty-array()), + )), + :statementlist($.ast) + :static-lexpad(NONE)); make $block; self.finish-block($block); } method pblock ($/) { if $ { - my $block = Q::Block.new( + my $block = create(TYPE, :parameterlist($.ast), - :statementlist($.ast)); + :statementlist($.ast), + :static-lexpad(empty-dict())); make $block; self.finish-block($block); } else { @@ -300,36 +293,38 @@ class _007::Parser::Actions { } sub is-macro($q, $qtype, $identifier) { - $q ~~ $qtype - && $identifier ~~ Q::Identifier - && (my $macro = $*runtime.maybe-get-var($identifier.name.value)) ~~ Val::Macro - && $macro; + $q.is-a($qtype) + && $identifier.is-a("Q::Identifier") + && defined((my $macro = $*runtime.maybe-get-var($identifier.properties.value))) + && $macro.is-a("Macro"); } sub expand($macro, @arguments, &unexpanded-callback:()) { - my $expansion = $*runtime.call($macro, @arguments); + my $expansion = internal-call($macro, $*runtime, @arguments); - if $expansion ~~ Q::Statement::My { - _007::Parser::Syntax::declare(Q::Statement::My, $expansion.identifier.name.value); + if $expansion.is-a("Q::Statement::My") { + _007::Parser::Syntax::declare(TYPE, $expansion.properties.properties.value); } if $*unexpanded { return &unexpanded-callback(); } else { - if $expansion ~~ Q::Statement { - $expansion = Q::StatementList.new(:statements(Val::Array.new(:elements([$expansion])))); + if $expansion.is-a("Q::Statement") { + my $statements = wrap([$expansion]); + $expansion = create(TYPE, :$statements); } elsif $expansion === NONE { - $expansion = Q::StatementList.new(:statements(Val::Array.new(:elements([])))); + my $statements = wrap([]); + $expansion = create(TYPE, :$statements); } - if $expansion ~~ Q::StatementList { - $expansion = Q::Expr::StatementListAdapter.new(:statementlist($expansion)); + if $expansion.is-a("Q::StatementList") { + $expansion = create(TYPE, :statementlist($expansion)); } - if $expansion ~~ Q::Block { - $expansion = Q::Expr::StatementListAdapter.new(:statementlist($expansion.statementlist)); + if $expansion.is-a("Q::Block") { + $expansion = create(TYPE, :statementlist($expansion.properties)); } return $expansion; @@ -338,7 +333,7 @@ class _007::Parser::Actions { method EXPR($/) { sub name($op) { - $op.identifier.name.value; + $op.properties.properties.value; } sub tighter($op1, $op2, $_ = $*parser.opscope.infixprec) { @@ -357,6 +352,11 @@ class _007::Parser::Actions { return $*parser.opscope.infixprec.first(*.contains(name($op))).assoc eq "non"; } + # XXX: this needs to be lifted up to 007 eventually + sub is-assignable(_007::Type $decltype) { + return $decltype === TYPE || $decltype === TYPE; + } + my @opstack; my @termstack = $[0].ast; sub REDUCE { @@ -364,27 +364,32 @@ class _007::Parser::Actions { my $infix = @opstack.pop; my $t1 = @termstack.pop; - if $infix ~~ Q::Unquote { - @termstack.push(Q::Unquote::Infix.new(:qtype($infix.qtype), :expr($infix.expr), :lhs($t1), :rhs($t2))); + if $infix.is-a("Q::Unquote") { + @termstack.push(create(TYPE, + :qtype($infix.properties), + :expr($infix.properties), + :lhs($t1), + :rhs($t2), + )); return; } - if my $macro = is-macro($infix, Q::Infix, $infix.identifier) { + if my $macro = is-macro($infix, TYPE, $infix.properties) { @termstack.push(expand($macro, [$t1, $t2], - -> { $infix.new(:lhs($t1), :rhs($t2), :identifier($infix.identifier)) })); + -> { create($infix.type, :lhs($t1), :rhs($t2), :identifier($infix.properties)) })); } else { - @termstack.push($infix.new(:lhs($t1), :rhs($t2), :identifier($infix.identifier))); + @termstack.push(create($infix.type, :lhs($t1), :rhs($t2), :identifier($infix.properties))); - if $infix ~~ Q::Infix::Assignment && $t1 ~~ Q::Identifier { + if $infix.is-a("Q::Infix::Assignment") && $t1.is-a("Q::Identifier") { my $frame = $*runtime.current-frame; - my $symbol = $t1.name.value; + my $symbol = $t1.properties.value; die X::Undeclared.new(:$symbol) unless @*declstack[*-1]{$symbol} :exists; my $decltype = @*declstack[*-1]{$symbol}; my $declname = $decltype.^name.subst(/ .* '::'/, "").lc; die X::Assignment::RO.new(:typename("$declname '$symbol'")) - unless $decltype.is-assignable; + unless is-assignable($decltype); %*assigned{$frame.id ~ $symbol}++; } } @@ -395,7 +400,9 @@ class _007::Parser::Actions { || equal(@opstack[*-1], $infix) && left-associative($infix)) { REDUCE; } - die X::Op::Nonassociative.new(:op1(@opstack[*-1].identifier.name.value), :op2($infix.identifier.name.value)) + die X::Op::Nonassociative.new( + :op1(@opstack[*-1].properties.properties.value), + :op2($infix.properties.properties.value)) if @opstack && equal(@opstack[*-1], $infix) && non-associative($infix); @opstack.push($infix); @termstack.push($term); @@ -409,7 +416,7 @@ class _007::Parser::Actions { method termish($/) { sub name($op) { - $op.identifier.name.value; + $op.properties.properties.value; } sub tighter($op1, $op2, $_ = $*parser.opscope.prepostfixprec) { @@ -436,43 +443,49 @@ class _007::Parser::Actions { sub handle-prefix($/) { my $prefix = @prefixes.shift.ast; - if $prefix ~~ Q::Unquote { - make Q::Unquote::Prefix.new(:qtype($prefix.qtype), :expr($prefix.expr), :operand($/.ast)); + if $prefix.is-a("Q::Unquote") { + make create(TYPE, + :qtype($prefix.properties), + :expr($prefix.properties), + :operand($/.ast), + ); return; } - if my $macro = is-macro($prefix, Q::Prefix, $prefix.identifier) { + if my $macro = is-macro($prefix, TYPE, $prefix.properties) { make expand($macro, [$/.ast], - -> { $prefix.new(:operand($/.ast), :identifier($prefix.identifier)) }); + -> { create($prefix.type, :operand($/.ast), :identifier($prefix.properties)) }); } else { - make $prefix.new(:operand($/.ast), :identifier($prefix.identifier)); + make create($prefix.type, :operand($/.ast), :identifier($prefix.properties)); } } sub handle-postfix($/) { my $postfix = @postfixes.shift.ast; - my $identifier = $postfix.identifier; - if my $macro = is-macro($postfix, Q::Postfix::Call, $/.ast) { - make expand($macro, $postfix.argumentlist.arguments.elements, - -> { $postfix.new(:$identifier, :operand($/.ast), :argumentlist($postfix.argumentlist)) }); + my $identifier = $postfix.properties; + if is-macro($postfix, TYPE, $/.ast) -> $macro { + make expand($macro, $postfix.properties.properties.value, -> { + create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); + }); } - elsif $postfix ~~ Q::Postfix::Index { - make $postfix.new(:$identifier, :operand($/.ast), :index($postfix.index)); + elsif $postfix.is-a("Q::Postfix::Index") { + make create($postfix.type, :$identifier, :operand($/.ast), :index($postfix.properties)); } - elsif $postfix ~~ Q::Postfix::Call { - make $postfix.new(:$identifier, :operand($/.ast), :argumentlist($postfix.argumentlist)); + elsif $postfix.is-a("Q::Postfix::Call") { + make create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); } - elsif $postfix ~~ Q::Postfix::Property { - make $postfix.new(:$identifier, :operand($/.ast), :property($postfix.property)); + elsif $postfix.is-a("Q::Postfix::Property") { + make create($postfix.type, :$identifier, :operand($/.ast), :property($postfix.properties)); } else { - if my $macro = is-macro($postfix, Q::Postfix, $identifier) { - make expand($macro, [$/.ast], - -> { $postfix.new(:$identifier, :operand($/.ast)) }); + if is-macro($postfix, TYPE, $identifier) -> $macro { + make expand($macro, [$/.ast], -> { + create($postfix.type, :$identifier, :operand($/.ast)); + }); } else { - make $postfix.new(:$identifier, :operand($/.ast)); + make create($postfix.type, :$identifier, :operand($/.ast)); } } } @@ -503,11 +516,11 @@ class _007::Parser::Actions { method prefix($/) { my $op = ~$/; - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("prefix:$op"))), + my $identifier = create(TYPE, + :name(wrap("prefix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.new(:$identifier, :operand(Val::NoneType)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :operand(NONE)); } method prefix-unquote($/) { @@ -519,25 +532,24 @@ class _007::Parser::Actions { die X::String::Newline.new if $s ~~ /\n/; }(~$0); - my $value = (~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g); - $value = Val::Str.new(:$value); - make Q::Literal::Str.new(:$value); + my $value = wrap((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); + make create(TYPE, :$value); } method term:none ($/) { - make Q::Literal::None.new; + make create(TYPE); } method term:false ($/) { - make Q::Literal::Bool.new(:value(Val::Bool.new(:value(False)))); + make create(TYPE, :value(FALSE)); } method term:true ($/) { - make Q::Literal::Bool.new(:value(Val::Bool.new(:value(True)))); + make create(TYPE, :value(TRUE)); } method term:int ($/) { - make Q::Literal::Int.new(:value(Val::Int.new(:value(+$/)))); + make create(TYPE, :value(wrap(+$/))); } method term:str ($/) { @@ -545,7 +557,8 @@ class _007::Parser::Actions { } method term:array ($/) { - make Q::Term::Array.new(:elements(Val::Array.new(:elements($».ast)))); + my $elements = wrap($».ast); + make create(TYPE, :$elements); } method term:parens ($/) { @@ -553,20 +566,22 @@ class _007::Parser::Actions { } method term:regex ($/) { - make Q::Term::Regex.new(:contents($.ast.value)); + make create(TYPE, :contents($.ast.properties)); } method term:identifier ($/) { make $.ast; - my $name = $.ast.name.value; + my $name = $.ast.properties.value; if !$*runtime.declared($name) { my $frame = $*runtime.current-frame; $*parser.postpone: sub checking-postdeclared { my $value = $*runtime.maybe-get-var($name, $frame); + die X::Undeclared.new(:symbol($name)) + unless defined $value; die X::Macro::Postdeclared.new(:$name) - if $value ~~ Val::Macro; + if $value.is-a("Macro"); die X::Undeclared.new(:symbol($name)) - unless $value ~~ Val::Sub; + unless $value.is-a("Sub"); }; } } @@ -576,7 +591,7 @@ class _007::Parser::Actions { } method term:quasi ($/) { - my $qtype = Val::Str.new(:value(~($ // ""))); + my $qtype = wrap(~($ // "")); if $ -> $block { # If the quasi consists of a block with a single expression statement, it's very @@ -591,22 +606,22 @@ class _007::Parser::Actions { if $qtype.value eq "Q::Statement" { # XXX: make sure there's only one statement (suboptimal; should parse-error sooner) - my $contents = $block.ast.statementlist.statements.elements[0]; - make Q::Term::Quasi.new(:$contents, :$qtype); + my $contents = $block.ast.properties.properties.value[0]; + make create(TYPE, :$contents, :$qtype); return; } elsif $qtype.value eq "Q::StatementList" { - my $contents = $block.ast.statementlist; - make Q::Term::Quasi.new(:$contents, :$qtype); + my $contents = $block.ast.properties; + make create(TYPE, :$contents, :$qtype); return; } elsif $qtype.value ne "Q::Block" - && $block.ast ~~ Q::Block - && $block.ast.statementlist.statements.elements.elems == 1 - && $block.ast.statementlist.statements.elements[0] ~~ Q::Statement::Expr { + && $block.ast.is-a("Q::Block") + && $block.ast.properties.properties.value.elems == 1 + && $block.ast.properties.properties.value[0].is-a("Q::Statement::Expr") { - my $contents = $block.ast.statementlist.statements.elements[0].expr; - make Q::Term::Quasi.new(:$contents, :$qtype); + my $contents = $block.ast.properties.properties.value[0].properties; + make create(TYPE, :$contents, :$qtype); return; } } @@ -617,7 +632,7 @@ class _007::Parser::Actions { if $/{$subrule} -> $submatch { my $contents = $submatch.ast; - make Q::Term::Quasi.new(:$contents, :$qtype); + make create(TYPE, :$contents, :$qtype); return; } } @@ -630,115 +645,122 @@ class _007::Parser::Actions { my $traitlist = $.ast; my $statementlist = $.ast; - my $block = Q::Block.new(:$parameterlist, :$statementlist); + my $block = create(TYPE, :$parameterlist, :$statementlist, :static-lexpad(empty-dict())); if $ { - my $name = $.ast.name; - my $outer-frame = $*runtime.current-frame.properties; - my $static-lexpad = $*runtime.current-frame.properties; - my $val = Val::Sub.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); - $.ast.put-value($val, $*runtime); + my $name = $.ast.properties; + my $outer-frame = $*runtime.current-frame.value; + my $static-lexpad = $*runtime.current-frame.value; + my $val = create(TYPE, :$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + bound-method($.ast, "put-value", $*runtime)($val); } self.finish-block($block); - my $name = $.ast.name; + my $name = $ && $.ast.properties; my $identifier = $ - ?? Q::Identifier.new(:$name) + ?? create(TYPE, :$name) !! NONE; - make Q::Term::Sub.new(:$identifier, :$traitlist, :$block); + make create(TYPE, :$identifier, :$traitlist, :$block); } method unquote ($/) { my $qtype = $ - ?? $*runtime.get-var($.ast.name.value).type - !! Q::Term; - make Q::Unquote.new(:$qtype, :expr($.ast)); + ?? $*runtime.get-var($.ast.properties.value) + !! TYPE; + make create(TYPE, :$qtype, :expr($.ast)); } method term:new-object ($/) { - my $type = $.ast.name.value; - my $type-obj = $*runtime.get-var($type).type; - - if $type-obj !=== Val::Object { - sub aname($attr) { $attr.name.substr(2) } - my %known-properties = $type-obj.attributes.map({ aname($_) => 1 }); - for $.ast.properties.elements -> $p { - my $property = $p.key.value; - die X::Property::NotDeclared.new(:$type, :$property) - unless %known-properties{$property}; - } - for %known-properties.keys -> $property { - # If an attribute has an initializer, then we don't require that it be - # passed, since it will get a sensible value anyway. - next if $type-obj.^attributes.first({ .name.substr(2) eq $property }).build; - - die X::Property::Required.new(:$type, :$property) - unless $property eq any($.ast.properties.elements».key».value); - } - } - - make Q::Term::Object.new( - :type(Q::Identifier.new(:name(Val::Str.new(:value($type))))), + my $type = $.ast.properties.value; + my $type-obj = $*runtime.get-var($type); + + my @known-properties = $type-obj.type-chain.reverse.map({ .fields }).flat; + my $seen-properties = set(); + for $.ast.properties.value -> $p { + my $property = $p.properties.value; + # Here we make a slight exception for the wrapped types + next if $property eq "value" && $type eq "Int" | "Str" | "Array" | "Dict"; + die X::Property::NotDeclared.new(:$type, :$property) + unless $property (elem) @known-properties.map({ . }); + $seen-properties (|)= $property; + } + for @known-properties -> $p { + next if $p; + + my $property = $p; + die X::Property::Required.new(:$type, :$property) + unless $property (elem) $seen-properties; + } + + make create(TYPE, + # XXX: couldn't we just pass $type here? + :type(create(TYPE, :name(wrap($type)))), :propertylist($.ast)); } - method term:object ($/) { - my $type = "Object"; - my $name = Val::Str.new(:value($type)); - my $frame = $*runtime.builtin-frame; - - make Q::Term::Object.new( - :type(Q::Identifier.new(:$name, :$frame)), + method term:dict ($/) { + make create(TYPE, :propertylist($.ast)); } method propertylist ($/) { my %seen; - for $».ast -> Q::Property $p { - my Str $property = $p.key.value; + for $».ast -> $p { + my Str $property = $p.properties.value; die X::Property::Duplicate.new(:$property) if %seen{$property}++; } - make Q::PropertyList.new(:properties(Val::Array.new(:elements($».ast)))); + my $properties = wrap($».ast); + make create(TYPE, :$properties); } method property:str-expr ($/) { - make Q::Property.new(:key($.ast.value), :value($.ast)); + make create(TYPE, :key($.ast.properties), :value($.ast)); } method property:identifier-expr ($/) { - my $key = $.ast.name; - make Q::Property.new(:$key, :value($.ast)); + my $key = $.ast.properties; + make create(TYPE, :$key, :value($.ast)); } method property:identifier ($/) { - my $key = $.ast.name; - make Q::Property.new(:$key, :value($.ast)); + my $key = $.ast.properties; + make create(TYPE, :$key, :value($.ast)); } method property:method ($/) { - my $block = Q::Block.new( + my $block = create(TYPE, :parameterlist($.ast), - :statementlist($.ast)); - my $name = $.ast.name; - my $identifier = Q::Identifier.new(:$name); - make Q::Property.new(:key($name), :value( - Q::Term::Sub.new(:$identifier, :$block))); + :statementlist($.ast), + :static-lexpad(wrap({})), + ); + my $name = $.ast.properties; + my $identifier = create(TYPE, :$name); + make create(TYPE, + :key($name), + :value(create(TYPE, + :$identifier, + :$block, + :traitlist(create(TYPE, + :traits(wrap([])), + )), + )), + ); self.finish-block($block); } method infix($/) { my $op = ~$/; - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("infix:$op"))), + my $identifier = create(TYPE, + :name(wrap("infix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.new(:$identifier, :lhs(NONE), :rhs(NONE)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :lhs(NONE), :rhs(NONE)); } method infix-unquote($/) { my $got = ~($ // "Q::Term"); - die X::TypeCheck.new(:operation, :$got, :expected(Q::Infix)) + die X::Type.new(:operation, :$got, :expected(TYPE)) unless $got eq "Q::Infix"; make $.ast; @@ -755,23 +777,23 @@ class _007::Parser::Actions { elsif $ { $op = "."; } - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("postfix:$op"))), + my $identifier = create(TYPE, + :name(wrap("postfix:$op")), :frame($*runtime.current-frame), ); # XXX: this can't stay hardcoded forever, but we don't have the machinery yet # to do these right enough if $ { - make Q::Postfix::Index.new(index => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, index => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make Q::Postfix::Call.new(argumentlist => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, argumentlist => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make Q::Postfix::Property.new(property => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, property => $.ast, :$identifier, :operand(NONE)); } else { - make $*parser.opscope.ops{$op}.new(:$identifier, :operand(NONE)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :operand(NONE)); } } @@ -784,18 +806,21 @@ class _007::Parser::Actions { $value ~~ s:g['\\»'] = '»'; $value ~~ s:g['\\\\'] = '\\'; }(); - make Q::Identifier.new(:name(Val::Str.new(:$value))); + my $name = wrap($value); + make create(TYPE, :$name); } method argumentlist($/) { - make Q::ArgumentList.new(:arguments(Val::Array.new(:elements($».ast)))); + my $arguments = wrap($».ast); + make create(TYPE, :$arguments); } method parameterlist($/) { - make Q::ParameterList.new(:parameters(Val::Array.new(:elements($».ast)))); + my $parameters = wrap($».ast); + make create(TYPE, :$parameters); } method parameter($/) { - make Q::Parameter.new(:identifier($.ast)); + make create(TYPE, :identifier($.ast)); } } diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index f08ce1d9..7af3ccac 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -1,5 +1,5 @@ -use _007::Val; -use _007::Q; +use _007::Type; +use _007::Object; sub check-feature-flag($feature, $word) { my $flag = "FLAG_007_{$word}"; @@ -19,7 +19,9 @@ grammar _007::Parser::Syntax { token newpad { { $*parser.push-opscope; @*declstack.push(@*declstack ?? @*declstack[*-1].clone !! {}); - $*runtime.enter($*runtime.current-frame, Val::Object.new, Q::StatementList.new); + $*runtime.enter($*runtime.current-frame, wrap({}), create(TYPE, + :statements(wrap([])), + )); } } token finishpad { { @@ -35,15 +37,14 @@ grammar _007::Parser::Syntax { die X::Syntax::Missing.new(:$what); } - our sub declare(Q::Declaration $decltype, $symbol) { + our sub declare(_007::Type $decltype, $symbol) { die X::Redeclaration.new(:$symbol) if $*runtime.declared-locally($symbol); my $frame = $*runtime.current-frame(); die X::Redeclaration::Outer.new(:$symbol) if %*assigned{$frame.id ~ $symbol}; - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value($symbol))), - :$frame); + my $name = wrap($symbol); + my $identifier = create(TYPE, :$name, :$frame); $*runtime.declare-var($identifier); @*declstack[*-1]{$symbol} = $decltype; } @@ -51,15 +52,15 @@ grammar _007::Parser::Syntax { proto token statement {*} rule statement:my { my [ || <.panic("identifier")>] - { declare(Q::Statement::My, $.ast.name.value); } + { declare(TYPE, $.ast.properties.value); } ['=' ]? } rule statement:constant { constant { - my $symbol = $.ast.name.value; + my $symbol = $.ast.properties.value; # XXX: a suspicious lack of redeclaration checks here - declare(Q::Statement::Constant, $symbol); + declare(TYPE, $symbol); } ['=' ]? } @@ -73,9 +74,9 @@ grammar _007::Parser::Syntax { :my $*insub = True; { declare($ eq "sub" - ?? Q::Statement::Sub - !! Q::Statement::Macro, - $.ast.name.value); + ?? TYPE + !! TYPE, + $.ast.properties.value); } <.newpad> '(' ~ ')' @@ -114,7 +115,7 @@ grammar _007::Parser::Syntax { class <.ws> { check-feature-flag("'class' keyword", "CLASS"); } <.ws> - { declare(Q::Statement::Class, $.ast.name.value); } + { declare(TYPE, $.ast.properties.value); } } @@ -202,6 +203,7 @@ grammar _007::Parser::Syntax { || "@" <.ws> $=["Q::PropertyList"] <.ws> '{' <.ws> <.ws> '}' || "@" <.ws> $=["Q::Term"] <.ws> '{' <.ws> <.ws> '}' || "@" <.ws> $=["Q::Term::Array"] <.ws> '{' <.ws> <.ws> '}' + || "@" <.ws> $=["Q::Term::Dict"] <.ws> '{' <.ws> <.ws> '}' || "@" <.ws> $=["Q::Term::Object"] <.ws> '{' <.ws> <.ws> '}' || "@" <.ws> $=["Q::Term::Quasi"] <.ws> '{' <.ws> <.ws> '}' || "@" <.ws> $=["Q::Trait"] <.ws> '{' <.ws> <.ws> '}' @@ -219,10 +221,10 @@ grammar _007::Parser::Syntax { } token term:new-object { new» <.ws> - ) ~~ Val::Type }> <.ws> + ) ~~ _007::Type }> <.ws> '{' ~ '}' } - token term:object { + token term:dict { '{' ~ '}' } token term:identifier { @@ -234,7 +236,7 @@ grammar _007::Parser::Syntax { <.newpad> { if $ { - declare(Q::Term::Sub, $.ast.name.value); + declare(TYPE, $.ast.properties.value); } } '(' ~ ')' @@ -318,7 +320,7 @@ grammar _007::Parser::Syntax { rule parameterlist { [ - { declare(Q::Parameter, $[*-1].ast.name.value); } + { declare(TYPE, $[*-1].ast.properties.value); } ]* %% ',' } diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm deleted file mode 100644 index 353a75f3..00000000 --- a/lib/_007/Q.pm +++ /dev/null @@ -1,1092 +0,0 @@ -use _007::Val; - -class X::Control::Return is Exception { - has $.frame; - has $.value; -} - -class X::Subscript::TooLarge is Exception { - has $.value; - has $.length; - - method message() { "Subscript ($.value) too large (array length $.length)" } -} - -class X::Subscript::NonInteger is Exception { -} - -class X::Subscript::NonString is Exception { -} - -class X::ParameterMismatch is Exception { - has $.type; - has $.paramcount; - has $.argcount; - - method message { - "$.type with $.paramcount parameters called with $.argcount arguments" - } -} - -class X::Property::NotFound is Exception { - has $.propname; - has $.type; - - method message { - "Property '$.propname' not found on object of type $.type" - } -} - -class X::Associativity::Conflict is Exception { - method message { "The operator already has a defined associativity" } -} - -class X::Regex::InvalidMatchType is Exception { - method message { "A regex can only match strings" } -} - -class X::_007::RuntimeException is Exception { - has $.msg; - - method message { - $.msg.Str; - } -} - -sub aname($attr) { $attr.name.substr(2) } -sub avalue($attr, $obj) { $attr.get_value($obj) } - -### ### Q -### -### An program element; anything that forms a node in the syntax tree -### representing a program. -### -role Q { - method Str { - my %*stringification-seen; - Helper::Str(self); - } - - method quoted-Str { - self.Str - } - - method truthy { - True - } - - method attributes { - sub find($aname) { self.^attributes.first({ $aname eq aname($_) }) } - - self.can("attribute-order") - ?? self.attribute-order.map({ find($_) }) - !! self.^attributes; - } -} - -### ### Q::Expr -### -### An expression; something that can be evaluated to a value. -### -role Q::Expr does Q { - method eval($runtime) { ... } -} - -### ### Q::Term -### -### A term; a unit of parsing describing a value or an identifier. Along with -### operators, what makes up expressions. -### -role Q::Term does Q::Expr { -} - -### ### Q::Literal -### -### A literal; a constant value written out explicitly in the program, such as -### `None`, `True`, `5`, or `"James Bond"`. -### -### Compound values such as arrays and objects are considered terms but not -### literals. -### -role Q::Literal does Q::Term { -} - -### ### Q::Literal::None -### -### The `None` literal. -### -class Q::Literal::None does Q::Literal { - method eval($) { NONE } -} - -### ### Q::Literal::Bool -### -### A boolean literal; either `True` or `False`. -### -class Q::Literal::Bool does Q::Literal { - has Val::Bool $.value; - - method eval($) { $.value } -} - -### ### Q::Literal::Int -### -### An integer literal; a non-negative number. -### -### Negative numbers are not themselves considered integer literals: something -### like `-5` is parsed as a `prefix:<->` containing a literal `5`. -### -class Q::Literal::Int does Q::Literal { - has Val::Int $.value; - - method eval($) { $.value } -} - -### ### Q::Literal::Str -### -### A string literal. -### -class Q::Literal::Str does Q::Literal { - has Val::Str $.value; - - method eval($) { $.value } -} - -### ### Q::Identifier -### -### An identifier; a name which identifies a storage location in the program. -### -### Identifiers are subject to *scoping*: the same name can point to different -### storage locations because they belong to different scopes. -### -class Q::Identifier does Q::Term { - has Val::Str $.name; - has $.frame = NONE; - - method attribute-order { } - - method eval($runtime) { - return $runtime.get-var($.name.value, $.frame); - } - - method put-value($value, $runtime) { - $runtime.put-var(self, $value); - } -} - -### ### Q::Term::Regex -### -### A regular expression (*regex*). -### -class Q::Term::Regex does Q::Term { - has Val::Str $.contents; - - method eval($runtime) { - Val::Regex.new(:$.contents); - } -} - -### ### Q::Term::Array -### -### An array. Array terms consist of zero or more *elements*, each of which -### can be an arbitrary expression. -### -class Q::Term::Array does Q::Term { - has Val::Array $.elements; - - method eval($runtime) { - Val::Array.new(:elements($.elements.elements.map(*.eval($runtime)))); - } -} - -### ### Q::Term::Object -### -### An object. Object terms consist of an optional *type*, and a property list -### with zero or more key/value pairs. -### -class Q::Term::Object does Q::Term { - has Q::Identifier $.type; - has $.propertylist; - - method eval($runtime) { - return $runtime.get-var($.type.name.value, $.type.frame).create( - $.propertylist.properties.elements.map({.key.value => .value.eval($runtime)}) - ); - } -} - -### ### Q::Property -### -### An object property. Properties have a key and a value. -### -class Q::Property does Q { - has Val::Str $.key; - has $.value; -} - -### ### Q::PropertyList -### -### A property list in an object. Property lists have zero or more key/value -### pairs. Keys in objects are considered unordered, but a property list has -### a specified order: the order the properties occur in the program text. -### -class Q::PropertyList does Q { - has Val::Array $.properties .= new; -} - -### ### Q::Declaration -### -### A declaration; something that introduces a name. -### -role Q::Declaration { - method is-assignable { False } -} - -### ### Q::Trait -### -### A trait; a piece of metadata for a routine. A trait consists of an -### identifier and an expression. -### -class Q::Trait does Q { - has $.identifier; - has $.expr; - - method attribute-order { } -} - -### ### Q::TraitList -### -### A list of zero or more traits. Each routine has a traitlist. -### -class Q::TraitList does Q { - has Val::Array $.traits .= new; - - method attribute-order { } -} - -### ### Q::Term::Sub -### -### A subroutine. -### -class Q::Term::Sub does Q::Term does Q::Declaration { - has $.identifier; - has $.traitlist = Q::TraitList.new; - has $.block; - - method attribute-order { } - - method eval($runtime) { - my $name = $.identifier ~~ Val::NoneType - ?? Val::Str.new(:value("")) - !! $.identifier.name; - return Val::Sub.new( - :$name, - :parameterlist($.block.parameterlist), - :statementlist($.block.statementlist), - :static-lexpad($.block.static-lexpad), - :outer-frame($runtime.current-frame), - ); - } -} - -### ### Q::Block -### -### A block. Blocks are used in a number of places: by routines, by -### block statements, by other compound statements (such as `if` statements) -### and by `quasi` terms and sub terms. Blocks are not, however, terms -### in their own regard. -### -### A block has a parameter list and a statement list, each of which can -### be empty. -### -class Q::Block does Q { - has $.parameterlist; - has $.statementlist; - has Val::Object $.static-lexpad is rw = Val::Object.new; - - method attribute-order { } -} - -### ### Q::Prefix -### -### A prefix operator; an operator that occurs before a term, like the -### `-` in `-5`. -### -class Q::Prefix does Q::Expr { - has $.identifier; - has $.operand; - - method attribute-order { } - - method eval($runtime) { - my $e = $.operand.eval($runtime); - my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$e]); - } -} - -### ### Q::Prefix::Str -### -### A stringification operator. -### -class Q::Prefix::Str is Q::Prefix {} - -### ### Q::Prefix::Plus -### -### A numification operator. -### -class Q::Prefix::Plus is Q::Prefix {} - -### ### Q::Prefix::Minus -### -### A numeric negation operator. -### -class Q::Prefix::Minus is Q::Prefix {} - -### ### Q::Prefix::So -### -### A boolification operator. -### -class Q::Prefix::So is Q::Prefix {} - -### ### Q::Prefix::Not -### -### A boolean negation operator. -### -class Q::Prefix::Not is Q::Prefix {} - -### ### Q::Prefix::Upto -### -### An "upto" operator; applied to a number `n` it produces an array -### of values `[0, 1, ..., n-1]`. -### -class Q::Prefix::Upto is Q::Prefix {} - -### ### Q::Infix -### -### An infix operator; something like the `+` in `2 + 2` that occurs between -### two terms. -### -class Q::Infix does Q::Expr { - has $.identifier; - has $.lhs; - has $.rhs; - - method attribute-order { } - - method eval($runtime) { - my $l = $.lhs.eval($runtime); - my $r = $.rhs.eval($runtime); - my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$l, $r]); - } -} - -### ### Q::Infix::Addition -### -### A numeric addition operator. -### -class Q::Infix::Addition is Q::Infix {} - -### ### Q::Infix::Addition -### -### A numeric subtraction operator. -### -class Q::Infix::Subtraction is Q::Infix {} - -### ### Q::Infix::Multiplication -### -### A numeric multiplication operator. -### -class Q::Infix::Multiplication is Q::Infix {} - -### ### Q::Infix::Modulo -### -### A numeric modulo operator; produces the *remainder* left from an integer -### division between two numbers. For example, `456 % 100` is `56` because the -### remainder from dividing `456` by `100` is `56`. -### -class Q::Infix::Modulo is Q::Infix {} - -### ### Q::Infix::Divisibility -### -### A divisibility test operator. Returns `True` exactly when the remainder -### operator would return `0`. -### -class Q::Infix::Divisibility is Q::Infix {} - -### ### Q::Infix::Concat -### -### A string concatenation operator. Returns a single string that is the -### result of sequentially putting two strings together. -### -class Q::Infix::Concat is Q::Infix {} - -### ### Q::Infix::Replicate -### -### A string replication operator. Returns a string which consists of `n` -### copies of a string. -### -class Q::Infix::Replicate is Q::Infix {} - -### ### Q::Infix::ArrayReplicate -### -### An array replication operator. Returns an array which consists of -### the original array's elements, repeated `n` times. -### -class Q::Infix::ArrayReplicate is Q::Infix {} - -### ### Q::Infix::Cons -### -### A "cons" operator. Given a value and an array, returns a new -### array with the value added as the first element. -### -class Q::Infix::Cons is Q::Infix {} - -### ### Q::Infix::Assignment -### -### An assignment operator. Puts a value in a storage location. -### -class Q::Infix::Assignment is Q::Infix { - method eval($runtime) { - my $value = $.rhs.eval($runtime); - $.lhs.put-value($value, $runtime); - return $value; - } -} - -### ### Q::Infix::Eq -### -### An equality test operator. -### -class Q::Infix::Eq is Q::Infix {} - -### ### Q::Infix::Ne -### -### An inequality test operator. -### -class Q::Infix::Ne is Q::Infix {} - -### ### Q::Infix::Gt -### -### A greater-than test operator. -### -class Q::Infix::Gt is Q::Infix {} - -### ### Q::Infix::Lt -### -### A less-than test operator. -### -class Q::Infix::Lt is Q::Infix {} - -### ### Q::Infix::Ge -### -### A greater-than-or-equal test operator. -### -class Q::Infix::Ge is Q::Infix {} - -### ### Q::Infix::Le -### -### A less-than-or-equal test operator. -### -class Q::Infix::Le is Q::Infix {} - -### ### Q::Infix::Or -### -### A short-circuiting disjunction operator; evaluates its right-hand -### side only if the left-hand side is falsy. -### -class Q::Infix::Or is Q::Infix { - method eval($runtime) { - my $l = $.lhs.eval($runtime); - return $l.truthy - ?? $l - !! $.rhs.eval($runtime); - } -} - -### ### Q::Infix::DefinedOr -### -### A short-circuiting "defined-or" operator. Evaluates its -### right-hand side only if the left-hand side is `None`. -### -class Q::Infix::DefinedOr is Q::Infix { - method eval($runtime) { - my $l = $.lhs.eval($runtime); - return $l !~~ Val::NoneType - ?? $l - !! $.rhs.eval($runtime); - } -} - -### ### Q::Infix::And -### -### A short-circuiting "and" operator. Evaluates its -### right-hand side only if the left-hand side is truthy. -### -class Q::Infix::And is Q::Infix { - method eval($runtime) { - my $l = $.lhs.eval($runtime); - return !$l.truthy - ?? $l - !! $.rhs.eval($runtime); - } -} - -### ### Q::Infix::TypeMatch -### -### A type match operator. Checks if a value on the left-hand side has -### the type on the right-hand side, including subtypes. -### -class Q::Infix::TypeMatch is Q::Infix {} - -### ### Q::Infix::TypeNonMatch -### -### A negative type match operator. Returns `True` exactly in the cases -### a type match would return `False`. -### -class Q::Infix::TypeNonMatch is Q::Infix {} - -### ### Q::Postfix -### -### A postfix operator; something like the `[0]` in `agents[0]` that occurs -### after a term. -### -class Q::Postfix does Q::Expr { - has $.identifier; - has $.operand; - - method attribute-order { } - - method eval($runtime) { - my $e = $.operand.eval($runtime); - my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$e]); - } -} - -### ### Q::Postfix::Index -### -### An indexing operator; returns an array element or object property. -### Arrays expect integer indices and objects expect string property names. -### -class Q::Postfix::Index is Q::Postfix { - has $.index; - - method attribute-order { } - - method eval($runtime) { - given $.operand.eval($runtime) { - when Val::Array { - my $index = $.index.eval($runtime); - die X::Subscript::NonInteger.new - if $index !~~ Val::Int; - die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) - if $index.value >= .elements; - die X::Subscript::Negative.new(:$index, :type([])) - if $index.value < 0; - return .elements[$index.value]; - } - when Val::Object | Val::Sub | Q { - my $property = $.index.eval($runtime); - die X::Subscript::NonString.new - if $property !~~ Val::Str; - my $propname = $property.value; - return $runtime.property($_, $propname); - } - die X::TypeCheck.new(:operation, :got($_), :expected(Val::Array)); - } - } - - method put-value($value, $runtime) { - given $.operand.eval($runtime) { - when Val::Array { - my $index = $.index.eval($runtime); - die X::Subscript::NonInteger.new - if $index !~~ Val::Int; - die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) - if $index.value >= .elements; - die X::Subscript::Negative.new(:$index, :type([])) - if $index.value < 0; - .elements[$index.value] = $value; - } - when Val::Object | Q { - my $property = $.index.eval($runtime); - die X::Subscript::NonString.new - if $property !~~ Val::Str; - my $propname = $property.value; - $runtime.put-property($_, $propname, $value); - } - die X::TypeCheck.new(:operation, :got($_), :expected(Val::Array)); - } - } -} - -### ### Q::Postfix::Call -### -### An invocation operator; calls a routine. -### -class Q::Postfix::Call is Q::Postfix { - has $.argumentlist; - - method attribute-order { } - - method eval($runtime) { - my $c = $.operand.eval($runtime); - die "macro is called at runtime" - if $c ~~ Val::Macro; - die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: - unless $c ~~ Val::Sub; - my @arguments = $.argumentlist.arguments.elements.map(*.eval($runtime)); - return $runtime.call($c, @arguments); - } -} - -### ### Q::Postfix::Property -### -### An object property operator; fetches a property out of an object. -### -class Q::Postfix::Property is Q::Postfix { - has $.property; - - method attribute-order { } - - method eval($runtime) { - my $obj = $.operand.eval($runtime); - my $propname = $.property.name.value; - $runtime.property($obj, $propname); - } - - method put-value($value, $runtime) { - given $.operand.eval($runtime) { - when Val::Object | Q { - my $propname = $.property.name.value; - $runtime.put-property($_, $propname, $value); - } - die "We don't handle this case yet"; # XXX: think more about this case - } - } -} - -### ### Q::Unquote -### -### An unquote; allows Qtree fragments to be inserted into places in a quasi. -### -class Q::Unquote does Q { - has $.qtype; - has $.expr; - - method eval($runtime) { - die "Should never hit an unquote at runtime"; # XXX: turn into X:: - } -} - -### ### Q::Unquote::Prefix -### -### An unquote which is a prefix operator. -### -class Q::Unquote::Prefix is Q::Unquote { - has $.operand; -} - -### ### Q::Unquote::Infix -### -### An unquote which is an infix operator. -### -class Q::Unquote::Infix is Q::Unquote { - has $.lhs; - has $.rhs; -} - -### ### Q::Term::Quasi -### -### A quasi; a piece of 007 code which evaluates to that code's Qtree -### representation. A way to "quote" code in a program instead of running -### it directly in place. Used together with macros. -### -### The term "quasi" comes from the fact that inside the quoted code there -### can be parametric holes ("unquotes") where Qtree fragments can be -### inserted. Quasiquotation is the practice of combining literal code -### fragments with such parametric holes. -### -class Q::Term::Quasi does Q::Term { - has $.qtype; - has $.contents; - - method attribute-order { } - - method eval($runtime) { - sub interpolate($thing) { - return $thing.new(:elements($thing.elements.map(&interpolate))) - if $thing ~~ Val::Array; - - return $thing.new(:properties(%($thing.properties.map({ .key => interpolate(.value) })))) - if $thing ~~ Val::Object; - - return $thing - if $thing ~~ Val; - - return $thing.new(:name($thing.name), :frame($runtime.current-frame)) - if $thing ~~ Q::Identifier; - - if $thing ~~ Q::Unquote::Prefix { - my $prefix = $thing.expr.eval($runtime); - die X::TypeCheck.new(:operation("interpolating an unquote"), :got($prefix), :expected(Q::Prefix)) - unless $prefix ~~ Q::Prefix; - return $prefix.new(:identifier($prefix.identifier), :operand($thing.operand)); - } - elsif $thing ~~ Q::Unquote::Infix { - my $infix = $thing.expr.eval($runtime); - die X::TypeCheck.new(:operation("interpolating an unquote"), :got($infix), :expected(Q::Infix)) - unless $infix ~~ Q::Infix; - return $infix.new(:identifier($infix.identifier), :lhs($thing.lhs), :rhs($thing.rhs)); - } - - if $thing ~~ Q::Unquote { - my $ast = $thing.expr.eval($runtime); - die "Expression inside unquote did not evaluate to a Q" # XXX: turn into X:: - unless $ast ~~ Q; - return $ast; - } - - my %attributes = $thing.attributes.map: -> $attr { - aname($attr) => interpolate(avalue($attr, $thing)) - }; - - $thing.new(|%attributes); - } - - if $.qtype.value eq "Q::Unquote" && $.contents ~~ Q::Unquote { - return $.contents; - } - return interpolate($.contents); - } -} - -### ### Q::Parameter -### -### A parameter. Any identifier that's declared as the input to a block -### is a parameter, including subs, macros, and `if` statements. -### -class Q::Parameter does Q does Q::Declaration { - has $.identifier; - - method is-assignable { True } -} - -### ### Q::ParameterList -### -### A list of zero or more parameters. -### -class Q::ParameterList does Q { - has Val::Array $.parameters .= new; -} - -### ### Q::ArgumentList -### -### A list of zero or more arguments. -### -class Q::ArgumentList does Q { - has Val::Array $.arguments .= new; -} - -### ### Q::Statement -### -### A statement. -### -role Q::Statement does Q { -} - -### ### Q::Statement::My -### -### A `my` variable declaration statement. -### -class Q::Statement::My does Q::Statement does Q::Declaration { - has $.identifier; - has $.expr = NONE; - - method attribute-order { } - - method is-assignable { True } - - method run($runtime) { - return - unless $.expr !~~ Val::NoneType; - my $value = $.expr.eval($runtime); - $.identifier.put-value($value, $runtime); - } -} - -### ### Q::Statement::Constant -### -### A `constant` declaration statement. -### -class Q::Statement::Constant does Q::Statement does Q::Declaration { - has $.identifier; - has $.expr; - - method attribute-order { } - - method run($runtime) { - # value has already been assigned - } -} - -### ### Q::Statement::Expr -### -### A statement consisting of an expression. -### -class Q::Statement::Expr does Q::Statement { - has $.expr; - - method run($runtime) { - $.expr.eval($runtime); - } -} - -### ### Q::Statement::If -### -### An `if` statement. -### -class Q::Statement::If does Q::Statement { - has $.expr; - has $.block; - has $.else = NONE; - - method attribute-order { } - - method run($runtime) { - my $expr = $.expr.eval($runtime); - if $expr.truthy { - my $paramcount = $.block.parameterlist.elems; - die X::ParameterMismatch.new( - :type("If statement"), :$paramcount, :argcount("0 or 1")) - if $paramcount > 1; - $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); - for @($.block.parameterlist.parameters.elements) Z $expr -> ($param, $arg) { - $runtime.declare-var($param.identifier, $arg); - } - $.block.statementlist.run($runtime); - $runtime.leave; - } - else { - given $.else { - when Q::Statement::If { - $.else.run($runtime) - } - when Q::Block { - $runtime.enter($runtime.current-frame, $.else.static-lexpad, $.else.statementlist); - $.else.statementlist.run($runtime); - $runtime.leave; - } - } - } - } -} - -### ### Q::Statement::Block -### -### A block statement. -### -class Q::Statement::Block does Q::Statement { - has $.block; - - method run($runtime) { - $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); - $.block.statementlist.run($runtime); - $runtime.leave; - } -} - -### ### Q::CompUnit -### -### A block-level statement representing a whole compilation unit. -### We can read "compilation unit" here as meaning "file". -### -class Q::CompUnit is Q::Statement::Block { -} - -### ### Q::Statement::For -### -### A `for` loop statement. -### -class Q::Statement::For does Q::Statement { - has $.expr; - has $.block; - - method attribute-order { } - - method run($runtime) { - my $count = $.block.parameterlist.parameters.elements.elems; - die X::ParameterMismatch.new( - :type("For loop"), :paramcount($count), :argcount("0 or 1")) - if $count > 1; - - my $array = $.expr.eval($runtime); - die X::TypeCheck.new(:operation("for loop"), :got($array), :expected(Val::Array)) - unless $array ~~ Val::Array; - - for $array.elements -> $arg { - $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); - if $count == 1 { - $runtime.declare-var($.block.parameterlist.parameters.elements[0].identifier, $arg.list[0]); - } - $.block.statementlist.run($runtime); - $runtime.leave; - } - } -} - -### ### Q::Statement::While -### -### A `while` loop statement. -### -class Q::Statement::While does Q::Statement { - has $.expr; - has $.block; - - method attribute-order { } - - method run($runtime) { - while (my $expr = $.expr.eval($runtime)).truthy { - my $paramcount = $.block.parameterlist.parameters.elements.elems; - die X::ParameterMismatch.new( - :type("While loop"), :$paramcount, :argcount("0 or 1")) - if $paramcount > 1; - $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); - for @($.block.parameterlist.parameters.elements) Z $expr -> ($param, $arg) { - $runtime.declare-var($param.identifier, $arg); - } - $.block.statementlist.run($runtime); - $runtime.leave; - } - } -} - -### ### Q::Statement::Return -### -### A `return` statement. -### -class Q::Statement::Return does Q::Statement { - has $.expr = NONE; - - method run($runtime) { - my $value = $.expr ~~ Val::NoneType ?? $.expr !! $.expr.eval($runtime); - my $frame = $runtime.get-var("--RETURN-TO--"); - die X::Control::Return.new(:$value, :$frame); - } -} - -### ### Q::Statement::Throw -### -### A `throw` statement. -### -class Q::Statement::Throw does Q::Statement { - has $.expr = NONE; - - method run($runtime) { - my $value = $.expr ~~ Val::NoneType - ?? Val::Exception.new(:message(Val::Str.new(:value("Died")))) - !! $.expr.eval($runtime); - die X::TypeCheck.new(:got($value), :excpected(Val::Exception)) - if $value !~~ Val::Exception; - - die X::_007::RuntimeException.new(:msg($value.message.value)); - } -} - -### ### Q::Statement::Sub -### -### A subroutine declaration statement. -### -class Q::Statement::Sub does Q::Statement does Q::Declaration { - has $.identifier; - has $.traitlist = Q::TraitList.new; - has Q::Block $.block; - - method attribute-order { } - - method run($runtime) { - } -} - -### ### Q::Statement::Macro -### -### A macro declaration statement. -### -class Q::Statement::Macro does Q::Statement does Q::Declaration { - has $.identifier; - has $.traitlist = Q::TraitList.new; - has $.block; - - method attribute-order { } - - method run($runtime) { - } -} - -### ### Q::Statement::BEGIN -### -### A `BEGIN` block statement. -### -class Q::Statement::BEGIN does Q::Statement { - has $.block; - - method run($runtime) { - # a BEGIN block does not run at runtime - } -} - -### ### Q::Statement::Class -### -### A class declaration statement. -### -class Q::Statement::Class does Q::Statement does Q::Declaration { - has $.block; - - method run($runtime) { - # a class block does not run at runtime - } -} - -### ### Q::StatementList -### -### A list of zero or more statements. Statement lists commonly occur -### directly inside blocks (or at the top level of the program, on the -### compunit level). However, it's also possible for a `quasi` to -### denote a statement list without any surrounding block. -### -class Q::StatementList does Q { - has Val::Array $.statements .= new; - - method run($runtime) { - for $.statements.elements -> $statement { - my $value = $statement.run($runtime); - LAST if $statement ~~ Q::Statement::Expr { - return $value; - } - } - } -} - -### ### Q::Expr::StatementListAdapter -### -### An expression which holds a statement list. Surprisingly, this never -### happens in the source code text itself; because of 007's grammar, an -### expression can never consist of a list of statements. -### -### However, it can happen as a macro call (an expression) expands into -### a statement list; that's when this Qtype is used. -### -### Semantically, the contained statement list is executed normally, and -### if execution evaluates the last statement and the statement turns out -### to have a value (because it's an expression statement), then this -### value is the value of the whole containing expression. -### -class Q::Expr::StatementListAdapter does Q::Expr { - has $.statementlist; - - method eval($runtime) { - return $.statementlist.run($runtime); - } -} diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index a07c5a5f..b73a75bf 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -1,12 +1,10 @@ -use _007::Val; -use _007::Q; +use _007::Type; +use _007::Object; use _007::Builtins; use _007::OpScope; -constant NO_OUTER = Val::Object.new; -constant RETURN_TO = Q::Identifier.new( - :name(Val::Str.new(:value("--RETURN-TO--"))), - :frame(NONE)); +constant NO_OUTER = wrap({}); +constant RETURN_TO = create(TYPE, :name(wrap("--RETURN-TO--"))); class _007::Runtime { has $.input; @@ -16,14 +14,16 @@ class _007::Runtime { has $.builtin-frame; submethod BUILD(:$!input, :$!output) { - self.enter(NO_OUTER, Val::Object.new, Q::StatementList.new); + self.enter(NO_OUTER, wrap({}), create(TYPE, + :statements(wrap([])), + )); $!builtin-frame = @!frames[*-1]; $!builtin-opscope = _007::OpScope.new; self.load-builtins; } - method run(Q::CompUnit $compunit) { - $compunit.run(self); + method run(_007::Object $compunit) { + bound-method($compunit, "run", self)(); CATCH { when X::Control::Return { die X::ControlFlow::Return.new; @@ -32,34 +32,35 @@ class _007::Runtime { } method enter($outer-frame, $static-lexpad, $statementlist, $routine?) { - my $frame = Val::Object.new(:properties(:$outer-frame, :pad(Val::Object.new))); + my $frame = wrap({ + :$outer-frame, + :pad(wrap({})) + }); @!frames.push($frame); - for $static-lexpad.properties.kv -> $name, $value { - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value($name))), - :frame(NONE)); + for $static-lexpad.value.kv -> $name, $value { + my $identifier = create(TYPE, :name(wrap($name))); self.declare-var($identifier, $value); } - for $statementlist.statements.elements.kv -> $i, $_ { - when Q::Statement::Sub { - my $name = .identifier.name; - my $parameterlist = .block.parameterlist; - my $statementlist = .block.statementlist; - my $static-lexpad = .block.static-lexpad; + for $statementlist.properties.value.kv -> $i, $_ { + if .is-a("Q::Statement::Sub") { + my $name = .properties.properties; + my $parameterlist = .properties.properties; + my $statementlist = .properties.properties; + my $static-lexpad = .properties.properties; my $outer-frame = $frame; - my $val = Val::Sub.new( + my $val = create(TYPE, :$name, :$parameterlist, :$statementlist, :$static-lexpad, :$outer-frame ); - self.declare-var(.identifier, $val); + self.declare-var(.properties, $val); } } if $routine { - my $name = $routine.name; - my $identifier = Q::Identifier.new(:$name, :$frame); + my $name = $routine.properties; + my $identifier = create(TYPE, :$name, :$frame); self.declare-var($identifier, $routine); } } @@ -84,44 +85,42 @@ class _007::Runtime { } method !maybe-find-pad(Str $symbol, $frame is copy) { - if $frame ~~ Val::NoneType { # XXX: make a `defined` method on NoneType so we can use `//` + if $frame === NONE { $frame = self.current-frame; } repeat until $frame === NO_OUTER { - return $frame.properties - if $frame.properties.properties{$symbol} :exists; - $frame = $frame.properties; + return $frame.value + if $frame.value.value{$symbol} :exists; + $frame = $frame.value; } - die X::ControlFlow::Return.new - if $symbol eq RETURN_TO; } - method put-var(Q::Identifier $identifier, $value) { - my $name = $identifier.name.value; - my $frame = $identifier.frame ~~ Val::NoneType + method put-var(_007::Object $identifier, $value) { + my $name = $identifier.properties.value; + my $frame = $identifier.properties === NONE ?? self.current-frame - !! $identifier.frame; + !! $identifier.properties; my $pad = self!find-pad($name, $frame); - $pad.properties{$name} = $value; + $pad.value{$name} = $value; } method get-var(Str $name, $frame = self.current-frame) { my $pad = self!find-pad($name, $frame); - return $pad.properties{$name}; + return $pad.value{$name}; } method maybe-get-var(Str $name, $frame = self.current-frame) { if self!maybe-find-pad($name, $frame) -> $pad { - return $pad.properties{$name}; + return $pad.value{$name}; } } - method declare-var(Q::Identifier $identifier, $value?) { - my $name = $identifier.name.value; - my Val::Object $frame = $identifier.frame ~~ Val::NoneType + method declare-var(_007::Object $identifier, $value?) { + my $name = $identifier.properties.value; + my _007::Object::Wrapped $frame = $identifier.properties === NONE ?? self.current-frame - !! $identifier.frame; - $frame.properties.properties{$name} = $value // NONE; + !! $identifier.properties; + $frame.value.value{$name} = $value // NONE; } method declared($name) { @@ -131,7 +130,7 @@ class _007::Runtime { method declared-locally($name) { my $frame = self.current-frame; return True - if $frame.properties.properties{$name} :exists; + if $frame.value.value{$name} :exists; } method register-subhandler { @@ -140,348 +139,18 @@ class _007::Runtime { method load-builtins { my $opscope = $!builtin-opscope; - for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { - my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value($name))), - :frame(NONE)); + for builtins(:$.input, :$.output, :$opscope, :runtime(self)) -> Pair (:key($name), :$value) { + my $identifier = create(TYPE, :name(wrap($name))); self.declare-var($identifier, $value); } } - method call(Val::Sub $c, @arguments) { - my $paramcount = $c.parameterlist.parameters.elements.elems; - my $argcount = @arguments.elems; - die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) - unless $paramcount == $argcount; - if $c.hook -> &hook { - return &hook(|@arguments) || NONE; - } - self.enter($c.outer-frame, $c.static-lexpad, $c.statementlist, $c); - for @($c.parameterlist.parameters.elements) Z @arguments -> ($param, $arg) { - self.declare-var($param.identifier, $arg); - } - self.register-subhandler; - my $frame = self.current-frame; - my $value = $c.statementlist.run(self); - self.leave; - CATCH { - when X::Control::Return { - self.unroll-to($frame); - self.leave; - return .value; - } - } - $value || NONE - } - - method property($obj, Str $propname) { - sub builtin(&fn) { - my $name = &fn.name; - my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(Val::Str.new(:$^value))))) }; - my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); - my $statementlist = Q::StatementList.new(); - return Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); - } - - my $type = Val::Type.of($obj.WHAT).name; - if $obj ~~ Q { - if $propname eq "detach" { - sub aname($attr) { $attr.name.substr(2) } - sub avalue($attr, $obj) { $attr.get_value($obj) } - - sub interpolate($thing) { - return $thing.new(:elements($thing.elements.map(&interpolate))) - if $thing ~~ Val::Array; - - return $thing.new(:properties(%($thing.properties.map(.key => interpolate(.value))))) - if $thing ~~ Val::Object; - - return $thing - if $thing ~~ Val; - - return $thing.new(:name($thing.name), :frame(NONE)) - if $thing ~~ Q::Identifier; - - return $thing - if $thing ~~ Q::Unquote; - - my %attributes = $thing.attributes.map: -> $attr { - aname($attr) => interpolate(avalue($attr, $thing)) - }; - - $thing.new(|%attributes); - } - - return builtin(sub detach() { - return interpolate($obj); - }); - } - - sub aname($attr) { $attr.name.substr(2) } - my %known-properties = $obj.WHAT.attributes.map({ aname($_) => 1 }); - # XXX: hack - if $obj ~~ Q::Block { - %known-properties = 1; - } - - die X::Property::NotFound.new(:$propname, :$type) - unless %known-properties{$propname}; - - return $obj."$propname"(); - } - elsif $obj ~~ Val::Int && $propname eq "abs" { - return builtin(sub abs() { - return Val::Int.new(:value($obj.value.abs)); - }); - } - elsif $obj ~~ Val::Int && $propname eq "chr" { - return builtin(sub chr() { - return Val::Str.new(:value($obj.value.chr)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "ord" { - return builtin(sub ord() { - return Val::Int.new(:value($obj.value.ord)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "chars" { - return builtin(sub chars() { - return Val::Int.new(:value($obj.value.chars)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "uc" { - return builtin(sub uc() { - return Val::Str.new(:value($obj.value.uc)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "lc" { - return builtin(sub lc() { - return Val::Str.new(:value($obj.value.lc)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "trim" { - return builtin(sub trim() { - return Val::Str.new(:value($obj.value.trim)); - }); - } - elsif $obj ~~ Val::Array && $propname eq "size" { - return builtin(sub size() { - return Val::Int.new(:value($obj.elements.elems)); - }); - } - elsif $obj ~~ Val::Array && $propname eq "reverse" { - return builtin(sub reverse() { - return Val::Array.new(:elements($obj.elements.reverse)); - }); - } - elsif $obj ~~ Val::Array && $propname eq "sort" { - return builtin(sub sort() { - return Val::Array.new(:elements($obj.elements.sort)); - }); - } - elsif $obj ~~ Val::Array && $propname eq "shuffle" { - return builtin(sub shuffle() { - return Val::Array.new(:elements($obj.elements.pick(*))); - }); - } - elsif $obj ~~ Val::Array && $propname eq "concat" { - return builtin(sub concat($array) { - die X::TypeCheck.new(:operation, :got($array), :expected(Val::Array)) - unless $array ~~ Val::Array; - return Val::Array.new(:elements([|$obj.elements , |$array.elements])); - }); - } - elsif $obj ~~ Val::Array && $propname eq "join" { - return builtin(sub join($sep) { - return Val::Str.new(:value($obj.elements.join($sep.value.Str))); - }); - } - elsif $obj ~~ Val::Object && $propname eq "size" { - return builtin(sub size() { - return Val::Int.new(:value($obj.properties.elems)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "split" { - return builtin(sub split($sep) { - my @elements = (Val::Str.new(:value($_)) for $obj.value.split($sep.value)); - return Val::Array.new(:@elements); - }); - } - elsif $obj ~~ Val::Str && $propname eq "index" { - return builtin(sub index($substr) { - return Val::Int.new(:value($obj.value.index($substr.value) // -1)); - }); - } - elsif $obj ~~ Val::Str && $propname eq "substr" { - return builtin(sub substr($pos, $chars) { - return Val::Str.new(:value($obj.value.substr( - $pos.value, - $chars.value))); - }); - } - elsif $obj ~~ Val::Str && $propname eq "contains" { - return builtin(sub contains($substr) { - die X::TypeCheck.new(:operation, :got($substr), :expected(Val::Str)) - unless $substr ~~ Val::Str; - - return Val::Int.new(:value( - $obj.value.contains($substr.value); - )); - }); - } - elsif $obj ~~ Val::Str && $propname eq "prefix" { - return builtin(sub prefix($pos) { - return Val::Str.new(:value($obj.value.substr( - 0, - $pos.value))); - }); - } - elsif $obj ~~ Val::Str && $propname eq "suffix" { - return builtin(sub suffix($pos) { - return Val::Str.new(:value($obj.value.substr( - $pos.value))); - }); - } - elsif $obj ~~ Val::Str && $propname eq "charat" { - return builtin(sub charat($pos) { - my $s = $obj.value; - - die X::Subscript::TooLarge.new(:value($pos.value), :length($s.chars)) - if $pos.value >= $s.chars; - - return Val::Str.new(:value($s.substr($pos.value, 1))); - }); - } - elsif $obj ~~ Val::Regex && $propname eq "fullmatch" { - return builtin(sub fullmatch($str) { - my $regex-string = $obj.contents.value; - - die X::Regex::InvalidMatchType.new - unless $str ~~ Val::Str; - - return Val::Bool.new(:value($regex-string eq $str.value)); - }); - } - elsif $obj ~~ Val::Regex && $propname eq "search" { - return builtin(sub search($str) { - my $regex-string = $obj.contents.value; - - die X::Regex::InvalidMatchType.new - unless $str ~~ Val::Str; - - return Val::Bool.new(:value($str.value.contains($regex-string))); - }); - } - elsif $obj ~~ Val::Array && $propname eq "filter" { - return builtin(sub filter($fn) { - my @elements = $obj.elements.grep({ self.call($fn, [$_]).truthy }); - return Val::Array.new(:@elements); - }); - } - elsif $obj ~~ Val::Array && $propname eq "map" { - return builtin(sub map($fn) { - my @elements = $obj.elements.map({ self.call($fn, [$_]) }); - return Val::Array.new(:@elements); - }); - } - elsif $obj ~~ Val::Array && $propname eq "push" { - return builtin(sub push($newelem) { - $obj.elements.push($newelem); - return NONE; - }); - } - elsif $obj ~~ Val::Array && $propname eq "pop" { - return builtin(sub pop() { - die X::Cannot::Empty.new(:action, :what($obj.^name)) - if $obj.elements.elems == 0; - return $obj.elements.pop(); - }); - } - elsif $obj ~~ Val::Array && $propname eq "shift" { - return builtin(sub shift() { - die X::Cannot::Empty.new(:action, :what($obj.^name)) - if $obj.elements.elems == 0; - return $obj.elements.shift(); - }); - } - elsif $obj ~~ Val::Array && $propname eq "unshift" { - return builtin(sub unshift($newelem) { - $obj.elements.unshift($newelem); - return NONE; - }); - } - elsif $obj ~~ Val::Type && $propname eq "name" { - return Val::Str.new(:value($obj.name)); - } - elsif $obj ~~ Val::Type && $propname eq "create" { - return builtin(sub create($properties) { - $obj.create($properties.elements.map({ .elements[0].value => .elements[1] })); - }); - } - elsif $obj ~~ Val::Sub && $propname eq any { - return $obj."$propname"(); - } - elsif $obj ~~ (Q | Val::Object) && ($obj.properties{$propname} :exists) { - return $obj.properties{$propname}; - } - elsif $propname eq "get" { - return builtin(sub get($prop) { - return self.property($obj, $prop.value); - }); - } - elsif $propname eq "keys" { - return builtin(sub keys() { - return Val::Array.new(:elements($obj.properties.keys.map({ - Val::Str.new(:$^value) - }))); - }); - } - elsif $propname eq "has" { - return builtin(sub has($prop) { - # XXX: problem: we're not lying hard enough here. we're missing - # both Q objects, which are still hard-coded into the - # substrate, and the special-cased properties - # - my $value = $obj.properties{$prop.value} :exists; - return Val::Bool.new(:$value); - }); - } - elsif $propname eq "update" { - return builtin(sub update($newprops) { - for $obj.properties.keys { - $obj.properties{$_} = $newprops.properties{$_} // $obj.properties{$_}; - } - return $obj; - }); - } - elsif $propname eq "extend" { - return builtin(sub extend($newprops) { - for $newprops.properties.keys { - $obj.properties{$_} = $newprops.properties{$_}; - } - return $obj; - }); - } - elsif $propname eq "id" { - # XXX: Make this work for Q-type objects, too. - return Val::Int.new(:value($obj.id)); - } - else { - die X::Property::NotFound.new(:$propname, :$type); - } - } - method put-property($obj, Str $propname, $newvalue) { - if $obj ~~ Q { - die "We don't handle assigning to Q object properties yet"; - } - elsif $obj !~~ Val::Object { - die "We don't handle assigning to non-Val::Object types yet"; + if !$obj.is-a("Dict") { + die "We don't handle assigning to non-Dict types yet"; } else { - $obj.properties{$propname} = $newvalue; + $obj.value{$propname} = $newvalue; } } } diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 90e4d6a4..2b61f936 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -1,77 +1,90 @@ use v6; use _007; -use _007::Val; -use _007::Q; +use _007::Type; +use _007::Object; use _007::Backend::JavaScript; use Test; sub read(Str $ast) is export { sub n($type, $op) { - Q::Identifier.new(:name(Val::Str.new(:value($type ~ ":<$op>")))); + my $name = wrap($type ~ ":<$op>"); + return create(TYPE, :$name); } my %q_lookup = - none => Q::Literal::None, - int => Q::Literal::Int, - str => Q::Literal::Str, - array => Q::Term::Array, - object => Q::Term::Object, - regex => Q::Term::Regex, - sub => Q::Term::Sub, - quasi => Q::Term::Quasi, - - 'prefix:~' => Q::Prefix::Str, - 'prefix:+' => Q::Prefix::Plus, - 'prefix:-' => Q::Prefix::Minus, - 'prefix:^' => Q::Prefix::Upto, - - 'infix:+' => Q::Infix::Addition, - 'infix:-' => Q::Infix::Subtraction, - 'infix:*' => Q::Infix::Multiplication, - 'infix:%' => Q::Infix::Modulo, - 'infix:%%' => Q::Infix::Divisibility, - 'infix:~' => Q::Infix::Concat, - 'infix:x' => Q::Infix::Replicate, - 'infix:xx' => Q::Infix::ArrayReplicate, - 'infix:::' => Q::Infix::Cons, - 'infix:=' => Q::Infix::Assignment, - 'infix:==' => Q::Infix::Eq, - 'infix:!=' => Q::Infix::Ne, - 'infix:~~' => Q::Infix::TypeMatch, - 'infix:!~' => Q::Infix::TypeNonMatch, - - 'infix:<=' => Q::Infix::Le, - 'infix:>=' => Q::Infix::Ge, - 'infix:<' => Q::Infix::Lt, - 'infix:>' => Q::Infix::Gt, - - 'postfix:()' => Q::Postfix::Call, - 'postfix:[]' => Q::Postfix::Index, - 'postfix:.' => Q::Postfix::Property, - - my => Q::Statement::My, - stexpr => Q::Statement::Expr, - if => Q::Statement::If, - stblock => Q::Statement::Block, - stsub => Q::Statement::Sub, - macro => Q::Statement::Macro, - return => Q::Statement::Return, - for => Q::Statement::For, - while => Q::Statement::While, - begin => Q::Statement::BEGIN, - - identifier => Q::Identifier, - block => Q::Block, - param => Q::Parameter, - property => Q::Property, - - statementlist => Q::StatementList, - parameterlist => Q::ParameterList, - argumentlist => Q::ArgumentList, - propertylist => Q::PropertyList, + none => TYPE, + int => TYPE, + str => TYPE, + array => TYPE, + dict => TYPE, + object => TYPE, + regex => TYPE, + sub => TYPE, + quasi => TYPE, + + 'prefix:~' => TYPE, + 'prefix:+' => TYPE, + 'prefix:-' => TYPE, + 'prefix:^' => TYPE, + + 'infix:+' => TYPE, + 'infix:-' => TYPE, + 'infix:*' => TYPE, + 'infix:%' => TYPE, + 'infix:%%' => TYPE, + 'infix:~' => TYPE, + 'infix:x' => TYPE, + 'infix:xx' => TYPE, + 'infix:::' => TYPE, + 'infix:=' => TYPE, + 'infix:==' => TYPE, + 'infix:!=' => TYPE, + 'infix:~~' => TYPE, + 'infix:!~' => TYPE, + + 'infix:<=' => TYPE, + 'infix:>=' => TYPE, + 'infix:<' => TYPE, + 'infix:>' => TYPE, + + 'postfix:()' => TYPE, + 'postfix:[]' => TYPE, + 'postfix:.' => TYPE, + + my => TYPE, + stexpr => TYPE, + if => TYPE, + stblock => TYPE, + stsub => TYPE, + macro => TYPE, + return => TYPE, + for => TYPE, + while => TYPE, + begin => TYPE, + + identifier => TYPE, + block => TYPE, + param => TYPE, + property => TYPE, + + statementlist => TYPE, + parameterlist => TYPE, + argumentlist => TYPE, + propertylist => TYPE, ; + # XXX this is a temporary hack while we're refactoring the type system + # XXX when the system is limber enough to describe itself, it won't be necessary + my %qtype-has-just-array = qw< + Q::Term::Array 1 + Q::PropertyList 1 + Q::TraitList 1 + Q::ParameterList 1 + Q::ArgumentList 1 + Q::StatementList 1 + >; + my grammar AST::Syntax { regex TOP { \s* \s* } proto token expr {*} @@ -92,45 +105,60 @@ sub read(Str $ast) is export { my @rest = $».ast[1..*]; my $qtype = %q_lookup{$qname}; my %arguments; - my @attributes = $qtype.attributes; + my @attributes = $qtype.type-chain.reverse.map({ .fields }).flat.map({ . }); sub check-if-operator() { if $qname ~~ /^ [prefix | infix | postfix] ":"/ { # XXX: it stinks that we have to do this - %arguments = Q::Identifier.new(:name(Val::Str.new(:value($qname)))); + my $name = wrap($qname); + %arguments = create(TYPE, :$name); shift @attributes; # $.identifier } }(); - sub aname($attr) { $attr.name.substr(2) } - if @attributes == 1 && @attributes[0].type ~~ Val::Array { - my $aname = aname(@attributes[0]); - %arguments{$aname} = Val::Array.new(:elements(@rest)); + if @attributes == 1 && (%qtype-has-just-array{$qtype.name} :exists) { + my $aname = @attributes[0]; + %arguments{$aname} = wrap(@rest); } else { - die "{+@rest} arguments passed, only {+@attributes} parameters expected for {$qtype.^name}" + die "{+@rest} arguments passed, only {+@attributes} parameters expected for {$qtype.name}" if @rest > @attributes; for @attributes.kv -> $i, $attr { - if $attr.build && @rest < @attributes { + #if $attr.build && @rest < @attributes { + # @rest.splice($i, 0, "dummy value to make the indices add up"); + # next; + #} + if $attr eq "traitlist" && @rest < @attributes { @rest.splice($i, 0, "dummy value to make the indices add up"); next; } - my $aname = aname($attr); - %arguments{$aname} = @rest[$i] // last; + %arguments{$attr} = @rest[$i] // last; } } - make $qtype.new(|%arguments); + # XXX: these exceptions can go away once we support initializers + if $qtype === TYPE { + %arguments //= wrap({}); + } + if $qtype === TYPE | TYPE | TYPE { + %arguments //= create(TYPE, + :traits(wrap([])), + ); + } + make create($qtype, |%arguments); } method expr:symbol ($/) { make ~$/ } - method expr:int ($/) { make Val::Int.new(:value(+$/)) } - method expr:str ($/) { make Val::Str.new(:value((~$0).subst(q[\\"], q["], :g))) } + method expr:int ($/) { make wrap(+$/) } + method expr:str ($/) { make wrap((~$0).subst(q[\\"], q["], :g)) } }; AST::Syntax.parse($ast, :$actions) or die "couldn't parse AST syntax"; - return Q::CompUnit.new(:block(Q::Block.new( - :parameterlist(Q::ParameterList.new()), - :statementlist($/.ast) + return create(TYPE, :block(create(TYPE, + :parameterlist(create(TYPE, + :parameters(wrap([])), + )), + :statementlist($/.ast), + :static-lexpad(wrap({})), ))); } @@ -146,120 +174,123 @@ my class UnwantedOutput { method print($s) { die "Program printed '$s'; was not expected to print anything" } } -sub check(Q::CompUnit $ast, $runtime) is export { +sub check(_007::Object $ast, $runtime) is export { my %*assigned; - handle($ast); - # a bunch of nodes we don't care about descending into - multi handle(Q::ParameterList $) {} - multi handle(Q::Statement::Return $) {} - multi handle(Q::Statement::Expr $) {} - multi handle(Q::Statement::BEGIN $) {} - multi handle(Q::Literal $) {} - multi handle(Q::Term $) {} # except Q::Term::Object, see below - multi handle(Q::Postfix $) {} - - multi handle(Q::StatementList $statementlist) { - for $statementlist.statements.elements -> $statement { - handle($statement); + sub handle($ast) { + if $ast.is-a("Q::StatementList") -> $statementlist { + for $statementlist.properties.value -> $statement { + handle($statement); + } } - } - - multi handle(Q::Statement::My $my) { - my $symbol = $my.identifier.name.value; - my $block = $runtime.current-frame(); - die X::Redeclaration.new(:$symbol) - if $runtime.declared-locally($symbol); - die X::Redeclaration::Outer.new(:$symbol) - if %*assigned{$block ~ $symbol}; - $runtime.declare-var($my.identifier); - - if $my.expr !~~ Val::NoneType { - handle($my.expr); + elsif $ast.is-a("Q::Statement::My") -> $my { + my $symbol = $my.properties.properties.value; + my $block = $runtime.current-frame(); + die X::Redeclaration.new(:$symbol) + if $runtime.declared-locally($symbol); + die X::Redeclaration::Outer.new(:$symbol) + if %*assigned{$block.id ~ $symbol}; + $runtime.declare-var($my.properties); + + if $my.properties !=== NONE { + handle($my.properties); + } } - } - - multi handle(Q::Statement::Constant $constant) { - my $symbol = $constant.identifier.name.value; - my $block = $runtime.current-frame(); - die X::Redeclaration.new(:$symbol) - if $runtime.declared-locally($symbol); - die X::Redeclaration::Outer.new(:$symbol) - if %*assigned{$block ~ $symbol}; - $runtime.declare-var($symbol); - - handle($constant.expr); - } - - multi handle(Q::Statement::Block $block) { - $runtime.enter($runtime.current-frame, $block.block.static-lexpad, $block.block.statementlist); - handle($block.block.statementlist); - $block.block.static-lexpad = $runtime.current-frame.properties; - $runtime.leave(); - } - - multi handle(Q::Statement::Sub $sub) { - my $outer-frame = $runtime.current-frame; - my $name = $sub.identifier.name; - my $val = Val::Sub.new(:$name, - :parameterlist($sub.block.parameterlist), - :statementlist($sub.block.statementlist), - :$outer-frame - ); - $runtime.enter($outer-frame, Val::Object.new, $sub.block.statementlist, $val); - handle($sub.block); - $runtime.leave(); - - $runtime.declare-var($sub.identifier, $val); - } - - multi handle(Q::Statement::Macro $macro) { - my $outer-frame = $runtime.current-frame; - my $name = $macro.identifier.name; - my $val = Val::Macro.new(:$name, - :parameterlist($macro.block.parameterlist), - :statementlist($macro.block.statementlist), - :$outer-frame - ); - $runtime.enter($outer-frame, Val::Object.new, $macro.block.statementlist, $val); - handle($macro.block); - $runtime.leave(); - - $runtime.declare-var($macro.identifier, $val); - } - - multi handle(Q::Statement::If $if) { - handle($if.block); - } - - multi handle(Q::Statement::For $for) { - handle($for.block); - } - - multi handle(Q::Statement::While $while) { - handle($while.block); - } - - multi handle(Q::Block $block) { - $runtime.enter($runtime.current-frame, Val::Object.new, Q::StatementList.new); - handle($block.parameterlist); - handle($block.statementlist); - $block.static-lexpad = $runtime.current-frame.properties; - $runtime.leave(); - } - - multi handle(Q::Term::Object $object) { - handle($object.propertylist); - } - - multi handle(Q::PropertyList $propertylist) { - my %seen; - for $propertylist.properties.elements -> Q::Property $p { - my Str $property = $p.key.value; - die X::Property::Duplicate.new(:$property) - if %seen{$property}++; + elsif $ast.is-a("Q::Statement::Constant") -> $constant { + my $symbol = $constant.properties.properties.value; + my $block = $runtime.current-frame(); + die X::Redeclaration.new(:$symbol) + if $runtime.declared-locally($symbol); + die X::Redeclaration::Outer.new(:$symbol) + if %*assigned{$block.id ~ $symbol}; + $runtime.declare-var($constant.properties); + + handle($constant.expr); + } + elsif $ast.is-a("Q::Statement::Block") -> $block { + $runtime.enter( + $runtime.current-frame, + $block.properties.properties, + $block.properties.properties); + handle($block.properties.properties); + $block.properties.properties = $runtime.current-frame.value; + $runtime.leave(); + } + elsif $ast.is-a("Q::Statement::Sub") -> $sub { + my $outer-frame = $runtime.current-frame; + my $name = $sub.properties.properties; + my $val = create(TYPE, + :$name, + :parameterlist($sub.properties.properties), + :statementlist($sub.properties.properties), + :$outer-frame, + :static-lexpad(wrap({})), + ); + $runtime.enter($outer-frame, wrap({}), $sub.properties.properties, $val); + handle($sub.properties); + $runtime.leave(); + + $runtime.declare-var($sub.properties, $val); + } + elsif $ast.is-a("Q::Statement::Macro") -> $macro { + my $outer-frame = $runtime.current-frame; + my $name = $macro.properties.properties; + my $val = create(TYPE, + :$name, + :parameterlist($macro.properties.properties), + :statementlist($macro.properties.properties), + :$outer-frame, + :static-lexpad(wrap({})), + ); + $runtime.enter($outer-frame, wrap({}), $macro.properties.properties, $val); + handle($macro.properties); + $runtime.leave(); + + $runtime.declare-var($macro.properties, $val); + } + elsif $ast.is-a("Q::Statement::If") -> $if { + handle($if.properties); + } + elsif $ast.is-a("Q::Statement::For") -> $for { + handle($for.properties); + } + elsif $ast.is-a("Q::Statement::While") -> $while { + handle($while.properties); + } + elsif $ast.is-a("Q::Block") -> $block { + $runtime.enter($runtime.current-frame, wrap({}), create(TYPE, + :statements(wrap([])), + )); + handle($block.properties); + handle($block.properties); + $block.properties = $runtime.current-frame.value; + $runtime.leave(); + } + elsif $ast.is-a("Q::Term::Object") -> $object { + handle($object.properties); + } + elsif $ast.is-a("Q::Term::Dict") -> $object { + handle($object.properties); + } + elsif $ast.is-a("Q::PropertyList") -> $propertylist { + my %seen; + for $propertylist.properties.value -> _007::Object $p { + my Str $property = $p.properties.value; + die X::Property::Duplicate.new(:$property) + if %seen{$property}++; + } + } + elsif $ast.is-a("Q::ParameterList") || $ast.is-a("Q::Statement::Return") || $ast.is-a("Q::Statement::Expr") + || $ast.is-a("Q::Statement::BEGIN") || $ast.is-a("Q::Literal") || $ast.is-a("Q::Term") + || $ast.is-a("Q::Postfix") { + # we don't care about descending into these + } + else { + die "Don't know how to handle type {$ast.type}"; } } + + handle($ast); } sub is-result($input, $expected, $desc = "MISSING TEST DESCRIPTION") is export { @@ -303,7 +334,7 @@ sub parses-to($program, $expected, $desc = "MISSING TEST DESCRIPTION", Bool :$un my $parser = _007.parser(:$runtime); my $actual-ast = $parser.parse($program, :$unexpanded); - empty-diff ~$expected-ast, ~$actual-ast, $desc; + empty-diff stringify($expected-ast, $runtime), stringify($actual-ast, $runtime), $desc; } sub parse-error($program, $expected-error, $desc = $expected-error.^name) is export { diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm new file mode 100644 index 00000000..50fd8339 --- /dev/null +++ b/lib/_007/Type.pm @@ -0,0 +1,1230 @@ +sub unique-id is export { ++$ } + +constant TYPE = hash(); + +class _007::Type { ... } + +role Typable { + has $.type = TYPE; + + method install-type($type) { + $!type = $type; + } + + multi method is-a(Str $typename) { + die "Asked to typecheck against $typename but no such type is declared" + unless TYPE{$typename} :exists; + + return self.is-a(TYPE{$typename}); + } + + multi method is-a(_007::Type $type) { + # We return `self` as an "interesting truthy value" so as to enable + # renaming as part of finding out an object's true type: + # + # if $ast.is-a("Q::StatementList") -> $statementlist { + # # ... + # } + + return $type (elem) $.type.type-chain && self; + } +} + +class _007::Type does Typable { + has Str $.name; + has $.base = TYPE; + has @.fields; + has Bool $.is-abstract = False; + # XXX: $.id + + method install-base($none) { + $!base = $none; + } + + method type-chain() { + my @chain; + my $t = self; + while $t ~~ _007::Type { + @chain.push($t); + $t.=base; + } + return @chain; + } +} + +BEGIN { + ### ### Object + ### + ### The topmost type in the type system. Every value in 007 is a subtype of + ### `Object`. + ### + ### XXX: mention `id` and maybe some other things + ### + TYPE = _007::Type.new(:name); + + ### ### Type + ### + ### A type in 007's type system. All values have a type, which determines + ### the value's "shape": what properties it can have, and which of these + ### are required. + ### + ### say(type(007)); # --> `` + ### say(type("Bond")); # --> `` + ### say(type({})); # --> `` + ### say(type(type({}))); # --> `` + ### + ### 007 comes with a number of built-in types: `NoneType`, `Bool`, `Int`, + ### `Str`, `Array`, `Object`, `Regex`, `Type`, `Block`, `Sub`, `Macro`, + ### and `Exception`. + ### + ### There's also a whole hierarchy of Q types, which describe parts of + ### program structure. + ### + ### Besides these built-in types, the programmer can also introduce new + ### types by using the `class` statement: + ### + ### class C { # TODO: improve this example + ### } + ### say(type(new C {})); # --> `` + ### say(type(C)); # --> `` + ### + ### If you want to check whether a certain object is of a certain type, + ### you can use the `infix:<~~>` operator: + ### + ### say(42 ~~ Int); # --> `True` + ### say(42 ~~ Str); # --> `False` + ### + ### The `infix:<~~>` operator respects subtyping, so checking against a + ### wider type also gives a `True` result: + ### + ### my q = new Q::Literal::Int { value: 42 }; + ### say(q ~~ Q::Literal::Int); # --> `True` + ### say(q ~~ Q::Literal); # --> `True` + ### say(q ~~ Q); # --> `True` + ### say(q ~~ Int); # --> `False` + ### + ### If you want *exact* type matching (which isn't a very OO thing to want), + ### consider using infix:<==> on the respective type objects instead: + ### + ### my q = new Q::Literal::Str { value: "Bond" }; + ### say(type(q) == Q::Literal::Str); # --> `True` + ### say(type(q) == Q::Literal); # --> `False` + ### + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); + TYPE.install-type(TYPE); + + ### ### NoneType + ### + ### A type with only one value, indicating the lack of a value where one was + ### expected. + ### + ### It is the value variables have that haven't been assigned to: + ### + ### my empty; + ### say(empty); # --> `None` + ### + ### It is also the value returned from a subroutine that didn't explicitly + ### return a value: + ### + ### sub noreturn() { + ### } + ### say(noreturn()); # --> `None` + ### + ### Finally, it's found in various places in the Q hierarchy to indicate that + ### a certain child element is not present. For example, a `my` declaration + ### can have an assignment attached to it, in which case its `expr` property + ### is a `Q::Expr` — but if no assignment is present, the `expr` + ### property is the value `None`. + ### + ### say(type((quasi @ Q::Statement { my x = 2 }).expr)); # --> `` + ### say(type((quasi @ Q::Statement { my x; }).expr)); # --> `` + ### + ### The value `None` is falsy, stringifies to `None`, and doesn't numify. + ### + ### say(!!None); # --> `False` + ### say(~None); # --> `None` + ### say(+None); # + ### + ### Since `None` is often used as a default, there's an operator `infix:` + ### that evaluates its right-hand side if it finds `None` on the left: + ### + ### say(None // "default"); # --> `default` + ### say("value" // "default"); # --> `value` + ### + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); + + ### ### Bool + ### + ### A type with two values, `True` and `False`. These are often the result + ### of comparisons or match operations, such as `infix:<==>` or `infix:<~~>`. + ### + ### say(2 + 2 == 5); # --> `False` + ### say(7 ~~ Int); # --> `True` + ### + ### In 007 as in many other dynamic languages, it's not necessary to use + ### `True` or `False` values directly in conditions such as `if` statements + ### or `while` loops. *Any* value can be used, and there's always a way + ### for each type to convert any of its values to a boolean value: + ### + ### sub check(value) { + ### if value { + ### say("truthy"); + ### } + ### else { + ### say("falsy"); + ### } + ### } + ### check(None); # --> `falsy` + ### check(False); # --> `falsy` + ### check(0); # --> `falsy` + ### check(""); # --> `falsy` + ### check([]); # --> `falsy` + ### check({}); # --> `falsy` + ### # all other values are truthy + ### check(True); # --> `truthy` + ### check(42); # --> `truthy` + ### check("James"); # --> `truthy` + ### check([0, 0, 7]); # --> `truthy` + ### check({ name: "Jim" }); # --> `truthy` + ### + ### Similarly, when applying the `infix:<||>` and `infix:<&&>` macros to + ### some expressions, the result isn't coerced to a boolean value, but + ### instead the last value that needed to be evaluated is returned as-is: + ### + ### say(1 || 2); # --> `1` + ### say(1 && 2); # --> `2` + ### say(None && "!"); # --> `None` + ### say(None || "!"); # --> `!` + ### + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); +} + +### ### Int +### +### An whole number value, such as -8, 0, or 16384. +### +### Implementations are required to represent `Int` values either as 32-bit +### or as arbitrary-precision bigints. +### +### The standard arithmetic operations are defined in the language, with the +### notable exception of division. +### +### say(-7); # --> `-7` +### say(3 + 2); # --> `5` +### say(3 * 2); # --> `6` +### say(3 % 2); # --> `1` +### +### Division is not defined, because there's no sensible thing to return for +### something like `3 / 2`. Returning `1.5` is not an option, because the +### language does not have a built-in rational or floating-point type. +### Returning `1` (truncating to an integer) would be possible but +### unsatisfactory and a source of confusion. +### +### There are also a few methods defined on `Int`: +### +### say((-7).abs()); # --> `7` +### say(97.chr()); # --> `a` +### +TYPE = _007::Type.new(:name); + +### ### Str +### +### A piece of text. Strings are frequent whenever a program does text-based +### input/output. Since this language cares a lot about parsing, strings occur +### a lot. +### +### A number of useful operators are defined to work with strings: +### +### say("James" ~ " Bond"); # --> `James Bond` +### say("tap" x 3); # --> `taptaptap` +### +### Besides which, the `Str` type also carries many useful methods: +### +### say("x".ord()); # --> `120` +### say("James".chars()); # --> `5` +### say("Bond".uc()); # --> `BOND` +### say("Bond".lc()); # --> `bond` +### say(" hi ".trim()); # --> `hi` +### say("1,2,3".split(",")); # --> `["1", "2", "3"]` +### say([4, 5].join(":")); # --> `4:5` +### say("a fool's errand".index("foo")); # --> `2` +### say("abcd".substr(1, 2)); # --> `bc` +### say("abcd".prefix(3)); # --> `abc` +### say("abcd".suffix(2)); # --> `cd` +### say("James Bond".contains("s B")); # --> `True` +### say("James".charat(2)); # --> `m` +### +TYPE = _007::Type.new(:name); + +### ### Array +### +### A mutable sequence of values. An array contains zero or more elements, +### indexed from `0` up to `size - 1`, where `size` is the number of +### elements. +### +### Besides creating an array using an array term, one can also use the +### "upto" prefix operator, which creates an array where the elemens equal the +### indices: +### +### say(["a", "b", "c"]); # --> `["a", "b", "c"]` +### say(^3); # --> `[0, 1, 2]` +### +### Other array constructors which create entirely new arrays out of old ones +### (and leave the old ones unchanged) are concatenation and consing: +### +### say([1, 2].concat([3, 4])); # --> `[1, 2, 3, 4]` +### say(0 :: [0, 7]); # --> `[0, 0, 7]` +### +### Sorting, shuffling, and reversing an array also leave the original +### array unchanged: +### +### my a = [6, 4, 5]; +### say(a.reverse()); # --> `[5, 4, 6]` +### say(a); # --> `[6, 4, 5]` +### say(a.sort()); # --> `[4, 5, 6]` +### say(a); # --> `[6, 4, 5]` +### say(a.shuffle().sort()); # --> `[4, 5, 6]` +### say(a); # --> `[6, 4, 5]` +### +### The `.size` method gives you the length (number of elements) of the +### array: +### +### say([].size()); # --> `0` +### say([1, 2, 3].size()); # --> `3` +### +### Some common methods use the fact that the array is mutable: +### +### my a = [1, 2, 3]; +### a.push(4); +### say(a); # --> `[1, 2, 3, 4]` +### my x = a.pop(); +### say(x); # --> `4` +### say(a); # --> `[1, 2, 3]` +### +### my a = ["a", "b", "c"]; +### my y = a.shift(); +### say(y); # --> `a` +### say(a); # --> `["b", "c"]` +### a.unshift(y); +### say(a); # --> `["a", "b", "c"]` +### +### You can also *transform* an entire array, either by mapping +### each element through a function, or by filtering each element +### through a predicate function: +### +### my numbers = [1, 2, 3, 4, 5]; +### say(numbers.map(sub (e) { return e * 2 })); # --> `[2, 4, 6, 8, 10]` +### say(numbers.filter(sub (e) { return e %% 2 })); # --> `[2, 4]` +### +TYPE = _007::Type.new(:name); + +### ### Dict +### +### An unordered collection of key/value pairs. +### +### The way to create a dict from scratch is to write a dict term: +### +### my d1 = { foo: 42 }; # autoquoted key +### my d2 = { "foo": 42 }; # string key +### say(d1 == d2); # --> `True` +### my foo = 42; +### my d3 = { foo }; # property shorthand +### say(d1 == d3); # --> `True` +### +### All of the above will create objects of type `Dict`. +### +### say(type({})); # --> `` +### +### Dicts have various methods on them: +### +### my d = { foo: 1, bar: 2 }; +### say(d.size()); # --> `2` +### say(d.keys().sort()); # --> `["bar", "foo"]` +### +TYPE = _007::Type.new(:name); + +### ### Exception +### +### An exception. Represents an error condition, or some other way control +### flow couldn't continue normally. +### +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], +); + +### ### Sub +### +### A subroutine. When you define a subroutine in 007, the value of the +### name bound is a `Sub` object. +### +### sub agent() { +### return "Bond"; +### } +### say(agent); # --> `` +### +### Subroutines are mostly distinguished by being *callable*, that is, they +### can be called at runtime by passing some values into them. +### +### sub add(x, y) { +### return x + y; +### } +### say(add(2, 5)); # --> `7` +### +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + { :name, :type }, # XXX: add an initializer + { :name, :type }, # XXX: make optional + ], +); + +### ### Macro +### +### A macro. When you define a macro in 007, the value of the name bound +### is a macro object. +### +### macro agent() { +### return quasi { "Bond" }; +### } +### say(agent); # --> `` +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Regex +### +### A regex. As a runtime value, a regex is like a black box that can be put +### to work matching strings or parts of strings. Its main purpose is +### to let us know whether the string matches the pattern described in the +### regex. In other words, it returns `True` or `False`. +### +### (Regexes are currently under development, and are hidden behind a feature +### flag for the time being: `FLAG_007_REGEX`.) +### +### A few methods are defined on regexes: +### +### say(/"Bond"/.fullmatch("J. Bond")); # --> `False` +### say(/"Bond"/.search("J. Bond")); # --> `True` +### +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], +); + +### ### Q +### +### An program element; anything that forms a node in the syntax tree +### representing a program. +### +TYPE = _007::Type.new(:name, :is-abstract); + +### ### Q::Expr +### +### An expression; something that can be evaluated to a value. +### +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### Q::Term +### +### A term; a unit of parsing describing a value or an identifier. Along with +### operators, what makes up expressions. +### +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### Q::Literal +### +### A literal; a constant value written out explicitly in the program, such as +### `None`, `True`, `5`, or `"James Bond"`. +### +### Compound values such as arrays and objects are considered terms but not +### literals. +### +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### Q::Literal::None +### +### The `None` literal. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Literal::Bool +### +### A boolean literal; either `True` or `False`. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Literal::Int +### +### An integer literal; a non-negative number. +### +### Negative numbers are not themselves considered integer literals: something +### like `-5` is parsed as a `prefix:<->` containing a literal `5`. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Literal::Str +### +### A string literal. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Identifier +### +### An identifier; a name which identifies a storage location in the program. +### +### Identifiers are subject to *scoping*: the same name can point to different +### storage locations because they belong to different scopes. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type("Dict"), :optional }, + ], +); + +### ### Q::Term::Regex +### +### A regular expression (*regex*). +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Term::Array +### +### An array. Array terms consist of zero or more *elements*, each of which +### can be an arbitrary expression. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Term::Dict +### +### A dictionary. Dict terms consist of zero or more *properties*, each of which +### consists of a key and a value. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Term::Object +### +### An object. Object terms consist of an optional *type*, and a property list +### with zero or more key/value pairs. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Property +### +### An object property. Properties have a key and a value. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::PropertyList +### +### A property list in an object. Property lists have zero or more key/value +### pairs. Keys in objects are considered unordered, but a property list has +### a specified order: the order the properties occur in the program text. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Trait +### +### A trait; a piece of metadata for a routine. A trait consists of an +### identifier and an expression. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::TraitList +### +### A list of zero or more traits. Each routine has a traitlist. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Term::Sub +### +### A subroutine. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Identifier | NoneType") }, # XXX: make optional + { :name, :type }, # XXX: give initializer + { :name, :type }, + ], +); + +### ### Q::Block +### +### A block. Blocks are used in a number of places: by routines, by +### block statements, by other compound statements (such as `if` statements) +### and by `quasi` terms and sub terms. Blocks are not, however, terms +### in their own regard. +### +### A block has a parameter list and a statement list, each of which can +### be empty. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type("Dict | NoneType") }, # XXX: make optional + ], +); + +### ### Q::Prefix +### +### A prefix operator; an operator that occurs before a term, like the +### `-` in `-5`. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, + ], +); + +### ### Q::Prefix::Str +### +### A stringification operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Prefix::Plus +### +### A numification operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Prefix::Minus +### +### A numeric negation operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Prefix::So +### +### A boolification operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Prefix::Not +### +### A boolean negation operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Prefix::Upto +### +### An "upto" operator; applied to a number `n` it produces an array +### of values `[0, 1, ..., n-1]`. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix +### +### An infix operator; something like the `+` in `2 + 2` that occurs between +### two terms. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, + ], +); + +### ### Q::Infix::Addition +### +### A numeric addition operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Subtraction +### +### A numeric subtraction operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Multiplication +### +### A numeric multiplication operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Modulo +### +### A numeric modulo operator; produces the *remainder* left from an integer +### division between two numbers. For example, `456 % 100` is `56` because the +### remainder from dividing `456` by `100` is `56`. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Divisibility +### +### A divisibility test operator. Returns `True` exactly when the remainder +### operator would return `0`. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Concat +### +### A string concatenation operator. Returns a single string that is the +### result of sequentially putting two strings together. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Replicate +### +### A string replication operator. Returns a string which consists of `n` +### copies of a string. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::ArrayReplicate +### +### An array replication operator. Returns an array which consists of +### the original array's elements, repeated `n` times. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Cons +### +### A "cons" operator. Given a value and an array, returns a new +### array with the value added as the first element. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Assignment +### +### An assignment operator. Puts a value in a storage location. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Eq +### +### An equality test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Ne +### +### An inequality test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Gt +### +### A greater-than test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Lt +### +### A less-than test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Ge +### +### A greater-than-or-equal test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Le +### +### A less-than-or-equal test operator. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::Or +### +### A short-circuiting disjunction operator; evaluates its right-hand +### side only if the left-hand side is falsy. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::DefinedOr +### +### A short-circuiting "defined-or" operator. Evaluates its +### right-hand side only if the left-hand side is `None`. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::And +### +### A short-circuiting "and" operator. Evaluates its +### right-hand side only if the left-hand side is truthy. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::TypeMatch +### +### A type match operator. Checks if a value on the left-hand side has +### the type on the right-hand side, including subtypes. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Infix::TypeNonMatch +### +### A negative type match operator. Returns `True` exactly in the cases +### a type match would return `False`. +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Postfix +### +### A postfix operator; something like the `[0]` in `agents[0]` that occurs +### after a term. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | Q::Unquote | NoneType") }, # XXX: Q::Unquote needs mulling over + ], +); + +### ### Q::Postfix::Index +### +### An indexing operator; returns an array element or object property. +### Arrays expect integer indices and objects expect string property names. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Expr | NoneType") }, + ], +); + +### ### Q::Postfix::Call +### +### An invocation operator; calls a routine. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::ArgumentList | Q::Unquote | NoneType") }, # XXX: Q::Unquote needs mulling over + ], +); + +### ### Q::Postfix::Property +### +### An object property operator; fetches a property out of an object. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Expr | NoneType") }, + ], +); + +### ### Q::Unquote +### +### An unquote; allows Qtree fragments to be inserted into places in a quasi. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Unquote::Prefix +### +### An unquote which is a prefix operator. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Unquote::Infix +### +### An unquote which is an infix operator. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Term::Quasi +### +### A quasi; a piece of 007 code which evaluates to that code's Qtree +### representation. A way to "quote" code in a program instead of running +### it directly in place. Used together with macros. +### +### The term "quasi" comes from the fact that inside the quoted code there +### can be parametric holes ("unquotes") where Qtree fragments can be +### inserted. Quasiquotation is the practice of combining literal code +### fragments with such parametric holes. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Parameter +### +### A parameter. Any identifier that's declared as the input to a block +### is a parameter, including subs, macros, and `if` statements. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::ParameterList +### +### A list of zero or more parameters. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::ArgumentList +### +### A list of zero or more arguments. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Statement +### +### A statement. +### +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### Q::Statement::My +### +### A `my` variable declaration statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type("Q::Expr"), :optional }, + ], +); + +### ### Q::Statement::Constant +### +### A `constant` declaration statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Statement::Expr +### +### A statement consisting of an expression. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Statement::If +### +### An `if` statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type("Q::Block | Q::Statement::If"), :optional }, + ], +); + +### ### Q::Statement::Block +### +### A block statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::CompUnit +### +### A block-level statement representing a whole compilation unit. +### We can read "compilation unit" here as meaning "file". +### +TYPE = _007::Type.new(:name, :base(TYPE)); + +### ### Q::Statement::For +### +### A `for` loop statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Statement::While +### +### A `while` loop statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Statement::Return +### +### A `return` statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type("Q::Expr"), :optional }, + ], +); + +### ### Q::Statement::Throw +### +### A `throw` statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Statement::Sub +### +### A subroutine declaration statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Statement::Macro +### +### A macro declaration statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + ], +); + +### ### Q::Statement::BEGIN +### +### A `BEGIN` block statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Statement::Class +### +### A class declaration statement. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::StatementList +### +### A list of zero or more statements. Statement lists commonly occur +### directly inside blocks (or at the top level of the program, on the +### compunit level). However, it's also possible for a `quasi` to +### denote a statement list without any surrounding block. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); + +### ### Q::Expr::StatementListAdapter +### +### An expression which holds a statement list. Surprisingly, this never +### happens in the source code text itself; because of 007's grammar, an +### expression can never consist of a list of statements. +### +### However, it can happen as a macro call (an expression) expands into +### a statement list; that's when this Qtype is used. +### +### Semantically, the contained statement list is executed normally, and +### if execution evaluates the last statement and the statement turns out +### to have a value (because it's an expression statement), then this +### value is the value of the whole containing expression. +### +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm deleted file mode 100644 index 94bbd5be..00000000 --- a/lib/_007/Val.pm +++ /dev/null @@ -1,595 +0,0 @@ -use MONKEY-SEE-NO-EVAL; - -class X::Uninstantiable is Exception { - has Str $.name; - - method message() { " is abstract and uninstantiable"; } -} - -class Helper { ... } - -role Val { - method truthy { True } - method attributes { self.^attributes } - method quoted-Str { self.Str } - - method Str { - my %*stringification-seen; - Helper::Str(self); - } -} - -### ### NoneType -### -### A type with only one value, indicating the lack of a value where one was -### expected. -### -### It is the value variables have that haven't been assigned to: -### -### my empty; -### say(empty); # --> `None` -### -### It is also the value returned from a subroutine that didn't explicitly -### return a value: -### -### sub noreturn() { -### } -### say(noreturn()); # --> `None` -### -### Finally, it's found in various places in the Q hierarchy to indicate that -### a certain child element is not present. For example, a `my` declaration -### can have an assignment attached to it, in which case its `expr` property -### is a `Q::Expr` — but if no assignment is present, the `expr` -### property is the value `None`. -### -### say(type((quasi @ Q::Statement { my x = 2 }).expr)); # --> `` -### say(type((quasi @ Q::Statement { my x; }).expr)); # --> `` -### -### The value `None` is falsy, stringifies to `None`, and doesn't numify. -### -### say(!!None); # --> `False` -### say(~None); # --> `None` -### say(+None); # -### -### Since `None` is often used as a default, there's an operator `infix:` -### that evaluates its right-hand side if it finds `None` on the left: -### -### say(None // "default"); # --> `default` -### say("value" // "default"); # --> `value` -### -class Val::NoneType does Val { - method truthy { - False - } -} - -constant NONE is export = Val::NoneType.new; - -### ### Bool -### -### A type with two values, `True` and `False`. These are often the result -### of comparisons or match operations, such as `infix:<==>` or `infix:<~~>`. -### -### say(2 + 2 == 5); # --> `False` -### say(7 ~~ Int); # --> `True` -### -### In 007 as in many other dynamic languages, it's not necessary to use -### `True` or `False` values directly in conditions such as `if` statements -### or `while` loops. *Any* value can be used, and there's always a way -### for each type to convert any of its values to a boolean value: -### -### sub check(value) { -### if value { -### say("truthy"); -### } -### else { -### say("falsy"); -### } -### } -### check(None); # --> `falsy` -### check(False); # --> `falsy` -### check(0); # --> `falsy` -### check(""); # --> `falsy` -### check([]); # --> `falsy` -### check({}); # --> `falsy` -### # all other values are truthy -### check(True); # --> `truthy` -### check(42); # --> `truthy` -### check("James"); # --> `truthy` -### check([0, 0, 7]); # --> `truthy` -### check({ name: "Jim" }); # --> `truthy` -### -### Similarly, when applying the `infix:<||>` and `infix:<&&>` macros to -### some expressions, the result isn't coerced to a boolean value, but -### instead the last value that needed to be evaluated is returned as-is: -### -### say(1 || 2); # --> `1` -### say(1 && 2); # --> `2` -### say(None && "!"); # --> `None` -### say(None || "!"); # --> `!` -### -class Val::Bool does Val { - has Bool $.value; - - method truthy { - $.value; - } -} - -### ### Int -### -### An whole number value, such as -8, 0, or 16384. -### -### Implementations are required to represent `Int` values either as 32-bit -### or as arbitrary-precision bigints. -### -### The standard arithmetic operations are defined in the language, with the -### notable exception of division. -### -### say(-7); # --> `-7` -### say(3 + 2); # --> `5` -### say(3 * 2); # --> `6` -### say(3 % 2); # --> `1` -### -### Division is not defined, because there's no sensible thing to return for -### something like `3 / 2`. Returning `1.5` is not an option, because the -### language does not have a built-in rational or floating-point type. -### Returning `1` (truncating to an integer) would be possible but -### unsatisfactory and a source of confusion. -### -### There are also a few methods defined on `Int`: -### -### say((-7).abs()); # --> `7` -### say(97.chr()); # --> `a` -### -class Val::Int does Val { - has Int $.value; - - method truthy { - ?$.value; - } -} - -### ### Str -### -### A piece of text. Strings are frequent whenever a program does text-based -### input/output. Since this language cares a lot about parsing, strings occur -### a lot. -### -### A number of useful operators are defined to work with strings: -### -### say("James" ~ " Bond"); # --> `James Bond` -### say("tap" x 3); # --> `taptaptap` -### -### Besides which, the `Str` type also carries many useful methods: -### -### say("x".ord()); # --> `120` -### say("James".chars()); # --> `5` -### say("Bond".uc()); # --> `BOND` -### say("Bond".lc()); # --> `bond` -### say(" hi ".trim()); # --> `hi` -### say("1,2,3".split(",")); # --> `["1", "2", "3"]` -### say([4, 5].join(":")); # --> `4:5` -### say("a fool's errand".index("foo")); # --> `2` -### say("abcd".substr(1, 2)); # --> `bc` -### say("abcd".prefix(3)); # --> `abc` -### say("abcd".suffix(2)); # --> `cd` -### say("James Bond".contains("s B")); # --> `True` -### say("James".charat(2)); # --> `m` -### -class Val::Str does Val { - has Str $.value; - - method quoted-Str { - q["] ~ $.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["] - } - - method truthy { - ?$.value; - } -} - -### ### Regex -### -### A regex. As a runtime value, a regex is like a black box that can be put -### to work matching strings or parts of strings. Its main purpose is -### to let us know whether the string matches the pattern described in the -### regex. In other words, it returns `True` or `False`. -### -### (Regexes are currently under development, and are hidden behind a feature -### flag for the time being: `FLAG_007_REGEX`.) -### -### A few methods are defined on regexes: -### -### say(/"Bond"/.fullmatch("J. Bond")); # --> `False` -### say(/"Bond"/.search("J. Bond")); # --> `True` -### -class Val::Regex does Val { - has Val::Str $.contents; - - method quoted-Str { - "/" ~ $.contents.quoted-Str ~ "/" - } -} - -### ### Array -### -### A mutable sequence of values. An array contains zero or more elements, -### indexed from `0` up to `size - 1`, where `size` is the number of -### elements. -### -### Besides creating an array using an array term, one can also use the -### "upto" prefix operator, which creates an array where the elemens equal the -### indices: -### -### say(["a", "b", "c"]); # --> `["a", "b", "c"]` -### say(^3); # --> `[0, 1, 2]` -### -### Other array constructors which create entirely new arrays out of old ones -### (and leave the old ones unchanged) are concatenation and consing: -### -### say([1, 2].concat([3, 4])); # --> `[1, 2, 3, 4]` -### say(0 :: [0, 7]); # --> `[0, 0, 7]` -### -### Sorting, shuffling, and reversing an array also leave the original -### array unchanged: -### -### my a = [6, 4, 5]; -### say(a.reverse()); # --> `[5, 4, 6]` -### say(a); # --> `[6, 4, 5]` -### say(a.sort()); # --> `[4, 5, 6]` -### say(a); # --> `[6, 4, 5]` -### say(a.shuffle().sort()); # --> `[4, 5, 6]` -### say(a); # --> `[6, 4, 5]` -### -### The `.size` method gives you the length (number of elements) of the -### array: -### -### say([].size()); # --> `0` -### say([1, 2, 3].size()); # --> `3` -### -### Some common methods use the fact that the array is mutable: -### -### my a = [1, 2, 3]; -### a.push(4); -### say(a); # --> `[1, 2, 3, 4]` -### my x = a.pop(); -### say(x); # --> `4` -### say(a); # --> `[1, 2, 3]` -### -### my a = ["a", "b", "c"]; -### my y = a.shift(); -### say(y); # --> `a` -### say(a); # --> `["b", "c"]` -### a.unshift(y); -### say(a); # --> `["a", "b", "c"]` -### -### You can also *transform* an entire array, either by mapping -### each element through a function, or by filtering each element -### through a predicate function: -### -### my numbers = [1, 2, 3, 4, 5]; -### say(numbers.map(sub (e) { return e * 2 })); # --> `[2, 4, 6, 8, 10]` -### say(numbers.filter(sub (e) { return e %% 2 })); # --> `[2, 4]` -### -class Val::Array does Val { - has @.elements; - - method quoted-Str { - if %*stringification-seen{self.WHICH}++ { - return "[...]"; - } - return "[" ~ @.elements>>.quoted-Str.join(', ') ~ "]"; - } - - method truthy { - ?$.elements - } -} - -our $global-object-id = 0; - -### ### Object -### -### A mutable unordered collection of key/value properties. An object -### contains zero or more such properties, each with a unique string -### name. -### -### The way to create an object from scratch is to use the object term -### syntax: -### -### my o1 = { foo: 42 }; # autoquoted key -### my o2 = { "foo": 42 }; # string key -### say(o1 == o2); # --> `True` -### my foo = 42; -### my o3 = { foo }; # property shorthand -### say(o1 == o3); # --> `True` -### -### my o4 = { -### greet: sub () { -### return "hi!"; -### } -### }; -### my o5 = { -### greet() { # method shorthand -### return "hi!"; -### } -### }; -### say(o4.greet() == o5.greet()); # --> `True` -### -### All of the above will create objects of type `Object`, which is -### the topmost type in the type system. `Object` also has the special -### property that it can accept any set of keys. -### -### say(type({})); # --> `` -### -### There are also two ways to create a new, similar object from an old one. -### -### my o6 = { -### name: "James", -### job: "librarian" -### }; -### my o7 = o6.update({ -### job: "secret agent" -### }); -### say(o7); # --> `{job: "secret agent", name: "James"}` -### -### my o8 = { -### name: "Blofeld" -### }; -### my o9 = o8.extend({ -### job: "supervillain" -### }); -### say(o9); # --> `{job: "supervillain", name: "Blofeld"}` -### -### There's a way to extract an array of an object's keys. The order of the keys in -### this list is not defined and may even change from call to call. -### -### my o10 = { -### one: 1, -### two: 2, -### three: 3 -### }; -### say(o10.keys().sort()); # --> `["one", "three", "two"]` -### -### You can also ask whether a key exists on an object. -### -### my o11 = { -### foo: 42, -### bar: None -### }; -### say(o11.has("foo")); # --> `True` -### say(o11.has("bar")); # --> `True` -### say(o11.has("bazinga")); # --> `False` -### -### Note that the criterion is whether the *key* exists, not whether the -### corresponding value is defined. -### -### Each object has a unique ID, corresponding to references in other -### languages. Comparison of objects happens by comparing keys and values, -### not by reference. If you want to do a reference comparison, you need -### to use the `.id` property: -### -### my o12 = { foo: 5 }; -### my o13 = { foo: 5 }; # same key/value but different reference -### say(o12 == o13); # --> `True` -### say(o12.id == o13.id); # --> `False` -### -class Val::Object does Val { - has %.properties{Str}; - has $.id = $global-object-id++; - - method quoted-Str { - if %*stringification-seen{self.WHICH}++ { - return "\{...\}"; - } - return '{' ~ %.properties.map({ - my $key = .key ~~ /^ [\w+]+ % '::'$/ - ?? .key - !! Val::Str.new(value => .key).quoted-Str; - "{$key}: {.value.quoted-Str}" - }).sort.join(', ') ~ '}'; - } - - method truthy { - ?%.properties - } -} - -### ### Type -### -### A type in 007's type system. All values have a type, which determines -### the value's "shape": what properties it can have, and which of these -### are required. -### -### say(type(007)); # --> `` -### say(type("Bond")); # --> `` -### say(type({})); # --> `` -### say(type(type({}))); # --> `` -### -### 007 comes with a number of built-in types: `NoneType`, `Bool`, `Int`, -### `Str`, `Array`, `Object`, `Regex`, `Type`, `Block`, `Sub`, `Macro`, -### and `Exception`. -### -### There's also a whole hierarchy of Q types, which describe parts of -### program structure. -### -### Besides these built-in types, the programmer can also introduce new -### types by using the `class` statement: -### -### class C { # TODO: improve this example -### } -### say(type(new C {})); # --> `` -### say(type(C)); # --> `` -### -### If you want to check whether a certain object is of a certain type, -### you can use the `infix:<~~>` operator: -### -### say(42 ~~ Int); # --> `True` -### say(42 ~~ Str); # --> `False` -### -### The `infix:<~~>` operator respects subtyping, so checking against a -### wider type also gives a `True` result: -### -### my q = new Q::Literal::Int { value: 42 }; -### say(q ~~ Q::Literal::Int); # --> `True` -### say(q ~~ Q::Literal); # --> `True` -### say(q ~~ Q); # --> `True` -### say(q ~~ Int); # --> `False` -### -### If you want *exact* type matching (which isn't a very OO thing to want), -### consider using infix:<==> on the respective type objects instead: -### -### my q = new Q::Literal::Str { value: "Bond" }; -### say(type(q) == Q::Literal::Str); # --> `True` -### say(type(q) == Q::Literal); # --> `False` -### -class Val::Type does Val { - has $.type; - - method of($type) { - self.bless(:$type); - } - - sub is-role($type) { - my role R {}; - return $type.HOW ~~ R.HOW.WHAT; - } - - method create(@properties) { - if $.type ~~ Val::Object { - return $.type.new(:@properties); - } - elsif $.type ~~ Val::Int | Val::Str { - return $.type.new(:value(@properties[0].value.value)); - } - elsif $.type ~~ Val::Array { - return $.type.new(:elements(@properties[0].value.elements)); - } - elsif $.type ~~ Val::Type { - my $name = @properties[0].value; - return $.type.new(:type(EVAL qq[class :: \{ - method attributes \{ () \} - method ^name(\$) \{ "{$name}" \} - \}])); - } - elsif is-role($.type) { - die X::Uninstantiable.new(:$.name); - } - else { - return $.type.new(|%(@properties)); - } - } - - method name { - $.type.^name.subst(/^ "Val::"/, ""); - } -} - -### ### Sub -### -### A subroutine. When you define a subroutine in 007, the value of the -### name bound is a `Sub` object. -### -### sub agent() { -### return "Bond"; -### } -### say(agent); # --> `` -### -### Subroutines are mostly distinguished by being *callable*, that is, they -### can be called at runtime by passing some values into them. -### -### sub add(x, y) { -### return x + y; -### } -### say(add(2, 5)); # --> `7` -### -class Val::Sub is Val { - has Val::Str $.name; - has &.hook = Callable; - has $.parameterlist; - has $.statementlist; - has Val::Object $.static-lexpad is rw = Val::Object.new; - has Val::Object $.outer-frame; - - method new-builtin(&hook, Str $name, $parameterlist, $statementlist) { - self.bless(:name(Val::Str.new(:value($name))), :&hook, :$parameterlist, :$statementlist); - } - - method escaped-name { - sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } - sub escape-less-thans($s) { $s.subst(/"<"/, "\\<", :g) } - - return $.name.value - unless $.name.value ~~ /^ (prefix | infix | postfix) ':' (.+) /; - - return "{$0}:<{escape-less-thans escape-backslashes $1}>" - if $1.contains(">") && $1.contains("»"); - - return "{$0}:«{escape-backslashes $1}»" - if $1.contains(">"); - - return "{$0}:<{escape-backslashes $1}>"; - } - - method pretty-parameters { - sprintf "(%s)", $.parameterlist.parameters.elements».identifier».name.join(", "); - } - - method Str { "" } -} - -### ### Macro -### -### A macro. When you define a macro in 007, the value of the name bound -### is a macro object. -### -### macro agent() { -### return quasi { "Bond" }; -### } -### say(agent); # --> `` -### -class Val::Macro is Val::Sub { - method Str { "" } -} - -### ### Exception -### -### An exception. Represents an error condition, or some other way control -### flow couldn't continue normally. -### -class Val::Exception does Val { - has Val::Str $.message; -} - -class Helper { - our sub Str($_) { - when Val::NoneType { "None" } - when Val::Bool { .value.Str } - when Val::Int { .value.Str } - when Val::Str { .value } - when Val::Regex { .quoted-Str } - when Val::Array { .quoted-Str } - when Val::Object { .quoted-Str } - when Val::Type { "" } - when Val::Macro { "" } - when Val::Sub { "" } - when Val::Exception { "Exception \{message: {.message.quoted-Str}\}" } - default { - my $self = $_; - die "Unexpected type -- some invariant must be broken" - unless $self.^name ~~ /^ "Q::"/; # type not introduced yet; can't typecheck - - sub aname($attr) { $attr.name.substr(2) } - sub avalue($attr, $obj) { $attr.get_value($obj) } - - my @attrs = $self.attributes; - if @attrs == 1 { - return "{.^name} { avalue(@attrs[0], $self).quoted-Str }"; - } - sub keyvalue($attr) { aname($attr) ~ ": " ~ avalue($attr, $self).quoted-Str } - my $contents = @attrs.map(&keyvalue).join(",\n").indent(4); - return "{$self.^name} \{\n$contents\n\}"; - } - } -} diff --git a/self-host/runtime.007 b/self-host/runtime.007 index 9df60b01..de2d588e 100644 --- a/self-host/runtime.007 +++ b/self-host/runtime.007 @@ -2,10 +2,13 @@ my ast; if !ast { ast = new Q::CompUnit { block: new Q::Block { - parameterlist: new Q::ParameterList {}, + parameterlist: new Q::ParameterList { + parameters: [], + }, statementlist: new Q::StatementList { - statements: [] - } + statements: [], + }, + "static-lexpad": {}, } }; } @@ -69,7 +72,7 @@ my Runtime = { if paramcount != argcount { throw new Exception { message: "parameter mismatch" }; } - enter(c["outer-frame"], c["static-lexpad"]); + enter(c.get("outer-frame"), c.get("static-lexpad")); for ^argcount -> i { my param = c.parameterlist.parameters[i]; my arg = arguments[i]; @@ -197,7 +200,7 @@ my Runtime = { name, parameterlist: term.block.parameterlist, statementlist: term.block.statementlist, - "static-lexpad": term.block["static-lexpad"], + "static-lexpad": term.block.get("static-lexpad"), "outer-frame": current_frame(), }; }, @@ -226,7 +229,7 @@ my Runtime = { # no runtime behavior }, Q::CompUnit(compunit) { - enter(current_frame(), compunit.block["static-lexpad"]); + enter(current_frame(), compunit.block.get("static-lexpad")); run(compunit.block.statementlist); leave(); }, @@ -234,7 +237,7 @@ my Runtime = { # no runtime behavior }, Q::Statement::Block(stmt) { - enter(current_frame(), stmt.block["static-lexpad"]); + enter(current_frame(), stmt.block.get("static-lexpad")); run(stmt.block.statementlist); leave(); }, @@ -245,7 +248,7 @@ my Runtime = { my array = eval(stmt.expr); for array -> arg { - enter(current_frame(), stmt.block["static-lexpad"]); + enter(current_frame(), stmt.block.get("static-lexpad")); my parameters = stmt.block.parameterlist.parameters; if parameters { declare_var(parameters[0].identifier, arg); @@ -257,7 +260,7 @@ my Runtime = { Q::Statement::If(stmt) { my expr = eval(stmt.expr); if expr { - enter(current_frame(), stmt.block["static-lexpad"]); + enter(current_frame(), stmt.block.get("static-lexpad")); my parameters = stmt.block.parameterlist.parameters; if parameters { declare_var(parameters[0].identifier, expr); @@ -281,7 +284,7 @@ my Runtime = { Q::Statement::While(stmt) { my expr; while expr = eval(stmt.expr) { - enter(current_frame(), stmt.block["static-lexpad"]); + enter(current_frame(), stmt.block.get("static-lexpad")); my parameters = stmt.block.parameterlist.parameters; if parameters { declare_var(parameters[0].identifier, expr); @@ -307,5 +310,5 @@ my Runtime = { } }; -my runtime = Runtime.new(); -runtime.run(ast); +my runtime = Runtime["new"](); +runtime["run"](ast); diff --git a/t/api-documentation/code-snippets.t b/t/api-documentation/code-snippets.t index 8d5d4882..2efd4585 100644 --- a/t/api-documentation/code-snippets.t +++ b/t/api-documentation/code-snippets.t @@ -5,7 +5,7 @@ use _007::Test; %*ENV = "1"; # so that we can parse class declarations in the documentation %*ENV = "1"; # so that we can parse regexes in the documentation -for -> $file { +for -> $file { my ($topic, @snippet-lines); my $line-number = 0; for $file.IO.lines -> $line { diff --git a/t/api-documentation/comments.t b/t/api-documentation/comments.t index d932f3b8..c9129635 100644 --- a/t/api-documentation/comments.t +++ b/t/api-documentation/comments.t @@ -1,13 +1,13 @@ use v6; use Test; -for -> $file { +for -> $file { # I am a state machine. Hello. my enum State ; my $state = Normal; for $file.IO.lines -> $line { - if $line ~~ /^ < class role > \h+ (Q | < Val:: Q:: > \S+)/ { + if $line ~~ /^ "TYPE<" (<-[>]>+) ">" \h* "=" \h* "_007::Type.new(" / { ok $state == ApiComment, "$0 is documented"; } diff --git a/t/code-style/do-not-create-val-none.t b/t/code-style/do-not-create-val-none.t index 02542166..e942ac09 100644 --- a/t/code-style/do-not-create-val-none.t +++ b/t/code-style/do-not-create-val-none.t @@ -7,11 +7,11 @@ my $files = find(".", /[".pm" | ".t"] $/)\ .join(" "); my @lines-with-val-none-new = - qqx[grep -Fwrin 'Val::NoneType.new' $files].lines\ - # exception: we store Val::NoneType.new once as a constant + qqx[grep -Fwrin '_007::Object.new(:type(TYPE)' $files].lines\ + # exception: we store _007::Object.new(:type(TYPE) once as a constant .grep({ $_ !~~ / ":constant NONE is export = " / }); is @lines-with-val-none-new.join("\n"), "", - "no unnecessary calls to Val::NoneType.new"; + "no unnecessary calls to _007::Object.new(:type(TYPE)"; done-testing; diff --git a/t/code-style/do-not-use-str-in-typecheck.t b/t/code-style/do-not-use-str-in-typecheck.t index bc68f91e..a39f0a76 100644 --- a/t/code-style/do-not-use-str-in-typecheck.t +++ b/t/code-style/do-not-use-str-in-typecheck.t @@ -7,7 +7,7 @@ my @failing-typechecks; my @files = find(".", /".pm" $/); for @files -> $file { given slurp($file.IO) -> $content { - for $content.comb(/"X::TypeCheck.new" <-[;]>+ ";"/) -> $typecheck { + for $content.comb(/"X::Type.new" <-[;]>+ ";"/) -> $typecheck { next unless $typecheck ~~ /":expected(" (<-[)]>+) ")"/; next unless $0 ~~ /^ '"'/; @failing-typechecks.push("\n(In $file):\n$typecheck"); @@ -15,6 +15,6 @@ for @files -> $file { } } -is @failing-typechecks.join("\n"), "", "No X::TypeCheck :expected uses a literal string"; +is @failing-typechecks.join("\n"), "", "No X::Type :expected uses a literal string"; done-testing; diff --git a/t/features/assignment.t b/t/features/assignment.t index 4531d308..a03784e6 100644 --- a/t/features/assignment.t +++ b/t/features/assignment.t @@ -27,7 +27,7 @@ use _007::Test; { my $ast = q:to/./; (statementlist - (my (identifier "o") (object (identifier "Object") (propertylist (property "foo" (int 42))))) + (my (identifier "o") (dict (propertylist (property "foo" (int 42))))) (stexpr (infix:= (postfix:[] (identifier "o") (str "bar")) (str "James"))) (stexpr (infix:= (postfix:. (identifier "o") (identifier "baz")) (str "Bond"))) (stexpr (postfix:() (identifier "say") (argumentlist (identifier "o"))))) @@ -35,7 +35,7 @@ use _007::Test; is-result $ast, "\{bar: \"James\", baz: \"Bond\", foo: 42\}\n", - "can assign to a property of an object (I)"; + "can assign to a property of a dict (I)"; } { @@ -47,7 +47,7 @@ use _007::Test; qq!\{bar: "James", baz: "Bond", foo: 42\}\n!, - "can assign to a property of an object (II)"; + "can assign to a property of a dict (II)"; } done-testing; diff --git a/t/features/builtins/methods.t b/t/features/builtins/methods.t index 05ebb657..0db74a87 100644 --- a/t/features/builtins/methods.t +++ b/t/features/builtins/methods.t @@ -78,10 +78,10 @@ use _007::Test; { my $ast = q:to/./; (statementlist - (stexpr (postfix:() (identifier "say") (argumentlist (postfix:() (postfix:. (object (identifier "Object") (propertylist)) (identifier "size")) (argumentlist)))))) + (stexpr (postfix:() (identifier "say") (argumentlist (postfix:() (postfix:. (dict (propertylist)) (identifier "size")) (argumentlist)))))) . - is-result $ast, "0\n", "size() works -- Object"; + is-result $ast, "0\n", "size() works -- Dict"; } { @@ -362,10 +362,10 @@ use _007::Test; { my $program = q:to/./; - say(Object.create([["foo", 42]])); + say(Dict.create([["value", { foo: 42 }]])); . - outputs $program, qq[\{foo: 42\}\n], "Type.create() method to create an Object"; + outputs $program, qq[\{foo: 42\}\n], "Type.create() method to create a Dict"; } { @@ -386,7 +386,7 @@ use _007::Test; { my $program = q:to/./; - say(Array.create([["elements", [0, 0, 7]]])); + say(Array.create([["value", [0, 0, 7]]])); . outputs $program, qq<[0, 0, 7]\n>, "Type.create() method to create an Array"; diff --git a/t/features/builtins/operators.t b/t/features/builtins/operators.t index 037f149b..27181e01 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -254,33 +254,33 @@ use _007::Test; { my $ast = q:to/./; (statementlist - (my (identifier "o1") (object (identifier "Object") (propertylist (property "x" (int 7))))) - (my (identifier "o2") (object (identifier "Object") (propertylist (property "x" (int 9))))) + (my (identifier "o1") (dict (propertylist (property "x" (int 7))))) + (my (identifier "o2") (dict (propertylist (property "x" (int 9))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:== (identifier "o1") (identifier "o1"))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:== (identifier "o1") (identifier "o2")))))) . - is-result $ast, "True\nFalse\n", "object equality"; + is-result $ast, "True\nFalse\n", "dict equality"; } { my $ast = q:to/./; (statementlist - (my (identifier "o1") (object (identifier "Object") (propertylist (property "x" (int 7))))) - (my (identifier "o2") (object (identifier "Object") (propertylist (property "x" (int 9))))) + (my (identifier "o1") (dict (propertylist (property "x" (int 7))))) + (my (identifier "o2") (dict (propertylist (property "x" (int 9))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:!= (identifier "o1") (identifier "o1"))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:!= (identifier "o1") (identifier "o2")))))) . - is-result $ast, "False\nTrue\n", "object inequality"; + is-result $ast, "False\nTrue\n", "dict inequality"; } { my $ast = q:to/./; (statementlist - (my (identifier "o3") (object (identifier "Object") (propertylist (property "x" (int 7))))) + (my (identifier "o3") (dict (propertylist (property "x" (int 7))))) (stexpr (infix:= (postfix:. (identifier "o3") (identifier "y")) (identifier "o3"))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:== (identifier "o3") (identifier "o3")))))) @@ -315,7 +315,7 @@ use _007::Test; (my (identifier "i1") (int 10)) (my (identifier "s1") (str "10")) (my (identifier "a1") (array (int 1) (int 2) (int 3))) - (my (identifier "o1") (object (identifier "Object") (propertylist (property "x" (int 7))))) + (my (identifier "o1") (dict (propertylist (property "x" (int 7))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:== (identifier "i1") (identifier "s1"))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:== (identifier "s1") (identifier "a1"))))) @@ -332,7 +332,7 @@ use _007::Test; (my (identifier "i1") (int 10)) (my (identifier "s1") (str "10")) (my (identifier "a1") (array (int 1) (int 2) (int 3))) - (my (identifier "o1") (object (identifier "Object") (propertylist (property "x" (int 7))))) + (my (identifier "o1") (dict (propertylist (property "x" (int 7))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:!= (identifier "i1") (identifier "s1"))))) (stexpr (postfix:() (identifier "say") (argumentlist (infix:!= (identifier "s1") (identifier "a1"))))) @@ -429,7 +429,7 @@ use _007::Test; (stexpr (postfix:() (identifier "say") (argumentlist (infix:+ (int 38) (str "4")))))) . - is-error $ast, X::TypeCheck, "adding non-ints is an error"; + is-error $ast, X::Type, "adding non-ints is an error"; } { @@ -438,7 +438,7 @@ use _007::Test; (stexpr (postfix:() (identifier "say") (argumentlist (infix:~ (int 38) (str "4")))))) . - is-error $ast, X::TypeCheck, "concatenating non-strs is an error"; + is-error $ast, X::Type, "concatenating non-strs is an error"; } { @@ -448,25 +448,28 @@ use _007::Test; (stexpr (postfix:() (identifier "say") (argumentlist (postfix:[] (identifier "ns") (int 0)))))) . - is-error $ast, X::TypeCheck, "indexing a non-array is an error"; + is-error $ast, X::Type, "indexing a non-array is an error"; } { my $program = q:to/./; my a = [1, 2, 3]; + my d = { foo: 12 }; sub f() { return 7 }; - my o = { foo: 12 }; + my o = new Q::Identifier { name: "19" }; say(-a[1]); + say(-d["foo"]); say(-f()); - say(-o.foo); + say(-o.name); say(!a[2]); + say(!d["foo"]); say(!f()); - say(!o.foo); + say(!o.name); . - outputs $program, "-2\n-7\n-12\nFalse\nFalse\nFalse\n", "all postfixes are tighter than both prefixes"; + outputs $program, "-2\n-12\n-7\n-19\nFalse\nFalse\nFalse\nFalse\n", "all postfixes are tighter than all prefixes"; } { @@ -593,7 +596,7 @@ use _007::Test; (stexpr (prefix:^ (str "Mr Bond")))) . - is-error $ast, X::TypeCheck, "can't upto a string (or other non-integer types)"; + is-error $ast, X::Type, "can't upto a string (or other non-integer types)"; } { @@ -617,7 +620,7 @@ use _007::Test; my q = 42; say(q ~~ Int) . - outputs $program, "True\n", "typecheck works for Val::Int"; + outputs $program, "True\n", "typecheck works for Int"; } { @@ -625,15 +628,15 @@ use _007::Test; my q = [4, 2]; say(q ~~ Array) . - outputs $program, "True\n", "typecheck works for Val::Array"; + outputs $program, "True\n", "typecheck works for Array"; } { my $program = q:to/./; - my q = {}; say(q ~~ Object) + my q = {}; say(q ~~ Dict) . - outputs $program, "True\n", "typecheck works for Val::Object"; + outputs $program, "True\n", "typecheck works for Dict"; } { @@ -642,9 +645,9 @@ use _007::Test; say(quasi @ Q::Infix { + } !~~ Q::Prefix); say(42 !~~ Int); say([4, 2] !~~ Array); - say({} !~~ Object); + say({} !~~ Dict); say(42 !~~ Array); - say([4, 2] !~~ Object); + say([4, 2] !~~ Dict); say({} !~~ Int); . diff --git a/t/features/dict.t b/t/features/dict.t new file mode 100644 index 00000000..13c0d1b9 --- /dev/null +++ b/t/features/dict.t @@ -0,0 +1,90 @@ +use v6; +use Test; +use _007::Test; + +{ + my @exprs = « + '{}' '(dict (propertylist))' + '{"a": 1}' '(dict (propertylist (property "a" (int 1))))' + '{"a": 1 + 2}' '(dict (propertylist (property "a" (infix:+ (int 1) (int 2)))))' + '{"a": 1,}' '(dict (propertylist (property "a" (int 1))))' + '{a}' '(dict (propertylist (property "a" (identifier "a"))))' + '{a : 1}' '(dict (propertylist (property "a" (int 1))))' + '{ a: 1}' '(dict (propertylist (property "a" (int 1))))' + '{a: 1 }' '(dict (propertylist (property "a" (int 1))))' + '{a: 1}' '(dict (propertylist (property "a" (int 1))))' + '{a: 1 + 2}' '(dict (propertylist (property "a" (infix:+ (int 1) (int 2)))))' + '{a() {}}' '(dict (propertylist + (property "a" (sub (identifier "a") (block (parameterlist) (statementlist))))))' + '{a(a, b) {}}' '(dict (propertylist (property "a" (sub (identifier "a") (block + (parameterlist (param (identifier "a")) (param (identifier "b"))) (statementlist))))))' + »; + + for @exprs -> $expr, $frag { + my $ast = qq[(statementlist (my (identifier "a")) (stexpr {$frag}))]; + + parses-to "my a; ($expr)", $ast, $expr; + } +} + +{ + my $ast = q:to/./; + (statementlist + (my (identifier "o") + (dict (propertylist (property "b" (int 7))))) + (stexpr (postfix:() (identifier "say") (argumentlist + (postfix:[] (identifier "o") (str "b")))))) + . + + is-result $ast, "7\n", "can access an object's property (brackets syntax)"; +} + +{ + my $ast = q:to/./; + (statementlist + (my (identifier "o") (dict (propertylist + (property "foo" (int 1)) + (property "foo" (int 2)))))) + . + + is-error + $ast, + X::Property::Duplicate, + "can't have duplicate properties (#85) (I)"; +} + +{ + my $program = q:to/./; + my o = { foo: 1, foo: 2 }; + . + + parse-error + $program, + X::Property::Duplicate, + "can't have duplicate properties (#85) (II)"; +} + +{ + my $ast = q:to/./; + (statementlist + (my (identifier "o") (dict (propertylist))) + (stexpr (postfix:[] (identifier "o") (str "b")))) + . + + is-error $ast, X::Property::NotFound, "can't access non-existing property (brackets syntax)"; +} + +{ + my $program = q:to/./; + f(); + my o = { say }; + sub f() { say("Mr. Bond") } + . + + outputs + $program, + qq[Mr. Bond\n], + "using the short-form property syntax doesn't accidentally introduce a scope (#150)"; +} + +done-testing; diff --git a/t/features/if-statement.t b/t/features/if-statement.t index 1fa1548d..81ab6801 100644 --- a/t/features/if-statement.t +++ b/t/features/if-statement.t @@ -26,17 +26,17 @@ use _007::Test; (macro (identifier "bar") (block (parameterlist) (statementlist))) (if (identifier "bar") (block (parameterlist) (statementlist (stexpr (postfix:() (identifier "say") (argumentlist (str "truthy macro"))))))) - (if (object (identifier "Object") (propertylist)) (block (parameterlist) (statementlist - (stexpr (postfix:() (identifier "say") (argumentlist (str "falsy object"))))))) - (if (object (identifier "Object") (propertylist (property "a" (int 3)))) (block (parameterlist) (statementlist - (stexpr (postfix:() (identifier "say") (argumentlist (str "truthy object"))))))) + (if (dict (propertylist)) (block (parameterlist) (statementlist + (stexpr (postfix:() (identifier "say") (argumentlist (str "falsy dict"))))))) + (if (dict (propertylist (property "a" (int 3)))) (block (parameterlist) (statementlist + (stexpr (postfix:() (identifier "say") (argumentlist (str "truthy dict"))))))) (if (object (identifier "Q::Literal::Int") (propertylist (property "value" (int 0)))) (block (parameterlist) (statementlist (stexpr (postfix:() (identifier "say") (argumentlist (str "truthy qnode")))))))) . is-result $ast, - .map({"truthy $_\n"}).join, + .map({"truthy $_\n"}).join, "if statements run truthy things"; } diff --git a/t/features/objects.t b/t/features/objects.t index 22cda14c..2106c8dd 100644 --- a/t/features/objects.t +++ b/t/features/objects.t @@ -2,132 +2,6 @@ use v6; use Test; use _007::Test; -{ - my @exprs = « - '{}' '(object (identifier "Object") (propertylist))' - '{"a": 1}' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{"a": 1 + 2}' '(object (identifier "Object") (propertylist (property "a" (infix:+ (int 1) (int 2)))))' - '{"a": 1,}' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{a}' '(object (identifier "Object") (propertylist (property "a" (identifier "a"))))' - '{a : 1}' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{ a: 1}' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{a: 1 }' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{a: 1}' '(object (identifier "Object") (propertylist (property "a" (int 1))))' - '{a: 1 + 2}' '(object (identifier "Object") (propertylist (property "a" (infix:+ (int 1) (int 2)))))' - '{a() {}}' '(object (identifier "Object") (propertylist - (property "a" (sub (identifier "a") (block (parameterlist) (statementlist))))))' - '{a(a, b) {}}' '(object (identifier "Object") (propertylist (property "a" (sub (identifier "a") (block - (parameterlist (param (identifier "a")) (param (identifier "b"))) (statementlist))))))' - »; - - for @exprs -> $expr, $frag { - my $ast = qq[(statementlist (my (identifier "a")) (stexpr {$frag}))]; - - parses-to "my a; ($expr)", $ast, $expr; - } -} - -{ - my $ast = q:to/./; - (statementlist - (my (identifier "o") - (object (identifier "Object") (propertylist (property "a" (int 1))))) - (stexpr (postfix:() (identifier "say") (argumentlist - (postfix:. (identifier "o") (identifier "a")))))) - . - - is-result $ast, "1\n", "can access an object's property (dot syntax)"; -} - -{ - my $ast = q:to/./; - (statementlist - (my (identifier "o") - (object (identifier "Object") (propertylist (property "b" (int 7))))) - (stexpr (postfix:() (identifier "say") (argumentlist - (postfix:[] (identifier "o") (str "b")))))) - . - - is-result $ast, "7\n", "can access an object's property (brackets syntax)"; -} - -{ - my $ast = q:to/./; - (statementlist - (my (identifier "o") (object (identifier "Object") (propertylist))) - (stexpr (postfix:. (identifier "o") (identifier "a")))) - . - - is-error $ast, X::Property::NotFound, "can't access non-existing property (dot syntax)"; -} - -{ - my $ast = q:to/./; - (statementlist - (stexpr (postfix:. (int 42) (identifier "a")))) - . - - is-error $ast, X::Property::NotFound, "can't access property on Val::Int (dot syntax)"; -} - -{ - my $ast = q:to/./; - (statementlist - (my (identifier "o") (object (identifier "Object") (propertylist - (property "foo" (int 1)) - (property "foo" (int 2)))))) - . - - is-error - $ast, - X::Property::Duplicate, - "can't have duplicate properties (#85) (I)"; -} - -{ - my $program = q:to/./; - my o = { foo: 1, foo: 2 }; - . - - parse-error - $program, - X::Property::Duplicate, - "can't have duplicate properties (#85) (II)"; -} - -{ - my $ast = q:to/./; - (statementlist - (my (identifier "o") (object (identifier "Object") (propertylist))) - (stexpr (postfix:[] (identifier "o") (str "b")))) - . - - is-error $ast, X::Property::NotFound, "can't access non-existing property (brackets syntax)"; -} - -{ - my $program = q:to/./; - my o = { james: "bond", bond: 7 }; - - say(o.has("bond")); - say(o.has("jimmy")); - - say(o.get("bond")); - - say(o.update({ bond: 8 })); - - say({ x: 1 }.extend({ y: 2 })); - - my n = o.id; - say("id"); - . - - outputs - $program, - qq[True\nFalse\n7\n\{bond: 8, james: "bond"\}\n\{x: 1, y: 2\}\nid\n], - "built-in pseudo-inherited methods on objects"; -} - { my $program = q:to/./; my q = new Q::Identifier { name: "foo" }; @@ -165,24 +39,11 @@ use _007::Test; "an object literal is of the declared type"; } -{ - my $program = q:to/./; - my q = new Object { foo: 42 }; - - say(q.foo); - . - - outputs - $program, - qq[42\n], - "can create a Val::Object by explicitly naming 'Object'"; -} - { my $program = q:to/./; my i = new Int { value: 7 }; my s = new Str { value: "Bond" }; - my a = new Array { elements: [0, 0, 7] }; + my a = new Array { value: [0, 0, 7] }; say(i == 7); say(s == "Bond"); @@ -192,7 +53,7 @@ use _007::Test; outputs $program, qq[True\nTrue\nTrue\n], - "can create normal Val:: objects using typed object literals"; + "can create normal objects using typed object literals"; } { @@ -206,36 +67,4 @@ use _007::Test; "need to specify required properties on objects (#87)"; } -{ - my $program = q:to/./; - my obj = { - meth() { - return 007; - } - }; - . - - my $ast = q:to/./; - (statementlist - (my (identifier "obj") (object (identifier "Object") (propertylist - (property "meth" (sub (identifier "meth") (block (parameterlist) (statementlist - (return (int 7)))))))))) - . - - parses-to $program, $ast, "a `return` inside of a (short-form) method is fine"; -} - -{ - my $program = q:to/./; - f(); - my o = { say }; - sub f() { say("Mr. Bond") } - . - - outputs - $program, - qq[Mr. Bond\n], - "using the short-form property syntax doesn't accidentally introduce a scope (#150)"; -} - done-testing; diff --git a/t/features/q.t b/t/features/q.t index e4995629..f3ce23b3 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -4,7 +4,9 @@ use _007::Test; { my $program = q:to/./; - my q = new Q::Statement::My { identifier: new Q::Identifier { name: "foo" } }; + my q = new Q::Statement::My { + identifier: new Q::Identifier { name: "foo" }, + }; say(q.expr); . @@ -36,8 +38,10 @@ use _007::Test; }, statementlist: new Q::StatementList { statements: [] - } - } + }, + # XXX: can remove this later + "static-lexpad": {}, + }, }; say(q.else); . @@ -54,8 +58,12 @@ use _007::Test; identifier: new Q::Identifier { name: "foo" }, block: new Q::Block { parameterlist: new Q::ParameterList { parameters: [] }, - statementlist: new Q::StatementList { statements: [] } - } + statementlist: new Q::StatementList { statements: [] }, + # XXX: can remove this later + "static-lexpad": {}, + }, + # XXX: and this + traitlist: new Q::TraitList { traits: [] }, }; say(q.traitlist); . @@ -72,8 +80,12 @@ use _007::Test; identifier: new Q::Identifier { name: "moo" }, block: new Q::Block { parameterlist: new Q::ParameterList { parameters: [] }, - statementlist: new Q::StatementList { statements: [] } - } + statementlist: new Q::StatementList { statements: [] }, + # XXX: can remove this later + "static-lexpad": {}, + }, + # XXX: and this + traitlist: new Q::TraitList { traits: [] }, }; say(q.traitlist); . diff --git a/t/features/quasi.t b/t/features/quasi.t index 137197db..148af652 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -1,5 +1,7 @@ use v6; use Test; +use _007; +use _007::Object; use _007::Test; { @@ -7,9 +9,10 @@ use _007::Test; say(quasi { 1 + 1 }); . - my $expected = read( + # XXX: surely there's a better way to do this? + my $expected = bound-method(read( "(statementlist (stexpr (infix:+ (int 1) (int 1))))" - ).block.statementlist.statements.elements[0].expr.Str; + ).properties.properties.properties.value[0].properties, "Str", _007.runtime)().value; outputs $program, "$expected\n", "Basic quasi quoting"; } @@ -208,14 +211,14 @@ use _007::Test; say(type(quasi @ Q::Term { None })); say(type(quasi @ Q::Term { "James Bond" })); say(type(quasi @ Q::Term { [0, 0, 7] })); - say(type(quasi @ Q::Term { new Object { james: "Bond" } })); + say(type(quasi @ Q::Term { { james: "Bond" } })); say(type(quasi @ Q::Term { quasi { say("oh, james!") } })); say(type(quasi @ Q::Term { (0 + 0 + 7) })); . outputs $program, \ .map({ "\n" }).join, "quasi @ Q::Term"; @@ -231,12 +234,20 @@ use _007::Test; { my $program = q:to/./; - say(type(quasi @ Q::Term::Object { new Object { james: "Bond" } })); + say(type(quasi @ Q::Term::Object { new Object { } })); . outputs $program, "\n", "quasi @ Q::Term::Object"; } +{ + my $program = q:to/./; + say(type(quasi @ Q::Term::Dict { { } })); + . + + outputs $program, "\n", "quasi @ Q::Term::Dict"; +} + { my $program = q:to/./; say(type(quasi @ Q::Term::Quasi { quasi { say("oh, james!") } })); diff --git a/t/features/stringification.t b/t/features/stringification.t index 503fc1d5..a0de6aee 100644 --- a/t/features/stringification.t +++ b/t/features/stringification.t @@ -18,7 +18,7 @@ use _007::Test; { outputs 'my foo = [0, 0, 7]; foo[2] = foo; say(foo)', "[0, 0, [...]]\n", "array with reference to itself"; - outputs 'my foo = {}; foo.x = foo; say(foo)', "\{x: \{...\}\}\n", "object with reference to itself"; + outputs 'my foo = {}; foo.x = foo; say(foo)', "\{x: \{...\}\}\n", "dict with reference to itself"; } done-testing; diff --git a/t/features/unhygienic-declarations.t b/t/features/unhygienic-declarations.t index 06de2f8e..0df47c31 100644 --- a/t/features/unhygienic-declarations.t +++ b/t/features/unhygienic-declarations.t @@ -6,9 +6,7 @@ use _007::Test; my $program = q:to/./; macro moo() { return new Q::Statement::My { - identifier: new Q::Identifier { - name: "agent_name" - }, + identifier: new Q::Identifier { name: "agent_name" }, expr: new Q::Literal::Str { value: "James Bond" } diff --git a/t/features/unquote.t b/t/features/unquote.t index 58c153fc..1416accd 100644 --- a/t/features/unquote.t +++ b/t/features/unquote.t @@ -58,7 +58,7 @@ use _007::Test; . parse-error $program, - X::TypeCheck, + X::Type, "can't put a non-infix in a Q::Infix @ unquote"; } @@ -73,7 +73,7 @@ use _007::Test; . parse-error $program, - X::TypeCheck, + X::Type, "can't put a non-infix unquote in infix operator position (explicit)"; } @@ -88,7 +88,7 @@ use _007::Test; . parse-error $program, - X::TypeCheck, + X::Type, "can't put a non-infix unquote in infix operator position (implicit)"; } @@ -116,7 +116,7 @@ use _007::Test; . parse-error $program, - X::TypeCheck, + X::Type, "can't put a non-prefix in a Q::Prefix @ unquote"; } diff --git a/t/integration/count-builtins.t b/t/integration/count-builtins.t new file mode 100644 index 00000000..f4eadebf --- /dev/null +++ b/t/integration/count-builtins.t @@ -0,0 +1,13 @@ +use v6; +use Test; +use _007::Test; + +my $output = qx[perl6 bin/count-builtins]; + +for $output.lines { + if /^ (<-[:]>+) ":" \h* (\d+) $ / { + ok +$1 > 0, "have $1 {$0.lc}"; + } +} + +done-testing; diff --git a/t/integration/finishblock.t b/t/integration/finishblock.t index 552d162a..7baae09c 100644 --- a/t/integration/finishblock.t +++ b/t/integration/finishblock.t @@ -12,7 +12,7 @@ for "lib/_007/Parser/Actions.pm".IO.lines -> $line { } if $interested { - if $line ~~ /"Q::Block.new("/ { + if $line ~~ /"create(TYPE"/ { $blocks-minus-finishblocks++; } if $line ~~ /"self.finish-block("/ { diff --git a/t/self-host/sanity.t b/t/self-host/sanity.t index 813a6aea..a0e6e1d1 100644 --- a/t/self-host/sanity.t +++ b/t/self-host/sanity.t @@ -14,7 +14,7 @@ sub run_007_on_007($program) { my $output = StrOutput.new; my $runtime = _007.runtime(:$output); my $ast = _007.parser(:$runtime).parse($runtime-program); - $ast.block.static-lexpad.properties = $compunit; + $ast.properties.properties.value = $compunit; $runtime.run($ast); return $output.result; } diff --git a/tutorial/README.md b/tutorial/README.md index b8f568a6..a34d626b 100644 --- a/tutorial/README.md +++ b/tutorial/README.md @@ -249,10 +249,9 @@ The following built-in types have methods associated with them: ## Q objects -All the different Q types can be created by specifying the type before an -object term: +All the different Q types can be created with an object term: - my q = Q::Statement::My { + my q = new Q::Statement::My { identifier: Q::Identifier { name: "name" }, expr: Q::Literal::Str { value: "Bond" } };