From a46a97426ca32cd20d2571192167bd9f4b34270a Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 19 Aug 2017 06:38:13 +0200 Subject: [PATCH 01/91] asset-capture Val::Int --- lib/_007/Builtins.pm | 114 ++++++++++++++++++++++--------------- lib/_007/Parser/Actions.pm | 13 ++++- lib/_007/Parser/Syntax.pm | 2 +- lib/_007/Q.pm | 15 ++++- lib/_007/Runtime.pm | 30 ++++++---- lib/_007/Test.pm | 2 +- lib/_007/Val.pm | 40 ++++++++++++- 7 files changed, 149 insertions(+), 67 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index e7dc4cf1..2db52d7e 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -3,10 +3,10 @@ use _007::Q; sub builtins(:$input!, :$output!, :$opscope!) is export { sub wrap($_) { + when _007::Object { $_ } 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 } @@ -14,9 +14,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } + multi equal-value(_007::Type, _007::Type) { True } 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(_007::Object $l, _007::Object $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} { @@ -67,17 +68,17 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { die X::TypeCheck.new( :operation, :got($_), - :expected(Val::Int)); + :expected(_007::Object)); } - multi less-value(Val::Int $l, Val::Int $r) { $l.value < $r.value } + multi less-value(_007::Object $l, _007::Object $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( :operation, :got($_), - :expected(Val::Int)); + :expected(_007::Object)); } - multi more-value(Val::Int $l, Val::Int $r) { $l.value > $r.value } + multi more-value(_007::Object $l, _007::Object $r) { $l.value > $r.value } multi more-value(Val::Str $l, Val::Str $r) { $l.value ge $r.value } my role Placeholder { @@ -108,7 +109,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { $output.flush(); return wrap($input.get()); }, - type => -> $arg { Val::Type.of($arg.WHAT) }, + type => sub ($arg) { + $arg ~~ _007::Type + ?? TYPE_TYPE + !! $arg ~~ _007::Object + ?? $arg.type + !! Val::Type.of($arg.WHAT); + }, # OPERATORS (from loosest to tightest within each category) @@ -180,9 +187,17 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:~~' => op( sub ($lhs, $rhs) { + if $rhs ~~ _007::Type { + return wrap($lhs ~~ _007::Object); + } + die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type; + if $lhs ~~ _007::Object && $rhs.type === Val::Int { + return True; + } + return wrap($lhs ~~ $rhs.type); }, :qtype(Q::Infix::TypeMatch), @@ -190,8 +205,12 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:!~~' => op( sub ($lhs, $rhs) { + if $rhs ~~ _007::Type { + return wrap($lhs !~~ _007::Object); + } + die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) - unless $rhs ~~ Val::Type; + unless $rhs ~~ Val::Type | _007::Type; return wrap($lhs !~~ $rhs.type); }, @@ -213,11 +232,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # 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; - return wrap($lhs.value + $rhs.value); + die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object; + die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; + return sevenize($lhs.value + $rhs.value); }, :qtype(Q::Infix::Addition), ), @@ -234,11 +253,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), '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; - return wrap($lhs.value - $rhs.value); + die X::TypeCheck.new(:operation<->, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object; + die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; + return sevenize($lhs.value - $rhs.value); }, :qtype(Q::Infix::Subtraction), ), @@ -246,32 +265,32 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # 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; - return wrap($lhs.value * $rhs.value); + die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object; + die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; + return sevenize($lhs.value * $rhs.value); }, :qtype(Q::Infix::Multiplication), ), '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::TypeCheck.new(:operation<%>, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object; + die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; - return wrap($lhs.value % $rhs.value); + return sevenize($lhs.value % $rhs.value); }, :qtype(Q::Infix::Modulo), ), '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::TypeCheck.new(:operation<%%>, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object; + die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); @@ -282,8 +301,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; return wrap($lhs.value x $rhs.value); }, :qtype(Q::Infix::Replicate), @@ -293,8 +312,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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; + die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object; return wrap(| $lhs.elements xx $rhs.value); }, :qtype(Q::Infix::ArrayReplicate), @@ -311,34 +330,34 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:+' => op( sub prefix-plus($_) { when Val::Str { - return wrap(.value.Int) + return sevenize(.value.Int) if .value ~~ /^ '-'? \d+ $/; proceed; } - when Val::Int { + when _007::Object { return $_; } die X::TypeCheck.new( :operation("prefix:<+>"), :got($_), - :expected(Val::Int)); + :expected(_007::Object)); }, :qtype(Q::Prefix::Plus), ), 'prefix:-' => op( sub prefix-minus($_) { when Val::Str { - return wrap(-.value.Int) + return sevenize(-.value.Int) if .value ~~ /^ '-'? \d+ $/; proceed; } - when Val::Int { - return wrap(-.value); + when _007::Object { + return sevenize(-.value); } die X::TypeCheck.new( :operation("prefix:<->"), :got($_), - :expected(Val::Int)); + :expected(_007::Object)); }, :qtype(Q::Prefix::Minus), ), @@ -356,9 +375,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:^' => op( sub ($n) { - die X::TypeCheck.new(:operation<^>, :got($n), :expected(Val::Int)) - unless $n ~~ Val::Int; - return wrap([^$n.value]); + die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) + unless $n ~~ _007::Object; + return wrap([(^$n.value).map(&sevenize)]); }, :qtype(Q::Prefix::Upto), ), @@ -385,6 +404,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { tree-walk(Val::); tree-walk(Q::); push @builtins, "Q" => Val::Type.of(Q); + push @builtins, ("Int" => TYPE_INT); sub install-op($name, $placeholder) { $name ~~ /^ (prefix | infix | postfix) ':' (.+) $/ @@ -401,7 +421,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(Val::Str.new(:$^value))))) }; return @builtins.map: { - when .value ~~ Val::Type { + when .value ~~ _007::Type | Val::Type { .key => .value; } when .value ~~ Block { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 8e8d87f9..77a7e237 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -537,7 +537,7 @@ class _007::Parser::Actions { } method term:int ($/) { - make Q::Literal::Int.new(:value(Val::Int.new(:value(+$/)))); + make Q::Literal::Int.new(:value(sevenize(+$/))); } method term:str ($/) { @@ -656,9 +656,16 @@ class _007::Parser::Actions { method term:new-object ($/) { my $type = $.ast.name.value; - my $type-obj = $*runtime.get-var($type).type; + my $type-var = $*runtime.get-var($type); + my $type-obj = $type-var ~~ _007::Type + ?? $type-var + !! $type-var.type; - if $type-obj !=== Val::Object { + if $type-obj ~~ _007::Type { + # XXX: need to figure out how to do the corresponding error handling here + # something with .fields, most likely? + } + elsif $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 { diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index f08ce1d9..1e0bd3a1 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -219,7 +219,7 @@ grammar _007::Parser::Syntax { } token term:new-object { new» <.ws> - ) ~~ Val::Type }> <.ws> + ) ~~ Val::Type | _007::Type }> <.ws> '{' ~ '}' } token term:object { diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 353a75f3..bd8bc4d1 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -137,7 +137,7 @@ class Q::Literal::Bool does Q::Literal { ### like `-5` is parsed as a `prefix:<->` containing a literal `5`. ### class Q::Literal::Int does Q::Literal { - has Val::Int $.value; + has _007::Object $.value; method eval($) { $.value } } @@ -209,6 +209,12 @@ class Q::Term::Object does Q::Term { has $.propertylist; method eval($runtime) { + my $type = $runtime.get-var($.type.name.value, $.type.frame); + if $type ~~ _007::Type { + my $value = $.propertylist.properties.elements[0].value.eval($runtime); + # XXX: cheat less + return $value; + } return $runtime.get-var($.type.name.value, $.type.frame).create( $.propertylist.properties.elements.map({.key.value => .value.eval($runtime)}) ); @@ -580,7 +586,7 @@ class Q::Postfix::Index is Q::Postfix { when Val::Array { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - if $index !~~ Val::Int; + if $index !~~ _007::Object; die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) if $index.value >= .elements; die X::Subscript::Negative.new(:$index, :type([])) @@ -603,7 +609,7 @@ class Q::Postfix::Index is Q::Postfix { when Val::Array { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - if $index !~~ Val::Int; + if $index !~~ _007::Object; die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) if $index.value >= .elements; die X::Subscript::Negative.new(:$index, :type([])) @@ -717,6 +723,9 @@ class Q::Term::Quasi does Q::Term { method eval($runtime) { sub interpolate($thing) { + return $thing + if $thing ~~ _007::Object; # XXX: won't hold true for everything + return $thing.new(:elements($thing.elements.map(&interpolate))) if $thing ~~ Val::Array; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index a07c5a5f..5f66fcd8 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -231,24 +231,24 @@ class _007::Runtime { return $obj."$propname"(); } - elsif $obj ~~ Val::Int && $propname eq "abs" { + elsif $obj ~~ _007::Object && $propname eq "abs" { return builtin(sub abs() { - return Val::Int.new(:value($obj.value.abs)); + return sevenize($obj.value.abs); }); } - elsif $obj ~~ Val::Int && $propname eq "chr" { + elsif $obj ~~ _007::Object && $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)); + return sevenize($obj.value.ord); }); } elsif $obj ~~ Val::Str && $propname eq "chars" { return builtin(sub chars() { - return Val::Int.new(:value($obj.value.chars)); + return sevenize($obj.value.chars); }); } elsif $obj ~~ Val::Str && $propname eq "uc" { @@ -268,7 +268,7 @@ class _007::Runtime { } elsif $obj ~~ Val::Array && $propname eq "size" { return builtin(sub size() { - return Val::Int.new(:value($obj.elements.elems)); + return sevenize($obj.elements.elems); }); } elsif $obj ~~ Val::Array && $propname eq "reverse" { @@ -300,7 +300,7 @@ class _007::Runtime { } elsif $obj ~~ Val::Object && $propname eq "size" { return builtin(sub size() { - return Val::Int.new(:value($obj.properties.elems)); + return sevenize($obj.properties.elems); }); } elsif $obj ~~ Val::Str && $propname eq "split" { @@ -311,7 +311,7 @@ class _007::Runtime { } elsif $obj ~~ Val::Str && $propname eq "index" { return builtin(sub index($substr) { - return Val::Int.new(:value($obj.value.index($substr.value) // -1)); + return sevenize($obj.value.index($substr.value) // -1); }); } elsif $obj ~~ Val::Str && $propname eq "substr" { @@ -326,7 +326,7 @@ class _007::Runtime { die X::TypeCheck.new(:operation, :got($substr), :expected(Val::Str)) unless $substr ~~ Val::Str; - return Val::Int.new(:value( + return Val::Bool.new(:value( $obj.value.contains($substr.value); )); }); @@ -412,9 +412,17 @@ class _007::Runtime { return NONE; }); } - elsif $obj ~~ Val::Type && $propname eq "name" { + elsif $obj ~~ _007::Type && $propname eq "name" { return Val::Str.new(:value($obj.name)); } + elsif $obj ~~ Val::Type | _007::Type && $propname eq "name" { + return Val::Str.new(:value($obj.name)); + } + elsif $obj ~~ _007::Type && $propname eq "create" { + return builtin(sub create($properties) { + _007::Object.new(:value($properties.elements[0].elements[1].value)); + }); + } elsif $obj ~~ Val::Type && $propname eq "create" { return builtin(sub create($properties) { $obj.create($properties.elements.map({ .elements[0].value => .elements[1] })); @@ -466,7 +474,7 @@ class _007::Runtime { } elsif $propname eq "id" { # XXX: Make this work for Q-type objects, too. - return Val::Int.new(:value($obj.id)); + return sevenize($obj.id); } else { die X::Property::NotFound.new(:$propname, :$type); diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 90e4d6a4..2d6afb96 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -122,7 +122,7 @@ sub read(Str $ast) is export { make $qtype.new(|%arguments); } method expr:symbol ($/) { make ~$/ } - method expr:int ($/) { make Val::Int.new(:value(+$/)) } + method expr:int ($/) { make sevenize(+$/) } method expr:str ($/) { make Val::Str.new(:value((~$0).subst(q[\\"], q["], :g))) } }; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 94bbd5be..47a10df8 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -8,6 +8,35 @@ class X::Uninstantiable is Exception { class Helper { ... } +class _007::Type { + has $.name; + + method quoted-Str { self.Str } + method Str { + my %*stringification-seen; + Helper::Str(self); + } +} + +constant TYPE_TYPE = _007::Type.new(:name("Type")); +constant TYPE_INT = _007::Type.new(:name("Int")); + +class _007::Object { + has $.type; + has $.value; + + method attributes { () } + + method truthy { ?$.value } + + method quoted-Str { self.Str } + method Str { ~($.value // "EMPTY") } +} + +sub sevenize($value) is export { + _007::Object.new(:type(TYPE_INT), :$value); +} + role Val { method truthy { True } method attributes { self.^attributes } @@ -145,6 +174,10 @@ class Val::Bool does Val { class Val::Int does Val { has Int $.value; + submethod BUILD(:$value) { + die "Not supposed to use this class anymore"; + } + method truthy { ?$.value; } @@ -460,7 +493,10 @@ class Val::Type does Val { if $.type ~~ Val::Object { return $.type.new(:@properties); } - elsif $.type ~~ Val::Int | Val::Str { + elsif $.type ~~ _007::Object { + return $.type.new(:value(@properties[0].value.value)); + } + elsif $.type ~~ Val::Str { return $.type.new(:value(@properties[0].value.value)); } elsif $.type ~~ Val::Array { @@ -572,6 +608,8 @@ class Helper { when Val::Array { .quoted-Str } when Val::Object { .quoted-Str } when Val::Type { "" } + when _007::Type { "" } + when _007::Object { .value.Str } # XXX: wrong in the general case when Val::Macro { "" } when Val::Sub { "" } when Val::Exception { "Exception \{message: {.message.quoted-Str}\}" } From 885f903a6c284fb448e0f8a270d71518f564adaa Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 19 Aug 2017 07:31:17 +0200 Subject: [PATCH 02/91] remove Val::Int --- lib/_007/Builtins.pm | 4 ---- lib/_007/Val.pm | 39 --------------------------------------- 2 files changed, 43 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 2db52d7e..74bffab5 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -194,10 +194,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type; - if $lhs ~~ _007::Object && $rhs.type === Val::Int { - return True; - } - return wrap($lhs ~~ $rhs.type); }, :qtype(Q::Infix::TypeMatch), diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 47a10df8..8dbe774a 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -145,44 +145,6 @@ class Val::Bool does Val { } } -### ### 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; - - submethod BUILD(:$value) { - die "Not supposed to use this class anymore"; - } - - method truthy { - ?$.value; - } -} - ### ### Str ### ### A piece of text. Strings are frequent whenever a program does text-based @@ -602,7 +564,6 @@ 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 } From e53099cb98d4db09e3e5d1e42917486959d03c62 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 19 Aug 2017 08:21:38 +0200 Subject: [PATCH 03/91] Turn TYPE into a hash --- lib/_007/Builtins.pm | 4 ++-- lib/_007/Val.pm | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 74bffab5..df228b51 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -111,7 +111,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { }, type => sub ($arg) { $arg ~~ _007::Type - ?? TYPE_TYPE + ?? TYPE !! $arg ~~ _007::Object ?? $arg.type !! Val::Type.of($arg.WHAT); @@ -400,7 +400,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { tree-walk(Val::); tree-walk(Q::); push @builtins, "Q" => Val::Type.of(Q); - push @builtins, ("Int" => TYPE_INT); + push @builtins, ("Int" => TYPE); sub install-op($name, $placeholder) { $name ~~ /^ (prefix | infix | postfix) ':' (.+) $/ diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 8dbe774a..86b158a9 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -18,8 +18,9 @@ class _007::Type { } } -constant TYPE_TYPE = _007::Type.new(:name("Type")); -constant TYPE_INT = _007::Type.new(:name("Int")); +constant TYPE = {}; +TYPE = _007::Type.new(:name("Type")); +TYPE = _007::Type.new(:name("Int")); class _007::Object { has $.type; @@ -34,7 +35,7 @@ class _007::Object { } sub sevenize($value) is export { - _007::Object.new(:type(TYPE_INT), :$value); + _007::Object.new(:type(TYPE), :$value); } role Val { From 2fc4d1deac0dc9d642ed17c83fbcea3f4c07f197 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 19 Aug 2017 16:39:50 +0200 Subject: [PATCH 04/91] asset-capture Val::Str --- lib/_007/Builtins.pm | 133 ++++++++++++++++++++++--------------- lib/_007/OpScope.pm | 2 +- lib/_007/Parser/Actions.pm | 20 +++--- lib/_007/Parser/Syntax.pm | 5 +- lib/_007/Q.pm | 16 ++--- lib/_007/Runtime.pm | 78 +++++++++++----------- lib/_007/Test.pm | 8 ++- lib/_007/Val.pm | 33 ++++++--- 8 files changed, 165 insertions(+), 130 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index df228b51..2ead368f 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -7,18 +7,25 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { when Val | Q { $_ } when Nil { NONE } when Bool { Val::Bool.new(:value($_)) } - when Str { Val::Str.new(:value($_)) } + when Str { die "A Str was sent to &wrap" } when Array | Seq | List { Val::Array.new(:elements(.map(&wrap))) } default { die "Got some unknown value of type ", .^name } } # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } - multi equal-value(_007::Type, _007::Type) { True } multi equal-value(Val::NoneType, Val::NoneType) { True } multi equal-value(Val::Bool $l, Val::Bool $r) { $l.value == $r.value } - multi equal-value(_007::Object $l, _007::Object $r) { $l.value == $r.value } - multi equal-value(Val::Str $l, Val::Str $r) { $l.value eq $r.value } + multi equal-value(_007::Object $l, _007::Object $r) { + return False + unless $l.type === $r.type; + my $type = $l.type; + return $type === TYPE + ?? $l.value == $r.value + !! $type === TYPE + ?? $l.value eq $r.value + !! die "Unknown type ", $type.Str; + } multi equal-value(Val::Array $l, Val::Array $r) { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { return $l === $r; @@ -47,6 +54,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { [&&] $l.properties.keys.sort.perl eq $r.properties.keys.sort.perl, |($l.properties.keys).map(&equal-at-key); } + multi equal-value(_007::Type $l, _007::Type $r) { $l === $r } multi equal-value(Val::Type $l, Val::Type $r) { $l.type === $r.type } @@ -70,16 +78,32 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { :got($_), :expected(_007::Object)); } - multi less-value(_007::Object $l, _007::Object $r) { $l.value < $r.value } - multi less-value(Val::Str $l, Val::Str $r) { $l.value le $r.value } + multi less-value(_007::Object $l, _007::Object $r) { + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) + unless $l.type === $r.type; + my $type = $l.type; + return $type === TYPE + ?? $l.value < $r.value + !! $type === TYPE + ?? $l.value lt $r.value + !! die "Unknown type ", $type.Str; + } multi more-value($, $) { die X::TypeCheck.new( :operation, :got($_), :expected(_007::Object)); } - multi more-value(_007::Object $l, _007::Object $r) { $l.value > $r.value } - multi more-value(Val::Str $l, Val::Str $r) { $l.value ge $r.value } + multi more-value(_007::Object $l, _007::Object $r) { + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) + unless $l.type === $r.type; + my $type = $l.type; + return $type === TYPE + ?? $l.value > $r.value + !! $type === TYPE + ?? $l.value gt $r.value + !! die "Unknown type ", $type.Str; + } my role Placeholder { has $.qtype; @@ -107,7 +131,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { prompt => sub ($arg) { $output.print($arg); $output.flush(); - return wrap($input.get()); + return sevenize($input.get()); }, type => sub ($arg) { $arg ~~ _007::Type @@ -188,7 +212,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs ~~ _007::Object); + return wrap($lhs ~~ _007::Object && $lhs.type === $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) @@ -202,7 +226,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:!~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs !~~ _007::Object); + return wrap($lhs !~~ _007::Object || $lhs.type !=== $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) @@ -229,20 +253,20 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:+' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object; + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; return sevenize($lhs.value + $rhs.value); }, :qtype(Q::Infix::Addition), ), '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; - return wrap($lhs.value ~ $rhs.value); + die X::TypeCheck.new(:operation<~>, :got($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object && $lhs.type === TYPE; + die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object && $rhs.type === TYPE; + return sevenize($lhs.value ~ $rhs.value); }, :qtype(Q::Infix::Concat), :precedence{ equal => "infix:+" }, @@ -250,9 +274,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:-' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<->, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object; + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; return sevenize($lhs.value - $rhs.value); }, :qtype(Q::Infix::Subtraction), @@ -262,9 +286,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:*' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object; + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; return sevenize($lhs.value * $rhs.value); }, :qtype(Q::Infix::Multiplication), @@ -272,9 +296,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object; + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; return sevenize($lhs.value % $rhs.value); @@ -284,9 +308,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object; + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); @@ -295,11 +319,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), '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($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; - return wrap($lhs.value x $rhs.value); + unless $rhs ~~ _007::Object && $rhs.type === TYPE; + return sevenize($lhs.value x $rhs.value); }, :qtype(Q::Infix::Replicate), :precedence{ equal => "infix:*" }, @@ -309,7 +333,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { die X::TypeCheck.new(:operation, :got($lhs), :expected(Val::Array)) unless $lhs ~~ Val::Array; die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object; + unless $rhs ~~ _007::Object && $rhs.type === TYPE; return wrap(| $lhs.elements xx $rhs.value); }, :qtype(Q::Infix::ArrayReplicate), @@ -318,41 +342,41 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # prefixes 'prefix:~' => op( - sub prefix-str($expr) { - Val::Str.new(:value($expr.Str)); - }, + sub prefix-str($expr) { sevenize($expr.Str) }, :qtype(Q::Prefix::Str), ), 'prefix:+' => op( - sub prefix-plus($_) { - when Val::Str { - return sevenize(.value.Int) - if .value ~~ /^ '-'? \d+ $/; - proceed; - } - when _007::Object { - return $_; + sub prefix-plus($expr) { + if $expr ~~ _007::Object { + if $expr.type === TYPE { + return sevenize($expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; + } + elsif $expr.type === TYPE { + return $expr; + } } die X::TypeCheck.new( :operation("prefix:<+>"), - :got($_), + :got($expr), :expected(_007::Object)); }, :qtype(Q::Prefix::Plus), ), 'prefix:-' => op( - sub prefix-minus($_) { - when Val::Str { - return sevenize(-.value.Int) - if .value ~~ /^ '-'? \d+ $/; - proceed; - } - when _007::Object { - return sevenize(-.value); + sub prefix-minus($expr) { + if $expr ~~ _007::Object { + if $expr.type === TYPE { + return sevenize(-$expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; + } + elsif $expr.type === TYPE { + return sevenize(-$expr.value); + } } die X::TypeCheck.new( :operation("prefix:<->"), - :got($_), + :got($expr), :expected(_007::Object)); }, :qtype(Q::Prefix::Minus), @@ -372,7 +396,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:^' => op( sub ($n) { die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) - unless $n ~~ _007::Object; + unless $n ~~ _007::Object && $n.type === TYPE; return wrap([(^$n.value).map(&sevenize)]); }, :qtype(Q::Prefix::Upto), @@ -401,6 +425,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { tree-walk(Q::); push @builtins, "Q" => Val::Type.of(Q); push @builtins, ("Int" => TYPE); + push @builtins, ("Str" => TYPE); sub install-op($name, $placeholder) { $name ~~ /^ (prefix | infix | postfix) ':' (.+) $/ @@ -414,7 +439,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(Val::Str.new(:$^value))))) }; + my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(sevenize($^value))))) }; return @builtins.map: { when .value ~~ _007::Type | Val::Type { diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 45dba72a..18787288 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -15,7 +15,7 @@ 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 = Q::Identifier.new(:name(sevenize($name))); %!ops{$type}{$op} = $q !=== Any ?? $q !! { prefix => Q::Prefix.new(:$identifier), diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 77a7e237..03870b02 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -119,7 +119,7 @@ class _007::Parser::Actions { # 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:()"))))), + :identifier(Q::Identifier.new(:name(sevenize("postfix:()")))), :operand(Q::Term::Sub.new(:identifier(NONE), :block($.ast))), :argumentlist(Q::ArgumentList.new) ))); @@ -504,7 +504,7 @@ class _007::Parser::Actions { method prefix($/) { my $op = ~$/; my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("prefix:$op"))), + :name(sevenize("prefix:$op")), :frame($*runtime.current-frame), ); make $*parser.opscope.ops{$op}.new(:$identifier, :operand(Val::NoneType)); @@ -519,8 +519,7 @@ 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); + my $value = sevenize((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); make Q::Literal::Str.new(:$value); } @@ -576,7 +575,7 @@ class _007::Parser::Actions { } method term:quasi ($/) { - my $qtype = Val::Str.new(:value(~($ // ""))); + my $qtype = sevenize(~($ // "")); if $ -> $block { # If the quasi consists of a block with a single expression statement, it's very @@ -684,13 +683,13 @@ class _007::Parser::Actions { } make Q::Term::Object.new( - :type(Q::Identifier.new(:name(Val::Str.new(:value($type))))), + :type(Q::Identifier.new(:name(sevenize($type)))), :propertylist($.ast)); } method term:object ($/) { my $type = "Object"; - my $name = Val::Str.new(:value($type)); + my $name = sevenize($type); my $frame = $*runtime.builtin-frame; make Q::Term::Object.new( @@ -737,7 +736,7 @@ class _007::Parser::Actions { method infix($/) { my $op = ~$/; my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("infix:$op"))), + :name(sevenize("infix:$op")), :frame($*runtime.current-frame), ); make $*parser.opscope.ops{$op}.new(:$identifier, :lhs(NONE), :rhs(NONE)); @@ -763,7 +762,7 @@ class _007::Parser::Actions { $op = "."; } my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value("postfix:$op"))), + :name(sevenize("postfix:$op")), :frame($*runtime.current-frame), ); # XXX: this can't stay hardcoded forever, but we don't have the machinery yet @@ -791,7 +790,8 @@ class _007::Parser::Actions { $value ~~ s:g['\\»'] = '»'; $value ~~ s:g['\\\\'] = '\\'; }(); - make Q::Identifier.new(:name(Val::Str.new(:$value))); + my $name = sevenize($value); + make Q::Identifier.new(:$name); } method argumentlist($/) { diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index 1e0bd3a1..b4fe00db 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -41,9 +41,8 @@ grammar _007::Parser::Syntax { 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 = sevenize($symbol); + my $identifier = Q::Identifier.new(:$name, :$frame); $*runtime.declare-var($identifier); @*declstack[*-1]{$symbol} = $decltype; } diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index bd8bc4d1..251fedde 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -147,7 +147,7 @@ class Q::Literal::Int does Q::Literal { ### A string literal. ### class Q::Literal::Str does Q::Literal { - has Val::Str $.value; + has _007::Object $.value; method eval($) { $.value } } @@ -160,7 +160,7 @@ class Q::Literal::Str does Q::Literal { ### storage locations because they belong to different scopes. ### class Q::Identifier does Q::Term { - has Val::Str $.name; + has _007::Object $.name; has $.frame = NONE; method attribute-order { } @@ -179,7 +179,7 @@ class Q::Identifier does Q::Term { ### A regular expression (*regex*). ### class Q::Term::Regex does Q::Term { - has Val::Str $.contents; + has _007::Object $.contents; method eval($runtime) { Val::Regex.new(:$.contents); @@ -226,7 +226,7 @@ class Q::Term::Object does Q::Term { ### An object property. Properties have a key and a value. ### class Q::Property does Q { - has Val::Str $.key; + has _007::Object $.key; has $.value; } @@ -283,7 +283,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { method eval($runtime) { my $name = $.identifier ~~ Val::NoneType - ?? Val::Str.new(:value("")) + ?? sevenize("") !! $.identifier.name; return Val::Sub.new( :$name, @@ -596,7 +596,7 @@ class Q::Postfix::Index is Q::Postfix { when Val::Object | Val::Sub | Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new - if $property !~~ Val::Str; + unless $property ~~ _007::Object && $property.type === TYPE; my $propname = $property.value; return $runtime.property($_, $propname); } @@ -619,7 +619,7 @@ class Q::Postfix::Index is Q::Postfix { when Val::Object | Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new - if $property !~~ Val::Str; + unless $property ~~ _007::Object && $property.type === TYPE; my $propname = $property.value; $runtime.put-property($_, $propname, $value); } @@ -995,7 +995,7 @@ class Q::Statement::Throw does Q::Statement { method run($runtime) { my $value = $.expr ~~ Val::NoneType - ?? Val::Exception.new(:message(Val::Str.new(:value("Died")))) + ?? Val::Exception.new(:message(sevenize("Died"))) !! $.expr.eval($runtime); die X::TypeCheck.new(:got($value), :excpected(Val::Exception)) if $value !~~ Val::Exception; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 5f66fcd8..c6c58faa 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -5,7 +5,7 @@ use _007::OpScope; constant NO_OUTER = Val::Object.new; constant RETURN_TO = Q::Identifier.new( - :name(Val::Str.new(:value("--RETURN-TO--"))), + :name(sevenize("--RETURN-TO--")), :frame(NONE)); class _007::Runtime { @@ -36,7 +36,7 @@ class _007::Runtime { @!frames.push($frame); for $static-lexpad.properties.kv -> $name, $value { my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value($name))), + :name(sevenize($name)), :frame(NONE)); self.declare-var($identifier, $value); } @@ -142,7 +142,7 @@ class _007::Runtime { my $opscope = $!builtin-opscope; for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { my $identifier = Q::Identifier.new( - :name(Val::Str.new(:value($name))), + :name(sevenize($name)), :frame(NONE)); self.declare-var($identifier, $value); } @@ -178,7 +178,7 @@ class _007::Runtime { 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 ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(sevenize($^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(); @@ -231,39 +231,39 @@ class _007::Runtime { return $obj."$propname"(); } - elsif $obj ~~ _007::Object && $propname eq "abs" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "abs" { return builtin(sub abs() { return sevenize($obj.value.abs); }); } - elsif $obj ~~ _007::Object && $propname eq "chr" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chr" { return builtin(sub chr() { - return Val::Str.new(:value($obj.value.chr)); + return sevenize($obj.value.chr); }); } - elsif $obj ~~ Val::Str && $propname eq "ord" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "ord" { return builtin(sub ord() { return sevenize($obj.value.ord); }); } - elsif $obj ~~ Val::Str && $propname eq "chars" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chars" { return builtin(sub chars() { return sevenize($obj.value.chars); }); } - elsif $obj ~~ Val::Str && $propname eq "uc" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "uc" { return builtin(sub uc() { - return Val::Str.new(:value($obj.value.uc)); + return sevenize($obj.value.uc); }); } - elsif $obj ~~ Val::Str && $propname eq "lc" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "lc" { return builtin(sub lc() { - return Val::Str.new(:value($obj.value.lc)); + return sevenize($obj.value.lc); }); } - elsif $obj ~~ Val::Str && $propname eq "trim" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "trim" { return builtin(sub trim() { - return Val::Str.new(:value($obj.value.trim)); + return sevenize($obj.value.trim); }); } elsif $obj ~~ Val::Array && $propname eq "size" { @@ -295,7 +295,7 @@ class _007::Runtime { } elsif $obj ~~ Val::Array && $propname eq "join" { return builtin(sub join($sep) { - return Val::Str.new(:value($obj.elements.join($sep.value.Str))); + return sevenize($obj.elements.join($sep.value.Str)); }); } elsif $obj ~~ Val::Object && $propname eq "size" { @@ -303,55 +303,55 @@ class _007::Runtime { return sevenize($obj.properties.elems); }); } - elsif $obj ~~ Val::Str && $propname eq "split" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "split" { return builtin(sub split($sep) { - my @elements = (Val::Str.new(:value($_)) for $obj.value.split($sep.value)); + my @elements = (sevenize($_) for $obj.value.split($sep.value)); return Val::Array.new(:@elements); }); } - elsif $obj ~~ Val::Str && $propname eq "index" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "index" { return builtin(sub index($substr) { return sevenize($obj.value.index($substr.value) // -1); }); } - elsif $obj ~~ Val::Str && $propname eq "substr" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "substr" { return builtin(sub substr($pos, $chars) { - return Val::Str.new(:value($obj.value.substr( + return sevenize($obj.value.substr( $pos.value, - $chars.value))); + $chars.value)); }); } - elsif $obj ~~ Val::Str && $propname eq "contains" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "contains" { return builtin(sub contains($substr) { - die X::TypeCheck.new(:operation, :got($substr), :expected(Val::Str)) - unless $substr ~~ Val::Str; + die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) + unless $substr ~~ _007::Object && $substr.type === TYPE; return Val::Bool.new(:value( $obj.value.contains($substr.value); )); }); } - elsif $obj ~~ Val::Str && $propname eq "prefix" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "prefix" { return builtin(sub prefix($pos) { - return Val::Str.new(:value($obj.value.substr( + return sevenize($obj.value.substr( 0, - $pos.value))); + $pos.value)); }); } - elsif $obj ~~ Val::Str && $propname eq "suffix" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "suffix" { return builtin(sub suffix($pos) { - return Val::Str.new(:value($obj.value.substr( - $pos.value))); + return sevenize($obj.value.substr( + $pos.value)); }); } - elsif $obj ~~ Val::Str && $propname eq "charat" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $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))); + return sevenize($s.substr($pos.value, 1)); }); } elsif $obj ~~ Val::Regex && $propname eq "fullmatch" { @@ -359,7 +359,7 @@ class _007::Runtime { my $regex-string = $obj.contents.value; die X::Regex::InvalidMatchType.new - unless $str ~~ Val::Str; + unless $str ~~ _007::Object && $str.type === TYPE; return Val::Bool.new(:value($regex-string eq $str.value)); }); @@ -369,7 +369,7 @@ class _007::Runtime { my $regex-string = $obj.contents.value; die X::Regex::InvalidMatchType.new - unless $str ~~ Val::Str; + unless $str ~~ _007::Object && $str.type === TYPE; return Val::Bool.new(:value($str.value.contains($regex-string))); }); @@ -413,10 +413,10 @@ class _007::Runtime { }); } elsif $obj ~~ _007::Type && $propname eq "name" { - return Val::Str.new(:value($obj.name)); + return sevenize($obj.name); } elsif $obj ~~ Val::Type | _007::Type && $propname eq "name" { - return Val::Str.new(:value($obj.name)); + return sevenize($obj.name); } elsif $obj ~~ _007::Type && $propname eq "create" { return builtin(sub create($properties) { @@ -441,9 +441,7 @@ class _007::Runtime { } elsif $propname eq "keys" { return builtin(sub keys() { - return Val::Array.new(:elements($obj.properties.keys.map({ - Val::Str.new(:$^value) - }))); + return Val::Array.new(:elements($obj.properties.keys.map(&sevenize))); }); } elsif $propname eq "has" { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 2d6afb96..5f570884 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -8,7 +8,8 @@ use Test; sub read(Str $ast) is export { sub n($type, $op) { - Q::Identifier.new(:name(Val::Str.new(:value($type ~ ":<$op>")))); + my $name = sevenize($type ~ ":<$op>"); + return Q::Identifier.new(:$name); } my %q_lookup = @@ -96,7 +97,8 @@ sub read(Str $ast) is export { 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 = sevenize($qname); + %arguments = Q::Identifier.new(:$name); shift @attributes; # $.identifier } }(); @@ -123,7 +125,7 @@ sub read(Str $ast) is export { } method expr:symbol ($/) { make ~$/ } method expr:int ($/) { make sevenize(+$/) } - method expr:str ($/) { make Val::Str.new(:value((~$0).subst(q[\\"], q["], :g))) } + method expr:str ($/) { make sevenize((~$0).subst(q[\\"], q["], :g)) } }; AST::Syntax.parse($ast, :$actions) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 86b158a9..f2b0c25c 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -21,6 +21,7 @@ class _007::Type { constant TYPE = {}; TYPE = _007::Type.new(:name("Type")); TYPE = _007::Type.new(:name("Int")); +TYPE = _007::Type.new(:name("Str")); class _007::Object { has $.type; @@ -30,12 +31,26 @@ class _007::Object { method truthy { ?$.value } - method quoted-Str { self.Str } + method quoted-Str { + if $.type === TYPE { + return q["] ~ $.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]; + } + return self.Str; + } + method Str { ~($.value // "EMPTY") } } sub sevenize($value) is export { - _007::Object.new(:type(TYPE), :$value); + if $value ~~ Int { + return _007::Object.new(:type(TYPE), :$value); + } + elsif $value ~~ Str { + return _007::Object.new(:type(TYPE), :$value); + } + else { + die "Tried to sevenize unknown value ", $value.^name; + } } role Val { @@ -201,7 +216,7 @@ class Val::Str does Val { ### say(/"Bond"/.search("J. Bond")); # --> `True` ### class Val::Regex does Val { - has Val::Str $.contents; + has _007::Object $.contents; method quoted-Str { "/" ~ $.contents.quoted-Str ~ "/" @@ -382,7 +397,7 @@ class Val::Object does Val { return '{' ~ %.properties.map({ my $key = .key ~~ /^ [\w+]+ % '::'$/ ?? .key - !! Val::Str.new(value => .key).quoted-Str; + !! sevenize(.key).quoted-Str; "{$key}: {.value.quoted-Str}" }).sort.join(', ') ~ '}'; } @@ -459,9 +474,6 @@ class Val::Type does Val { elsif $.type ~~ _007::Object { return $.type.new(:value(@properties[0].value.value)); } - elsif $.type ~~ Val::Str { - return $.type.new(:value(@properties[0].value.value)); - } elsif $.type ~~ Val::Array { return $.type.new(:elements(@properties[0].value.elements)); } @@ -504,7 +516,7 @@ class Val::Type does Val { ### say(add(2, 5)); # --> `7` ### class Val::Sub is Val { - has Val::Str $.name; + has _007::Object $.name; has &.hook = Callable; has $.parameterlist; has $.statementlist; @@ -512,7 +524,7 @@ class Val::Sub is Val { has Val::Object $.outer-frame; method new-builtin(&hook, Str $name, $parameterlist, $statementlist) { - self.bless(:name(Val::Str.new(:value($name))), :&hook, :$parameterlist, :$statementlist); + self.bless(:name(sevenize($name)), :&hook, :$parameterlist, :$statementlist); } method escaped-name { @@ -558,14 +570,13 @@ class Val::Macro is Val::Sub { ### flow couldn't continue normally. ### class Val::Exception does Val { - has Val::Str $.message; + has _007::Object $.message; } class Helper { our sub Str($_) { when Val::NoneType { "None" } when Val::Bool { .value.Str } - when Val::Str { .value } when Val::Regex { .quoted-Str } when Val::Array { .quoted-Str } when Val::Object { .quoted-Str } From 450d49fd874777d4bd741e9ea050e11762dc2e28 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 19 Aug 2017 16:42:16 +0200 Subject: [PATCH 05/91] remove Val::Str --- lib/_007/Val.pm | 39 --------------------------------------- 1 file changed, 39 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index f2b0c25c..b819d393 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -161,45 +161,6 @@ class Val::Bool does Val { } } -### ### 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 From 317d4ea3a3862d89200688089bbe965834bbe83e Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 21 Aug 2017 07:04:21 +0200 Subject: [PATCH 06/91] asset-capture Val::Array --- lib/_007/Backend/JavaScript.pm | 6 +-- lib/_007/Builtins.pm | 66 ++++++++++++++----------- lib/_007/Linter.pm | 4 +- lib/_007/Parser/Actions.pm | 38 +++++++++------ lib/_007/Q.pm | 73 ++++++++++++++-------------- lib/_007/Runtime.pm | 85 +++++++++++++++++---------------- lib/_007/Test.pm | 19 ++++++-- lib/_007/Val.pm | 30 ++++++++---- t/features/builtins/methods.t | 2 +- t/features/builtins/operators.t | 4 +- t/features/quasi.t | 2 +- 11 files changed, 188 insertions(+), 141 deletions(-) diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 7b278775..4f6d38e6 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -12,12 +12,12 @@ my %builtins = class _007::Backend::JavaScript { method emit(Q::CompUnit $compunit) { return "" - unless $compunit.block.statementlist.statements.elements; + unless $compunit.block.statementlist.statements.value; my @builtins; my @main; - for $compunit.block.statementlist.statements.elements -> $stmt { + for $compunit.block.statementlist.statements.value -> $stmt { emit-stmt($stmt); } @@ -40,7 +40,7 @@ class _007::Backend::JavaScript { && $expr.operand.name.value eq "say" { @builtins.push(%builtins); - my @arguments = $expr.argumentlist.arguments.elements.map: { + my @arguments = $expr.argumentlist.arguments.value.map: { die "Cannot handle non-literal-Str arguments just yet!" unless $_ ~~ Q::Literal::Str; .value.quoted-Str; diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 2ead368f..abfaed8e 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -8,7 +8,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { when Nil { NONE } when Bool { Val::Bool.new(:value($_)) } when Str { die "A Str was sent to &wrap" } - when Array | Seq | List { Val::Array.new(:elements(.map(&wrap))) } default { die "Got some unknown value of type ", .^name } } @@ -20,25 +19,29 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return False unless $l.type === $r.type; my $type = $l.type; - return $type === TYPE - ?? $l.value == $r.value - !! $type === TYPE - ?? $l.value eq $r.value - !! die "Unknown type ", $type.Str; - } - multi equal-value(Val::Array $l, Val::Array $r) { - if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { - return $l === $r; + if $type === TYPE { + return $l.value == $r.value; } - %*equality-seen{$l.WHICH}++; - %*equality-seen{$r.WHICH}++; - - sub equal-at-index($i) { - equal-value($l.elements[$i], $r.elements[$i]); + elsif $type === TYPE { + return $l.value eq $r.value; } + elsif $type === TYPE { + 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]); + } - [&&] $l.elements == $r.elements, - |(^$l.elements).map(&equal-at-index); + [&&] $l.value == $r.value, + |(^$l.value).map(&equal-at-index); + } + else { + die "Unknown type ", $type.Str; + } } multi equal-value(Val::Object $l, Val::Object $r) { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { @@ -241,9 +244,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # 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::TypeCheck.new(:operation<::>, :got($rhs), :expected(_007::Object)) + unless $rhs ~~ _007::Object && $rhs.type === TYPE; + return sevenize([$lhs, |$rhs.value]); }, :qtype(Q::Infix::Cons), :assoc, @@ -330,11 +333,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), '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($lhs), :expected(_007::Object)) + unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return wrap(| $lhs.elements xx $rhs.value); + return sevenize(| $lhs.value xx $rhs.value); }, :qtype(Q::Infix::ArrayReplicate), :precedence{ equal => "infix:*" }, @@ -397,7 +400,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { sub ($n) { die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) unless $n ~~ _007::Object && $n.type === TYPE; - return wrap([(^$n.value).map(&sevenize)]); + return sevenize([(^$n.value).map(&sevenize)]); }, :qtype(Q::Prefix::Upto), ), @@ -424,8 +427,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { tree-walk(Val::); tree-walk(Q::); push @builtins, "Q" => Val::Type.of(Q); - push @builtins, ("Int" => TYPE); - push @builtins, ("Str" => TYPE); + for TYPE.keys -> $type { + next if $type eq "Type"; + push @builtins, ($type => TYPE{$type}); + } sub install-op($name, $placeholder) { $name ~~ /^ (prefix | infix | postfix) ':' (.+) $/ @@ -447,7 +452,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } when .value ~~ Block { my @elements = .value.signature.params».name».&ditch-sigil».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); + my $parameters = sevenize(@elements); + my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(.value, .key, $parameterlist, $statementlist); } @@ -455,7 +461,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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 $parameters = sevenize(@elements); + my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(sub () {}, $name, $parameterlist, $statementlist); } @@ -464,7 +471,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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 $parameters = sevenize(@elements); + my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); } diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 6a1875d5..58cfd51c 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -66,7 +66,7 @@ class _007::Linter { } multi traverse(Q::StatementList $statementlist) { - for $statementlist.statements.elements -> $stmt { + for $statementlist.statements.value -> $stmt { traverse($stmt); } } @@ -108,7 +108,7 @@ class _007::Linter { } multi traverse(Q::ArgumentList $argumentlist) { - for $argumentlist.arguments.elements -> $expr { + for $argumentlist.arguments.value -> $expr { traverse($expr); } } diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 03870b02..60c43738 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -92,7 +92,8 @@ class _007::Parser::Actions { } method statementlist($/) { - make Q::StatementList.new(:statements(Val::Array.new(:elements($».ast)))); + my $statements = sevenize($».ast); + make Q::StatementList.new(:$statements); } method statement:my ($/) { @@ -265,7 +266,8 @@ class _007::Parser::Actions { my $trait = $p.key; die X::Trait::Duplicate.new(:$trait); } - make Q::TraitList.new(:traits(Val::Array.new(:elements(@traits)))); + my $traits = sevenize(@traits); + make Q::TraitList.new(:$traits); } method trait($/) { make Q::Trait.new(:identifier($.ast), :expr($.ast)); @@ -318,10 +320,12 @@ class _007::Parser::Actions { } else { if $expansion ~~ Q::Statement { - $expansion = Q::StatementList.new(:statements(Val::Array.new(:elements([$expansion])))); + my $statements = sevenize([$expansion]); + $expansion = Q::StatementList.new(:$statements); } elsif $expansion === NONE { - $expansion = Q::StatementList.new(:statements(Val::Array.new(:elements([])))); + my $statements = sevenize([]); + $expansion = Q::StatementList.new(:$statements); } if $expansion ~~ Q::StatementList { @@ -454,7 +458,7 @@ class _007::Parser::Actions { 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, + make expand($macro, $postfix.argumentlist.arguments.value, -> { $postfix.new(:$identifier, :operand($/.ast), :argumentlist($postfix.argumentlist)) }); } elsif $postfix ~~ Q::Postfix::Index { @@ -544,7 +548,8 @@ class _007::Parser::Actions { } method term:array ($/) { - make Q::Term::Array.new(:elements(Val::Array.new(:elements($».ast)))); + my $elements = sevenize($».ast); + make Q::Term::Array.new(:$elements); } method term:parens ($/) { @@ -590,7 +595,7 @@ 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]; + my $contents = $block.ast.statementlist.statements.value[0]; make Q::Term::Quasi.new(:$contents, :$qtype); return; } @@ -601,10 +606,10 @@ class _007::Parser::Actions { } 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.statementlist.statements.value.elems == 1 + && $block.ast.statementlist.statements.value[0] ~~ Q::Statement::Expr { - my $contents = $block.ast.statementlist.statements.elements[0].expr; + my $contents = $block.ast.statementlist.statements.value[0].expr; make Q::Term::Quasi.new(:$contents, :$qtype); return; } @@ -667,7 +672,7 @@ class _007::Parser::Actions { elsif $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 { + for $.ast.properties.value -> $p { my $property = $p.key.value; die X::Property::NotDeclared.new(:$type, :$property) unless %known-properties{$property}; @@ -678,7 +683,7 @@ class _007::Parser::Actions { 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); + unless $property eq any($.ast.properties.value».key».value); } } @@ -705,7 +710,8 @@ class _007::Parser::Actions { if %seen{$property}++; } - make Q::PropertyList.new(:properties(Val::Array.new(:elements($».ast)))); + my $properties = sevenize($».ast); + make Q::PropertyList.new(:$properties); } method property:str-expr ($/) { @@ -795,11 +801,13 @@ class _007::Parser::Actions { } method argumentlist($/) { - make Q::ArgumentList.new(:arguments(Val::Array.new(:elements($».ast)))); + my $arguments = sevenize($».ast); + make Q::ArgumentList.new(:$arguments); } method parameterlist($/) { - make Q::ParameterList.new(:parameters(Val::Array.new(:elements($».ast)))); + my $parameters = sevenize($».ast); + make Q::ParameterList.new(:$parameters); } method parameter($/) { diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 251fedde..280ccf91 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -53,6 +53,8 @@ class X::_007::RuntimeException is Exception { } } +sub empty-array() { sevenize([]) } + sub aname($attr) { $attr.name.substr(2) } sub avalue($attr, $obj) { $attr.get_value($obj) } @@ -192,10 +194,10 @@ class Q::Term::Regex does Q::Term { ### can be an arbitrary expression. ### class Q::Term::Array does Q::Term { - has Val::Array $.elements; + has _007::Object $.elements; method eval($runtime) { - Val::Array.new(:elements($.elements.elements.map(*.eval($runtime)))); + sevenize($.elements.value.map(*.eval($runtime))); } } @@ -211,12 +213,12 @@ class Q::Term::Object does Q::Term { method eval($runtime) { my $type = $runtime.get-var($.type.name.value, $.type.frame); if $type ~~ _007::Type { - my $value = $.propertylist.properties.elements[0].value.eval($runtime); + my $value = $.propertylist.properties.value[0].value.eval($runtime); # XXX: cheat less return $value; } return $runtime.get-var($.type.name.value, $.type.frame).create( - $.propertylist.properties.elements.map({.key.value => .value.eval($runtime)}) + $.propertylist.properties.value.map({.key.value => .value.eval($runtime)}) ); } } @@ -237,7 +239,7 @@ class Q::Property does Q { ### a specified order: the order the properties occur in the program text. ### class Q::PropertyList does Q { - has Val::Array $.properties .= new; + has _007::Object $.properties = empty-array(); } ### ### Q::Declaration @@ -265,7 +267,7 @@ class Q::Trait does Q { ### A list of zero or more traits. Each routine has a traitlist. ### class Q::TraitList does Q { - has Val::Array $.traits .= new; + has _007::Object $.traits = empty-array(); method attribute-order { } } @@ -583,15 +585,15 @@ class Q::Postfix::Index is Q::Postfix { method eval($runtime) { given $.operand.eval($runtime) { - when Val::Array { + if $_ ~~ _007::Object && .type === TYPE { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - if $index !~~ _007::Object; - die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) - if $index.value >= .elements; + unless $index ~~ _007::Object && $index.type === TYPE; + 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 .elements[$index.value]; + return .value[$index.value]; } when Val::Object | Val::Sub | Q { my $property = $.index.eval($runtime); @@ -600,21 +602,22 @@ class Q::Postfix::Index is Q::Postfix { my $propname = $property.value; return $runtime.property($_, $propname); } - die X::TypeCheck.new(:operation, :got($_), :expected(Val::Array)); + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); } } method put-value($value, $runtime) { given $.operand.eval($runtime) { - when Val::Array { + if $_ ~~ _007::Object && .type === TYPE { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - if $index !~~ _007::Object; - die X::Subscript::TooLarge.new(:value($index.value), :length(+.elements)) - if $index.value >= .elements; + unless $index ~~ _007::Object && $index.type === TYPE; + 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; - .elements[$index.value] = $value; + .value[$index.value] = $value; + return; } when Val::Object | Q { my $property = $.index.eval($runtime); @@ -623,7 +626,7 @@ class Q::Postfix::Index is Q::Postfix { my $propname = $property.value; $runtime.put-property($_, $propname, $value); } - die X::TypeCheck.new(:operation, :got($_), :expected(Val::Array)); + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); } } } @@ -643,7 +646,7 @@ class Q::Postfix::Call is Q::Postfix { 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)); + my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); return $runtime.call($c, @arguments); } } @@ -723,12 +726,12 @@ class Q::Term::Quasi does Q::Term { method eval($runtime) { sub interpolate($thing) { + return sevenize($thing.value.map(&interpolate)) + if $thing ~~ _007::Object && $thing.type === TYPE; + return $thing if $thing ~~ _007::Object; # XXX: won't hold true for everything - 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; @@ -788,7 +791,7 @@ class Q::Parameter does Q does Q::Declaration { ### A list of zero or more parameters. ### class Q::ParameterList does Q { - has Val::Array $.parameters .= new; + has _007::Object $.parameters = empty-array(); } ### ### Q::ArgumentList @@ -796,7 +799,7 @@ class Q::ParameterList does Q { ### A list of zero or more arguments. ### class Q::ArgumentList does Q { - has Val::Array $.arguments .= new; + has _007::Object $.arguments = empty-array(); } ### ### Q::Statement @@ -872,8 +875,8 @@ class Q::Statement::If does Q::Statement { :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); + if $.block.parameterlist.parameters.value == 1 { + $runtime.declare-var($.block.parameterlist.parameters.value[0].identifier, $expr); } $.block.statementlist.run($runtime); $runtime.leave; @@ -926,19 +929,19 @@ class Q::Statement::For does Q::Statement { method attribute-order { } method run($runtime) { - my $count = $.block.parameterlist.parameters.elements.elems; + my $count = $.block.parameterlist.parameters.value.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; + die X::TypeCheck.new(:operation("for loop"), :got($array), :expected(_007::Object)) + unless $array ~~ _007::Object && $array.type === TYPE; - for $array.elements -> $arg { + for $array.value -> $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]); + $runtime.declare-var($.block.parameterlist.parameters.value[0].identifier, $arg.list[0]); } $.block.statementlist.run($runtime); $runtime.leave; @@ -958,12 +961,12 @@ class Q::Statement::While does Q::Statement { method run($runtime) { while (my $expr = $.expr.eval($runtime)).truthy { - my $paramcount = $.block.parameterlist.parameters.elements.elems; + my $paramcount = $.block.parameterlist.parameters.value.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) { + for @($.block.parameterlist.parameters.value) Z $expr -> ($param, $arg) { $runtime.declare-var($param.identifier, $arg); } $.block.statementlist.run($runtime); @@ -1066,10 +1069,10 @@ class Q::Statement::Class does Q::Statement does Q::Declaration { ### denote a statement list without any surrounding block. ### class Q::StatementList does Q { - has Val::Array $.statements .= new; + has _007::Object $.statements = empty-array(); method run($runtime) { - for $.statements.elements -> $statement { + for $.statements.value -> $statement { my $value = $statement.run($runtime); LAST if $statement ~~ Q::Statement::Expr { return $value; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index c6c58faa..3d510a28 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -40,7 +40,7 @@ class _007::Runtime { :frame(NONE)); self.declare-var($identifier, $value); } - for $statementlist.statements.elements.kv -> $i, $_ { + for $statementlist.statements.value.kv -> $i, $_ { when Q::Statement::Sub { my $name = .identifier.name; my $parameterlist = .block.parameterlist; @@ -149,7 +149,7 @@ class _007::Runtime { } method call(Val::Sub $c, @arguments) { - my $paramcount = $c.parameterlist.parameters.elements.elems; + my $paramcount = $c.parameterlist.parameters.value.elems; my $argcount = @arguments.elems; die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) unless $paramcount == $argcount; @@ -157,7 +157,7 @@ class _007::Runtime { return &hook(|@arguments) || NONE; } self.enter($c.outer-frame, $c.static-lexpad, $c.statementlist, $c); - for @($c.parameterlist.parameters.elements) Z @arguments -> ($param, $arg) { + for @($c.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { self.declare-var($param.identifier, $arg); } self.register-subhandler; @@ -180,7 +180,8 @@ class _007::Runtime { my &ditch-sigil = { $^str.substr(1) }; my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(sevenize($^value))))) }; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameterlist = Q::ParameterList.new(:parameters(Val::Array.new(:@elements))); + my $parameters = sevenize(@elements); + my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); return Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); } @@ -192,8 +193,8 @@ class _007::Runtime { sub avalue($attr, $obj) { $attr.get_value($obj) } sub interpolate($thing) { - return $thing.new(:elements($thing.elements.map(&interpolate))) - if $thing ~~ Val::Array; + return sevenize($thing.value.map(&interpolate)) + if $thing ~~ _007::Object && $thing.type === TYPE; return $thing.new(:properties(%($thing.properties.map(.key => interpolate(.value))))) if $thing ~~ Val::Object; @@ -266,36 +267,36 @@ class _007::Runtime { return sevenize($obj.value.trim); }); } - elsif $obj ~~ Val::Array && $propname eq "size" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { return builtin(sub size() { - return sevenize($obj.elements.elems); + return sevenize($obj.value.elems); }); } - elsif $obj ~~ Val::Array && $propname eq "reverse" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "reverse" { return builtin(sub reverse() { - return Val::Array.new(:elements($obj.elements.reverse)); + return sevenize($obj.value.reverse); }); } - elsif $obj ~~ Val::Array && $propname eq "sort" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "sort" { return builtin(sub sort() { - return Val::Array.new(:elements($obj.elements.sort)); + return sevenize($obj.value.sort); }); } - elsif $obj ~~ Val::Array && $propname eq "shuffle" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "shuffle" { return builtin(sub shuffle() { - return Val::Array.new(:elements($obj.elements.pick(*))); + return sevenize($obj.value.pick(*)); }); } - elsif $obj ~~ Val::Array && $propname eq "concat" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $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])); + die X::TypeCheck.new(:operation, :got($array), :expected(_007::Object)) + unless $array ~~ _007::Object && $array.type === TYPE; + return sevenize([|$obj.value, |$array.value]); }); } - elsif $obj ~~ Val::Array && $propname eq "join" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "join" { return builtin(sub join($sep) { - return sevenize($obj.elements.join($sep.value.Str)); + return sevenize($obj.value.join($sep.value.Str)); }); } elsif $obj ~~ Val::Object && $propname eq "size" { @@ -305,8 +306,8 @@ class _007::Runtime { } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "split" { return builtin(sub split($sep) { - my @elements = (sevenize($_) for $obj.value.split($sep.value)); - return Val::Array.new(:@elements); + my @elements = $obj.value.split($sep.value).map(&sevenize); + return sevenize(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "index" { @@ -374,41 +375,41 @@ class _007::Runtime { return Val::Bool.new(:value($str.value.contains($regex-string))); }); } - elsif $obj ~~ Val::Array && $propname eq "filter" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { return builtin(sub filter($fn) { - my @elements = $obj.elements.grep({ self.call($fn, [$_]).truthy }); - return Val::Array.new(:@elements); + my @elements = $obj.value.grep({ self.call($fn, [$_]).truthy }); + return sevenize(@elements); }); } - elsif $obj ~~ Val::Array && $propname eq "map" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { return builtin(sub map($fn) { - my @elements = $obj.elements.map({ self.call($fn, [$_]) }); - return Val::Array.new(:@elements); + my @elements = $obj.value.map({ self.call($fn, [$_]) }); + return sevenize(@elements); }); } - elsif $obj ~~ Val::Array && $propname eq "push" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "push" { return builtin(sub push($newelem) { - $obj.elements.push($newelem); + $obj.value.push($newelem); return NONE; }); } - elsif $obj ~~ Val::Array && $propname eq "pop" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $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(); + if $obj.value.elems == 0; + return $obj.value.pop(); }); } - elsif $obj ~~ Val::Array && $propname eq "shift" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $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(); + if $obj.value.elems == 0; + return $obj.value.shift(); }); } - elsif $obj ~~ Val::Array && $propname eq "unshift" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "unshift" { return builtin(sub unshift($newelem) { - $obj.elements.unshift($newelem); + $obj.value.unshift($newelem); return NONE; }); } @@ -420,12 +421,14 @@ class _007::Runtime { } elsif $obj ~~ _007::Type && $propname eq "create" { return builtin(sub create($properties) { - _007::Object.new(:value($properties.elements[0].elements[1].value)); + # XXX: needs more sanity checking + sevenize($properties.value[0].value[1].value); # XXX: won't work for non-wrapped objects + # _007::Object.new(:value($properties.value[0].value[1].value)); }); } elsif $obj ~~ Val::Type && $propname eq "create" { return builtin(sub create($properties) { - $obj.create($properties.elements.map({ .elements[0].value => .elements[1] })); + $obj.create($properties.value.map({ .value[0].value => .value[1] })); }); } elsif $obj ~~ Val::Sub && $propname eq any { @@ -441,7 +444,7 @@ class _007::Runtime { } elsif $propname eq "keys" { return builtin(sub keys() { - return Val::Array.new(:elements($obj.properties.keys.map(&sevenize))); + return sevenize($obj.properties.keys.map(&sevenize)); }); } elsif $propname eq "has" { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 5f570884..72d171d0 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -73,6 +73,17 @@ sub read(Str $ast) is export { propertylist => Q::PropertyList, ; + # 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 {*} @@ -104,9 +115,9 @@ sub read(Str $ast) is export { }(); sub aname($attr) { $attr.name.substr(2) } - if @attributes == 1 && @attributes[0].type ~~ Val::Array { + if @attributes == 1 && (%qtype-has-just-array{$qtype.^name} :exists) { my $aname = aname(@attributes[0]); - %arguments{$aname} = Val::Array.new(:elements(@rest)); + %arguments{$aname} = sevenize(@rest); } else { die "{+@rest} arguments passed, only {+@attributes} parameters expected for {$qtype.^name}" @@ -162,7 +173,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { multi handle(Q::Postfix $) {} multi handle(Q::StatementList $statementlist) { - for $statementlist.statements.elements -> $statement { + for $statementlist.statements.value -> $statement { handle($statement); } } @@ -256,7 +267,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { multi handle(Q::PropertyList $propertylist) { my %seen; - for $propertylist.properties.elements -> Q::Property $p { + for $propertylist.properties.value -> Q::Property $p { my Str $property = $p.key.value; die X::Property::Duplicate.new(:$property) if %seen{$property}++; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index b819d393..c9f81fb2 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -22,6 +22,7 @@ constant TYPE = {}; TYPE = _007::Type.new(:name("Type")); TYPE = _007::Type.new(:name("Int")); TYPE = _007::Type.new(:name("Str")); +TYPE = _007::Type.new(:name("Array")); class _007::Object { has $.type; @@ -35,10 +36,20 @@ class _007::Object { if $.type === TYPE { return q["] ~ $.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]; } + if $.type === TYPE { + if %*stringification-seen{self.WHICH}++ { + return "[...]"; + } + return "[" ~ @($.value)».quoted-Str.join(', ') ~ "]"; + } return self.Str; } - method Str { ~($.value // "EMPTY") } + method Str { + my %*stringification-seen; + Helper::Str(self); + } + } sub sevenize($value) is export { @@ -48,6 +59,9 @@ sub sevenize($value) is export { elsif $value ~~ Str { return _007::Object.new(:type(TYPE), :$value); } + elsif $value ~~ Array | Seq { + return _007::Object.new(:type(TYPE), :value($value.Array)); + } else { die "Tried to sevenize unknown value ", $value.^name; } @@ -435,9 +449,6 @@ class Val::Type does Val { elsif $.type ~~ _007::Object { 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 :: \{ @@ -505,7 +516,7 @@ class Val::Sub is Val { } method pretty-parameters { - sprintf "(%s)", $.parameterlist.parameters.elements».identifier».name.join(", "); + sprintf "(%s)", $.parameterlist.parameters.value».identifier».name.join(", "); } method Str { "" } @@ -539,17 +550,20 @@ class Helper { when Val::NoneType { "None" } when Val::Bool { .value.Str } when Val::Regex { .quoted-Str } - when Val::Array { .quoted-Str } when Val::Object { .quoted-Str } when Val::Type { "" } when _007::Type { "" } - when _007::Object { .value.Str } # XXX: wrong in the general case + when _007::Object { + .type === TYPE + ?? .quoted-Str + !! .value.Str + } 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" + die "Unexpected type -- some invariant must be broken ({$self.^name})" unless $self.^name ~~ /^ "Q::"/; # type not introduced yet; can't typecheck sub aname($attr) { $attr.name.substr(2) } diff --git a/t/features/builtins/methods.t b/t/features/builtins/methods.t index 05ebb657..96a6f413 100644 --- a/t/features/builtins/methods.t +++ b/t/features/builtins/methods.t @@ -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..0ef79d6d 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -617,7 +617,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,7 +625,7 @@ 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"; } { diff --git a/t/features/quasi.t b/t/features/quasi.t index 137197db..c2b02ca5 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -9,7 +9,7 @@ use _007::Test; my $expected = read( "(statementlist (stexpr (infix:+ (int 1) (int 1))))" - ).block.statementlist.statements.elements[0].expr.Str; + ).block.statementlist.statements.value[0].expr.Str; outputs $program, "$expected\n", "Basic quasi quoting"; } From f4af8238294ecdb0dac7fb25ba285adaad0763bb Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 21 Aug 2017 07:07:30 +0200 Subject: [PATCH 07/91] remove Val::Array --- lib/_007/Val.pm | 75 ------------------------------------------------- 1 file changed, 75 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index c9f81fb2..5080b1dd 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -198,81 +198,6 @@ class Val::Regex does Val { } } -### ### 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 From c19c1309ef84940bedb90408e624ab376abc513a Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 26 Aug 2017 14:39:01 +0200 Subject: [PATCH 08/91] de-duplicate code that creates TYPE --- lib/_007/Val.pm | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 5080b1dd..5057fa5e 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -18,11 +18,9 @@ class _007::Type { } } -constant TYPE = {}; -TYPE = _007::Type.new(:name("Type")); -TYPE = _007::Type.new(:name("Int")); -TYPE = _007::Type.new(:name("Str")); -TYPE = _007::Type.new(:name("Array")); +constant TYPE = hash(.map(-> $name { + $name => _007::Type.new(:$name) +})); class _007::Object { has $.type; From 29c9d469ac07c5561920cba1b8b3d7d5ce8cbb79 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 26 Aug 2017 15:37:05 +0200 Subject: [PATCH 09/91] asset-capture Val::NoneType --- lib/_007/Builtins.pm | 7 ++-- lib/_007/Parser/Actions.pm | 2 +- lib/_007/Q.pm | 11 +++--- lib/_007/Runtime.pm | 7 ++-- lib/_007/Test.pm | 2 +- lib/_007/Val.pm | 50 +++++++++++++++++---------- t/code-style/do-not-create-val-none.t | 6 ++-- 7 files changed, 51 insertions(+), 34 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index abfaed8e..66d2b0fa 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -13,7 +13,6 @@ sub builtins(:$input!, :$output!, :$opscope!) 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(_007::Object $l, _007::Object $r) { return False @@ -36,8 +35,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { equal-value($l.value[$i], $r.value[$i]); } - [&&] $l.value == $r.value, - |(^$l.value).map(&equal-at-index); + return [&&] $l.value == $r.value, |(^$l.value).map(&equal-at-index); + } + elsif $type === TYPE { + return True; } else { die "Unknown type ", $type.Str; diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 60c43738..6a4ecfcf 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -511,7 +511,7 @@ class _007::Parser::Actions { :name(sevenize("prefix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.new(:$identifier, :operand(Val::NoneType)); + make $*parser.opscope.ops{$op}.new(:$identifier, :operand(TYPE)); } method prefix-unquote($/) { diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 280ccf91..f47e575b 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -284,7 +284,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { method attribute-order { } method eval($runtime) { - my $name = $.identifier ~~ Val::NoneType + my $name = $.identifier ~~ _007::Object && $.identifier.type === TYPE ?? sevenize("") !! $.identifier.name; return Val::Sub.new( @@ -521,7 +521,7 @@ class Q::Infix::Or is Q::Infix { class Q::Infix::DefinedOr is Q::Infix { method eval($runtime) { my $l = $.lhs.eval($runtime); - return $l !~~ Val::NoneType + return $l !~~ _007::Object || $l.type !=== TYPE ?? $l !! $.rhs.eval($runtime); } @@ -823,7 +823,8 @@ class Q::Statement::My does Q::Statement does Q::Declaration { method run($runtime) { return - unless $.expr !~~ Val::NoneType; + if $.expr ~~ _007::Object && $.expr.type === TYPE; + my $value = $.expr.eval($runtime); $.identifier.put-value($value, $runtime); } @@ -983,7 +984,7 @@ class Q::Statement::Return does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ Val::NoneType ?? $.expr !! $.expr.eval($runtime); + my $value = $.expr ~~ _007::Object && $.expr.type === TYPE ?? $.expr !! $.expr.eval($runtime); my $frame = $runtime.get-var("--RETURN-TO--"); die X::Control::Return.new(:$value, :$frame); } @@ -997,7 +998,7 @@ class Q::Statement::Throw does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ Val::NoneType + my $value = $.expr ~~ _007::Object && $.expr.type === TYPE ?? Val::Exception.new(:message(sevenize("Died"))) !! $.expr.eval($runtime); die X::TypeCheck.new(:got($value), :excpected(Val::Exception)) diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 3d510a28..c4af4880 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -84,7 +84,8 @@ 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 `//` + # XXX: make a `defined` method on NoneType so we can use `//` + if $frame ~~ _007::Object && $frame.type === TYPE { $frame = self.current-frame; } repeat until $frame === NO_OUTER { @@ -98,7 +99,7 @@ class _007::Runtime { method put-var(Q::Identifier $identifier, $value) { my $name = $identifier.name.value; - my $frame = $identifier.frame ~~ Val::NoneType + my $frame = $identifier.frame ~~ _007::Object && $identifier.frame.type === TYPE ?? self.current-frame !! $identifier.frame; my $pad = self!find-pad($name, $frame); @@ -118,7 +119,7 @@ class _007::Runtime { method declare-var(Q::Identifier $identifier, $value?) { my $name = $identifier.name.value; - my Val::Object $frame = $identifier.frame ~~ Val::NoneType + my Val::Object $frame = $identifier.frame ~~ _007::Object && $identifier.frame.type === TYPE ?? self.current-frame !! $identifier.frame; $frame.properties.properties{$name} = $value // NONE; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 72d171d0..42b0488d 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -187,7 +187,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { if %*assigned{$block ~ $symbol}; $runtime.declare-var($my.identifier); - if $my.expr !~~ Val::NoneType { + if $my.expr !~~ _007::Object || $my.expr.type !=== TYPE { handle($my.expr); } } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 5057fa5e..7e183ec7 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -11,6 +11,8 @@ class Helper { ... } class _007::Type { has $.name; + method attributes { () } + method quoted-Str { self.Str } method Str { my %*stringification-seen; @@ -18,16 +20,30 @@ class _007::Type { } } -constant TYPE = hash(.map(-> $name { +constant TYPE = hash(.map(-> $name { $name => _007::Type.new(:$name) })); class _007::Object { has $.type; - has $.value; method attributes { () } + method Str { + my %*stringification-seen; + Helper::Str(self); + } + + method quoted-Str { self.Str } + + method truthy { + $.type !=== TYPE + } +} + +class _007::Object::Wrapped is _007::Object { + has $.value; + method truthy { ?$.value } method quoted-Str { @@ -42,23 +58,22 @@ class _007::Object { } return self.Str; } - - method Str { - my %*stringification-seen; - Helper::Str(self); - } - } +constant NONE is export = _007::Object.new(:type(TYPE)); + sub sevenize($value) is export { if $value ~~ Int { - return _007::Object.new(:type(TYPE), :$value); + return _007::Object::Wrapped.new(:type(TYPE), :$value); } elsif $value ~~ Str { - return _007::Object.new(:type(TYPE), :$value); + return _007::Object::Wrapped.new(:type(TYPE), :$value); } elsif $value ~~ Array | Seq { - return _007::Object.new(:type(TYPE), :value($value.Array)); + return _007::Object::Wrapped.new(:type(TYPE), :value($value.Array)); + } + elsif $value ~~ Nil { + return NONE; } else { die "Tried to sevenize unknown value ", $value.^name; @@ -104,7 +119,7 @@ role Val { ### ### The value `None` is falsy, stringifies to `None`, and doesn't numify. ### -### say(!!None); # --> `False` +### say(?None); # --> `False` ### say(~None); # --> `None` ### say(+None); # ### @@ -120,8 +135,6 @@ class Val::NoneType does Val { } } -constant NONE is export = Val::NoneType.new; - ### ### Bool ### ### A type with two values, `True` and `False`. These are often the result @@ -470,16 +483,17 @@ class Val::Exception does Val { class Helper { our sub Str($_) { - when Val::NoneType { "None" } when Val::Bool { .value.Str } when Val::Regex { .quoted-Str } when Val::Object { .quoted-Str } when Val::Type { "" } when _007::Type { "" } when _007::Object { - .type === TYPE - ?? .quoted-Str - !! .value.Str + .type === TYPE + ?? "None" + !! .type === TYPE + ?? .quoted-Str + !! .value.Str } when Val::Macro { "" } when Val::Sub { "" } 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; From ae4f76fe7d24bd3489ee2dcefc86364d39bc47cd Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 26 Aug 2017 15:40:48 +0200 Subject: [PATCH 10/91] remove Val::NoneType --- lib/_007/Val.pm | 44 -------------------------------------------- 1 file changed, 44 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 7e183ec7..a364af0e 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -91,50 +91,6 @@ role Val { } } -### ### 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 - } -} - ### ### Bool ### ### A type with two values, `True` and `False`. These are often the result From 97a8bcf2b7776a4864d8ff2b7a23ac9d6d039270 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 26 Aug 2017 16:45:26 +0200 Subject: [PATCH 11/91] asset-capture Val::Bool --- lib/_007/Builtins.pm | 32 ++++++++++++++++---------------- lib/_007/Parser/Actions.pm | 4 ++-- lib/_007/Q.pm | 2 +- lib/_007/Runtime.pm | 10 ++++------ lib/_007/Val.pm | 26 +++++++++++++++++--------- 5 files changed, 40 insertions(+), 34 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 66d2b0fa..4306643f 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -5,15 +5,12 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { sub wrap($_) { when _007::Object { $_ } when Val | Q { $_ } - when Nil { NONE } - when Bool { Val::Bool.new(:value($_)) } when Str { die "A Str was sent to &wrap" } default { die "Got some unknown value of type ", .^name } } # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } - multi equal-value(Val::Bool $l, Val::Bool $r) { $l.value == $r.value } multi equal-value(_007::Object $l, _007::Object $r) { return False unless $l.type === $r.type; @@ -40,6 +37,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return True; } + elsif $type === TYPE { + return $l === $r; + } else { die "Unknown type ", $type.Str; } @@ -171,21 +171,21 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:==' => op( sub ($lhs, $rhs) { my %*equality-seen; - return wrap(equal-value($lhs, $rhs)); + return sevenize(equal-value($lhs, $rhs)); }, :qtype(Q::Infix::Eq), ), 'infix:!=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return wrap(!equal-value($lhs, $rhs)) + return sevenize(!equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Ne), :precedence{ equal => "infix:==" }, ), 'infix:<' => op( sub ($lhs, $rhs) { - return wrap(less-value($lhs, $rhs)) + return sevenize(less-value($lhs, $rhs)) }, :qtype(Q::Infix::Lt), :precedence{ equal => "infix:==" }, @@ -193,14 +193,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:<=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return wrap(less-value($lhs, $rhs) || equal-value($lhs, $rhs)) + return sevenize(less-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Le), :precedence{ equal => "infix:==" }, ), 'infix:>' => op( sub ($lhs, $rhs) { - return wrap(more-value($lhs, $rhs) ) + return sevenize(more-value($lhs, $rhs) ) }, :qtype(Q::Infix::Gt), :precedence{ equal => "infix:==" }, @@ -208,7 +208,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:>=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return wrap(more-value($lhs, $rhs) || equal-value($lhs, $rhs)) + return sevenize(more-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Ge), :precedence{ equal => "infix:==" }, @@ -216,13 +216,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs ~~ _007::Object && $lhs.type === $rhs); + return sevenize($lhs ~~ _007::Object && $lhs.type === $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type; - return wrap($lhs ~~ $rhs.type); + return sevenize($lhs ~~ $rhs.type); }, :qtype(Q::Infix::TypeMatch), :precedence{ equal => "infix:==" }, @@ -230,13 +230,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:!~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs !~~ _007::Object || $lhs.type !=== $rhs); + return sevenize($lhs !~~ _007::Object || $lhs.type !=== $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type | _007::Type; - return wrap($lhs !~~ $rhs.type); + return sevenize($lhs !~~ $rhs.type); }, :qtype(Q::Infix::TypeNonMatch), :precedence{ equal => "infix:==" }, @@ -317,7 +317,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.type === TYPE; die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; - return wrap($lhs.value %% $rhs.value); + return sevenize($lhs.value %% $rhs.value); }, :qtype(Q::Infix::Divisibility), ), @@ -387,13 +387,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:?' => op( sub ($a) { - return wrap(?$a.truthy) + return sevenize(?$a.truthy) }, :qtype(Q::Prefix::So), ), 'prefix:!' => op( sub ($a) { - return wrap(!$a.truthy) + return sevenize(!$a.truthy) }, :qtype(Q::Prefix::Not), ), diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 6a4ecfcf..73b134dd 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -532,11 +532,11 @@ class _007::Parser::Actions { } method term:false ($/) { - make Q::Literal::Bool.new(:value(Val::Bool.new(:value(False)))); + make Q::Literal::Bool.new(:value(FALSE)); } method term:true ($/) { - make Q::Literal::Bool.new(:value(Val::Bool.new(:value(True)))); + make Q::Literal::Bool.new(:value(TRUE)); } method term:int ($/) { diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index f47e575b..e1c3ad89 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -126,7 +126,7 @@ class Q::Literal::None does Q::Literal { ### A boolean literal; either `True` or `False`. ### class Q::Literal::Bool does Q::Literal { - has Val::Bool $.value; + has _007::Object $.value; method eval($) { $.value } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index c4af4880..b73d4e62 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -328,9 +328,7 @@ class _007::Runtime { die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) unless $substr ~~ _007::Object && $substr.type === TYPE; - return Val::Bool.new(:value( - $obj.value.contains($substr.value); - )); + return sevenize($obj.value.contains($substr.value)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "prefix" { @@ -363,7 +361,7 @@ class _007::Runtime { die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; - return Val::Bool.new(:value($regex-string eq $str.value)); + return sevenize($regex-string eq $str.value); }); } elsif $obj ~~ Val::Regex && $propname eq "search" { @@ -373,7 +371,7 @@ class _007::Runtime { die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; - return Val::Bool.new(:value($str.value.contains($regex-string))); + return sevenize($str.value.contains($regex-string)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { @@ -455,7 +453,7 @@ class _007::Runtime { # substrate, and the special-cased properties # my $value = $obj.properties{$prop.value} :exists; - return Val::Bool.new(:$value); + return sevenize($value); }); } elsif $propname eq "update" { diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index a364af0e..763621d2 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -20,7 +20,7 @@ class _007::Type { } } -constant TYPE = hash(.map(-> $name { +constant TYPE = hash(.map(-> $name { $name => _007::Type.new(:$name) })); @@ -36,9 +36,7 @@ class _007::Object { method quoted-Str { self.Str } - method truthy { - $.type !=== TYPE - } + method truthy { truthy(self) } } class _007::Object::Wrapped is _007::Object { @@ -61,9 +59,18 @@ class _007::Object::Wrapped is _007::Object { } constant NONE is export = _007::Object.new(:type(TYPE)); +constant TRUE is export = _007::Object.new(:type(TYPE)); +constant FALSE is export = _007::Object.new(:type(TYPE)); + +sub truthy($v) { + $v !=== NONE && $v !=== FALSE +} sub sevenize($value) is export { - if $value ~~ Int { + if $value ~~ Bool { + return $value ?? TRUE !! FALSE; + } + elsif $value ~~ Int { return _007::Object::Wrapped.new(:type(TYPE), :$value); } elsif $value ~~ Str { @@ -439,7 +446,6 @@ class Val::Exception does Val { class Helper { our sub Str($_) { - when Val::Bool { .value.Str } when Val::Regex { .quoted-Str } when Val::Object { .quoted-Str } when Val::Type { "" } @@ -447,9 +453,11 @@ class Helper { when _007::Object { .type === TYPE ?? "None" - !! .type === TYPE - ?? .quoted-Str - !! .value.Str + !! .type === TYPE + ?? ($_ === TRUE ?? "True" !! "False") + !! .type === TYPE + ?? .quoted-Str + !! .value.Str } when Val::Macro { "" } when Val::Sub { "" } From e0aec7cae11018a9c7a2790e6979aba60d7df153 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 26 Aug 2017 16:47:26 +0200 Subject: [PATCH 12/91] remove Val::Bool --- lib/_007/Val.pm | 51 ------------------------------------------------- 1 file changed, 51 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 763621d2..a2cadd20 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -98,57 +98,6 @@ role Val { } } -### ### 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; - } -} - ### ### Regex ### ### A regex. As a runtime value, a regex is like a black box that can be put From eb2f5b1483accfe88f5b303d34213decd2bb2d66 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 27 Aug 2017 14:34:52 +0200 Subject: [PATCH 13/91] demote NoneType and Bool to enum types In eager anticipation of actually having enums in the language at some point. --- lib/_007/Val.pm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index a2cadd20..4ff5c359 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -39,6 +39,9 @@ class _007::Object { method truthy { truthy(self) } } +class _007::Object::Enum is _007::Object { +} + class _007::Object::Wrapped is _007::Object { has $.value; @@ -58,9 +61,9 @@ class _007::Object::Wrapped is _007::Object { } } -constant NONE is export = _007::Object.new(:type(TYPE)); -constant TRUE is export = _007::Object.new(:type(TYPE)); -constant FALSE is export = _007::Object.new(:type(TYPE)); +constant NONE is export = _007::Object::Enum.new(:type(TYPE)); +constant TRUE is export = _007::Object::Enum.new(:type(TYPE)); +constant FALSE is export = _007::Object::Enum.new(:type(TYPE)); sub truthy($v) { $v !=== NONE && $v !=== FALSE From 3816fa691f27425e49cc348edad3f166d931b1dc Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 27 Aug 2017 16:09:56 +0200 Subject: [PATCH 14/91] asset-capture Val::Exception --- lib/_007/Q.pm | 13 +++++++++---- lib/_007/Val.pm | 26 ++++++++++++++++++-------- 2 files changed, 27 insertions(+), 12 deletions(-) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index e1c3ad89..ecb016c3 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -212,6 +212,11 @@ class Q::Term::Object does Q::Term { method eval($runtime) { my $type = $runtime.get-var($.type.name.value, $.type.frame); + if $type === TYPE { + return $type.create(|hash($.propertylist.properties.value.map(-> $property { + $property.key.value => $property.value.eval($runtime) + }))); + } if $type ~~ _007::Type { my $value = $.propertylist.properties.value[0].value.eval($runtime); # XXX: cheat less @@ -999,12 +1004,12 @@ class Q::Statement::Throw does Q::Statement { method run($runtime) { my $value = $.expr ~~ _007::Object && $.expr.type === TYPE - ?? Val::Exception.new(:message(sevenize("Died"))) + ?? TYPE.create(:message(sevenize("Died"))) !! $.expr.eval($runtime); - die X::TypeCheck.new(:got($value), :excpected(Val::Exception)) - if $value !~~ Val::Exception; + die X::TypeCheck.new(:got($value), :expected(_007::Object)) + unless $value ~~ _007::Object && $value.type === TYPE; - die X::_007::RuntimeException.new(:msg($value.message.value)); + die X::_007::RuntimeException.new(:msg($value.properties.value)); } } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 4ff5c359..efa285ca 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -7,9 +7,11 @@ class X::Uninstantiable is Exception { } class Helper { ... } +class _007::Object::Class { ... } class _007::Type { has $.name; + has @.fields; method attributes { () } @@ -18,11 +20,17 @@ class _007::Type { my %*stringification-seen; Helper::Str(self); } + + method create(*%properties) { + # XXX: need to check %properties agains @.fields + return _007::Object::Class.new(:type(self), :%properties); + } } constant TYPE = hash(.map(-> $name { $name => _007::Type.new(:$name) })); +TYPE = _007::Type.new(:name, :fields["message"]); class _007::Object { has $.type; @@ -39,6 +47,10 @@ class _007::Object { method truthy { truthy(self) } } +class _007::Object::Class is _007::Object { + has %.properties; +} + class _007::Object::Enum is _007::Object { } @@ -403,17 +415,15 @@ class Helper { when Val::Type { "" } when _007::Type { "" } when _007::Object { - .type === TYPE - ?? "None" - !! .type === TYPE - ?? ($_ === TRUE ?? "True" !! "False") - !! .type === TYPE - ?? .quoted-Str - !! .value.Str + when .type === TYPE { "None" } + when .type === TYPE { $_ === TRUE ?? "True" !! "False" } + when .type === TYPE { .quoted-Str } + when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when _007::Object::Wrapped { .value.Str } + default { die "Unexpected type ", .^name } } 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 ({$self.^name})" From e7d9169330ddc5c08e71452db9a8854c4f2b017b Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 27 Aug 2017 16:12:13 +0200 Subject: [PATCH 15/91] remove Val::Exception --- lib/_007/Val.pm | 9 --------- 1 file changed, 9 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index efa285ca..eb3daa18 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -399,15 +399,6 @@ 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 _007::Object $.message; -} - class Helper { our sub Str($_) { when Val::Regex { .quoted-Str } From 6182b03cfef8f744b8462cb3b415d234c354d42e Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 30 Aug 2017 22:10:12 +0200 Subject: [PATCH 16/91] asset-capture Val::Object And introduce Dict in the process! --- lib/_007/Builtins.pm | 29 ++-- lib/_007/Linter.pm | 2 +- lib/_007/Parser/Actions.pm | 49 +++---- lib/_007/Parser/Syntax.pm | 5 +- lib/_007/Q.pm | 28 +++- lib/_007/Runtime.pm | 61 ++++---- lib/_007/Test.pm | 11 +- lib/_007/Val.pm | 52 +++---- t/features/assignment.t | 6 +- t/features/builtins/methods.t | 8 +- t/features/builtins/operators.t | 22 +-- t/features/if-statement.t | 10 +- t/features/objects.t | 241 -------------------------------- t/self-host/sanity.t | 2 +- 14 files changed, 152 insertions(+), 374 deletions(-) delete mode 100644 t/features/objects.t diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 4306643f..63936726 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -34,6 +34,19 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return [&&] $l.value == $r.value, |(^$l.value).map(&equal-at-index); } + elsif $type === TYPE { + if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { + return $l === $r; + } + %*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 $type === TYPE { return True; } @@ -41,22 +54,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return $l === $r; } else { - die "Unknown type ", $type.Str; - } - } - multi equal-value(Val::Object $l, Val::Object $r) { - if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { - return $l === $r; + die "Unknown type ", $type.^name; } - %*equality-seen{$l.WHICH}++; - %*equality-seen{$r.WHICH}++; - - sub equal-at-key(Str $key) { - equal-value($l.properties{$key}, $r.properties{$key}); - } - - [&&] $l.properties.keys.sort.perl eq $r.properties.keys.sort.perl, - |($l.properties.keys).map(&equal-at-key); } multi equal-value(_007::Type $l, _007::Type $r) { $l === $r } multi equal-value(Val::Type $l, Val::Type $r) { diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 58cfd51c..d341dbb4 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -88,7 +88,7 @@ class _007::Linter { sub ref(Str $name) { for @blocks.reverse -> $block { my $pad = $block.static-lexpad; - if $pad.properties{$name} { + if $pad.value{$name} { return "{$block.WHICH.Str}|$name"; } } diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 73b134dd..f62b0fcb 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -74,7 +74,7 @@ class X::Property::Duplicate is Exception { class _007::Parser::Actions { method finish-block($block) { - $block.static-lexpad = $*runtime.current-frame.properties; + $block.static-lexpad = $*runtime.current-frame.value; $*runtime.leave; } @@ -194,7 +194,7 @@ class _007::Parser::Actions { my $statementlist = $.ast; my $block = Q::Block.new(:$parameterlist, :$statementlist); - my $static-lexpad = $*runtime.current-frame.properties; + my $static-lexpad = $*runtime.current-frame.value; self.finish-block($block); my $outer-frame = $*runtime.current-frame; @@ -637,8 +637,8 @@ class _007::Parser::Actions { my $block = Q::Block.new(:$parameterlist, :$statementlist); if $ { my $name = $.ast.name; - my $outer-frame = $*runtime.current-frame.properties; - my $static-lexpad = $*runtime.current-frame.properties; + my $outer-frame = $*runtime.current-frame.value; + my $static-lexpad = $*runtime.current-frame.value; my $val = Val::Sub.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); $.ast.put-value($val, $*runtime); } @@ -669,36 +669,31 @@ class _007::Parser::Actions { # XXX: need to figure out how to do the corresponding error handling here # something with .fields, most likely? } - elsif $type-obj !=== Val::Object { - sub aname($attr) { $attr.name.substr(2) } - my %known-properties = $type-obj.attributes.map({ aname($_) => 1 }); - for $.ast.properties.value -> $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.value».key».value); - } - } + # XXX: Need some way to detect undeclared or required properties with _007::Type +# sub aname($attr) { $attr.name.substr(2) } +# my %known-properties = $type-obj.attributes.map({ aname($_) => 1 }); +# for $.ast.value.value -> $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.value.value».key».value); +# } make Q::Term::Object.new( :type(Q::Identifier.new(:name(sevenize($type)))), :propertylist($.ast)); } - method term:object ($/) { - my $type = "Object"; - my $name = sevenize($type); - my $frame = $*runtime.builtin-frame; - - make Q::Term::Object.new( - :type(Q::Identifier.new(:$name, :$frame)), + method term:dict ($/) { + make Q::Term::Dict.new( :propertylist($.ast)); } diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index b4fe00db..11ca5055 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -19,7 +19,7 @@ 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, sevenize({}), Q::StatementList.new); } } token finishpad { { @@ -201,6 +201,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> '}' @@ -221,7 +222,7 @@ grammar _007::Parser::Syntax { ) ~~ Val::Type | _007::Type }> <.ws> '{' ~ '}' } - token term:object { + token term:dict { '{' ~ '}' } token term:identifier { diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index ecb016c3..2ed1a4e2 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -228,6 +228,19 @@ class Q::Term::Object does Q::Term { } } +### ### Q::Term::Dict +### +### An dictionary. Dict terms consist of a property list +### with zero or more key/value pairs. +### +class Q::Term::Dict does Q::Term { + has $.propertylist; + + method eval($runtime) { + return sevenize(hash($.propertylist.properties.value.map({ .key.value => .value.eval($runtime) }))); + } +} + ### ### Q::Property ### ### An object property. Properties have a key and a value. @@ -315,7 +328,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { class Q::Block does Q { has $.parameterlist; has $.statementlist; - has Val::Object $.static-lexpad is rw = Val::Object.new; + has _007::Object::Wrapped $.static-lexpad is rw = sevenize({}); method attribute-order { } } @@ -600,7 +613,7 @@ class Q::Postfix::Index is Q::Postfix { if $index.value < 0; return .value[$index.value]; } - when Val::Object | Val::Sub | Q { + if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Val::Sub || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.type === TYPE; @@ -624,12 +637,13 @@ class Q::Postfix::Index is Q::Postfix { .value[$index.value] = $value; return; } - when Val::Object | Q { + if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.type === TYPE; my $propname = $property.value; $runtime.put-property($_, $propname, $value); + return; } die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); } @@ -673,9 +687,10 @@ class Q::Postfix::Property is Q::Postfix { method put-value($value, $runtime) { given $.operand.eval($runtime) { - when Val::Object | Q { + if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Q { my $propname = $.property.name.value; $runtime.put-property($_, $propname, $value); + return; } die "We don't handle this case yet"; # XXX: think more about this case } @@ -737,8 +752,9 @@ class Q::Term::Quasi does Q::Term { return $thing if $thing ~~ _007::Object; # XXX: won't hold true for everything - return $thing.new(:properties(%($thing.properties.map({ .key => interpolate(.value) })))) - if $thing ~~ Val::Object; + sub interpolate-entry($_) { .key => interpolate(.value) } + return sevenize(hash($thing.value.map(&interpolate-entry))) + if $thing ~~ _007::Object && $thing.type === TYPE; return $thing if $thing ~~ Val; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index b73d4e62..50ac2a56 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -3,7 +3,7 @@ use _007::Q; use _007::Builtins; use _007::OpScope; -constant NO_OUTER = Val::Object.new; +constant NO_OUTER = sevenize({}); constant RETURN_TO = Q::Identifier.new( :name(sevenize("--RETURN-TO--")), :frame(NONE)); @@ -16,7 +16,7 @@ class _007::Runtime { has $.builtin-frame; submethod BUILD(:$!input, :$!output) { - self.enter(NO_OUTER, Val::Object.new, Q::StatementList.new); + self.enter(NO_OUTER, sevenize({}), Q::StatementList.new); $!builtin-frame = @!frames[*-1]; $!builtin-opscope = _007::OpScope.new; self.load-builtins; @@ -32,9 +32,12 @@ 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 = sevenize({ + :$outer-frame, + :pad(sevenize({})) + }); @!frames.push($frame); - for $static-lexpad.properties.kv -> $name, $value { + for $static-lexpad.value.kv -> $name, $value { my $identifier = Q::Identifier.new( :name(sevenize($name)), :frame(NONE)); @@ -89,9 +92,9 @@ class _007::Runtime { $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; @@ -103,26 +106,26 @@ class _007::Runtime { ?? self.current-frame !! $identifier.frame; 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 ~~ _007::Object && $identifier.frame.type === TYPE + my _007::Object::Wrapped $frame = $identifier.frame ~~ _007::Object && $identifier.frame.type === TYPE ?? self.current-frame !! $identifier.frame; - $frame.properties.properties{$name} = $value // NONE; + $frame.value.value{$name} = $value // NONE; } method declared($name) { @@ -132,7 +135,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 { @@ -197,8 +200,9 @@ class _007::Runtime { return sevenize($thing.value.map(&interpolate)) if $thing ~~ _007::Object && $thing.type === TYPE; - return $thing.new(:properties(%($thing.properties.map(.key => interpolate(.value))))) - if $thing ~~ Val::Object; + sub interpolate-entry($_) { .key => interpolate(.value) } + return sevenize(hash($thing.value.map(&interpolate-entry))) + if $thing ~~ _007::Object && $thing.type === TYPE; return $thing if $thing ~~ Val; @@ -300,9 +304,9 @@ class _007::Runtime { return sevenize($obj.value.join($sep.value.Str)); }); } - elsif $obj ~~ Val::Object && $propname eq "size" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { return builtin(sub size() { - return sevenize($obj.properties.elems); + return sevenize($obj.value.elems); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "split" { @@ -433,9 +437,12 @@ class _007::Runtime { elsif $obj ~~ Val::Sub && $propname eq any { return $obj."$propname"(); } - elsif $obj ~~ (Q | Val::Object) && ($obj.properties{$propname} :exists) { + elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { return $obj.properties{$propname}; } + elsif $obj ~~ _007::Object && $obj.type === TYPE && ($obj.value{$propname} :exists) { + return $obj.value{$propname}; + } elsif $propname eq "get" { return builtin(sub get($prop) { return self.property($obj, $prop.value); @@ -443,7 +450,7 @@ class _007::Runtime { } elsif $propname eq "keys" { return builtin(sub keys() { - return sevenize($obj.properties.keys.map(&sevenize)); + return sevenize($obj.value.keys.map(&sevenize)); }); } elsif $propname eq "has" { @@ -452,22 +459,22 @@ class _007::Runtime { # both Q objects, which are still hard-coded into the # substrate, and the special-cased properties # - my $value = $obj.properties{$prop.value} :exists; + my $value = $obj.value{$prop.value} :exists; return sevenize($value); }); } elsif $propname eq "update" { return builtin(sub update($newprops) { - for $obj.properties.keys { - $obj.properties{$_} = $newprops.properties{$_} // $obj.properties{$_}; + for $obj.value.keys { + $obj.value{$_} = $newprops.value{$_} // $obj.value{$_}; } return $obj; }); } elsif $propname eq "extend" { return builtin(sub extend($newprops) { - for $newprops.properties.keys { - $obj.properties{$_} = $newprops.properties{$_}; + for $newprops.value.keys { + $obj.value{$_} = $newprops.value{$_}; } return $obj; }); @@ -485,11 +492,11 @@ class _007::Runtime { 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"; + elsif $obj !~~ _007::Object || $obj.type !=== TYPE { + 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 42b0488d..29901b3b 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -17,6 +17,7 @@ sub read(Str $ast) is export { int => Q::Literal::Int, str => Q::Literal::Str, array => Q::Term::Array, + dict => Q::Term::Dict, object => Q::Term::Object, regex => Q::Term::Regex, sub => Q::Term::Sub, @@ -207,7 +208,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { 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; + $block.block.static-lexpad = $runtime.current-frame.value; $runtime.leave(); } @@ -219,7 +220,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { :statementlist($sub.block.statementlist), :$outer-frame ); - $runtime.enter($outer-frame, Val::Object.new, $sub.block.statementlist, $val); + $runtime.enter($outer-frame, sevenize({}), $sub.block.statementlist, $val); handle($sub.block); $runtime.leave(); @@ -234,7 +235,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { :statementlist($macro.block.statementlist), :$outer-frame ); - $runtime.enter($outer-frame, Val::Object.new, $macro.block.statementlist, $val); + $runtime.enter($outer-frame, sevenize({}), $macro.block.statementlist, $val); handle($macro.block); $runtime.leave(); @@ -254,10 +255,10 @@ sub check(Q::CompUnit $ast, $runtime) is export { } multi handle(Q::Block $block) { - $runtime.enter($runtime.current-frame, Val::Object.new, Q::StatementList.new); + $runtime.enter($runtime.current-frame, sevenize({}), Q::StatementList.new); handle($block.parameterlist); handle($block.statementlist); - $block.static-lexpad = $runtime.current-frame.properties; + $block.static-lexpad = $runtime.current-frame.value; $runtime.leave(); } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index eb3daa18..fbf1f996 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -9,9 +9,12 @@ class X::Uninstantiable is Exception { class Helper { ... } class _007::Object::Class { ... } +sub unique-id { ++$ } + class _007::Type { has $.name; has @.fields; + # XXX: $.id method attributes { () } @@ -27,13 +30,14 @@ class _007::Type { } } -constant TYPE = hash(.map(-> $name { +constant TYPE = hash(.map(-> $name { $name => _007::Type.new(:$name) })); TYPE = _007::Type.new(:name, :fields["message"]); class _007::Object { has $.type; + has $.id = unique-id; method attributes { () } @@ -69,6 +73,17 @@ class _007::Object::Wrapped is _007::Object { } return "[" ~ @($.value)».quoted-Str.join(', ') ~ "]"; } + if $.type === TYPE { + if %*stringification-seen{self.WHICH}++ { + return "\{...\}"; + } + return '{' ~ %.value.map({ + my $key = .key ~~ /^ [\w+]+ % '::'$/ + ?? .key + !! sevenize(.key).quoted-Str; + "{$key}: {.value.quoted-Str}" + }).sort.join(', ') ~ '}'; + } return self.Str; } } @@ -94,6 +109,9 @@ sub sevenize($value) is export { 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; } @@ -154,23 +172,7 @@ our $global-object-id = 0; ### 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({})); # --> `` +### say(type({})); # --> `` ### ### There are also two ways to create a new, similar object from an old one. ### @@ -253,7 +255,7 @@ class Val::Object does Val { ### ### say(type(007)); # --> `` ### say(type("Bond")); # --> `` -### say(type({})); # --> `` +### say(type({})); # --> `` ### say(type(type({}))); # --> `` ### ### 007 comes with a number of built-in types: `NoneType`, `Bool`, `Int`, @@ -306,10 +308,8 @@ class Val::Type does Val { } method create(@properties) { - if $.type ~~ Val::Object { - return $.type.new(:@properties); - } - elsif $.type ~~ _007::Object { + # XXX: there used to be a Val__Object case here + if $.type ~~ _007::Object { return $.type.new(:value(@properties[0].value.value)); } elsif $.type ~~ Val::Type { @@ -355,8 +355,8 @@ class Val::Sub is Val { has &.hook = Callable; has $.parameterlist; has $.statementlist; - has Val::Object $.static-lexpad is rw = Val::Object.new; - has Val::Object $.outer-frame; + has _007::Object::Wrapped $.static-lexpad is rw = sevenize({}); + has _007::Object::Wrapped $.outer-frame; method new-builtin(&hook, Str $name, $parameterlist, $statementlist) { self.bless(:name(sevenize($name)), :&hook, :$parameterlist, :$statementlist); @@ -402,13 +402,13 @@ class Val::Macro is Val::Sub { class Helper { our sub Str($_) { when Val::Regex { .quoted-Str } - when Val::Object { .quoted-Str } when Val::Type { "" } when _007::Type { "" } when _007::Object { when .type === TYPE { "None" } when .type === TYPE { $_ === TRUE ?? "True" !! "False" } when .type === TYPE { .quoted-Str } + when .type === TYPE { .quoted-Str } when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } 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 96a6f413..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"; } { diff --git a/t/features/builtins/operators.t b/t/features/builtins/operators.t index 0ef79d6d..7c1646a5 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")))))) @@ -630,10 +630,10 @@ use _007::Test; { 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 +642,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/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 deleted file mode 100644 index 22cda14c..00000000 --- a/t/features/objects.t +++ /dev/null @@ -1,241 +0,0 @@ -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" }; - - say(q.name); - . - - outputs - $program, - qq[foo\n], - "object literal syntax prefixed by type"; -} - -{ - my $program = q:to/./; - my q = new Q::Identifier { dunnexist: "foo" }; - . - - parse-error - $program, - X::Property::NotDeclared, - "the object property doesn't exist on that type"; -} - -{ - my $program = q:to/./; - my q = new Q::Identifier { name: "foo" }; - - say(type(q)); - . - - outputs - $program, - qq[\n], - "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] }; - - say(i == 7); - say(s == "Bond"); - say(a == [0, 0, 7]); - . - - outputs - $program, - qq[True\nTrue\nTrue\n], - "can create normal Val:: objects using typed object literals"; -} - -{ - my $program = q:to/./; - my q = new Q::Identifier {}; - . - - parse-error - $program, - X::Property::Required, - "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/self-host/sanity.t b/t/self-host/sanity.t index 813a6aea..c0475731 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.block.static-lexpad.value = $compunit; $runtime.run($ast); return $output.result; } From 383cf08a4c14fe3b8aee5cd225b66ba26753be47 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 30 Aug 2017 22:12:37 +0200 Subject: [PATCH 17/91] remove Val::Object --- lib/_007/Val.pm | 93 ------------------------------------------------- 1 file changed, 93 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index fbf1f996..891a99a3 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -154,99 +154,6 @@ class Val::Regex does Val { } } -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` -### -### 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 - !! sevenize(.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 From 1f610aaf295072f5a4b3760a2aa1e69a9e364c57 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 31 Aug 2017 21:58:47 +0200 Subject: [PATCH 18/91] remove unuser &wrap subroutine --- lib/_007/Builtins.pm | 7 ------- 1 file changed, 7 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 63936726..5f2fc011 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -2,13 +2,6 @@ use _007::Val; use _007::Q; sub builtins(:$input!, :$output!, :$opscope!) is export { - sub wrap($_) { - when _007::Object { $_ } - when Val | Q { $_ } - when Str { die "A Str was sent to &wrap" } - default { die "Got some unknown value of type ", .^name } - } - # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } multi equal-value(_007::Object $l, _007::Object $r) { From 118e6d2688822998c0de80de4cb99d9f6af02e83 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 31 Aug 2017 22:03:54 +0200 Subject: [PATCH 19/91] rename s/sevenize/wrap/g --- lib/_007/Builtins.pm | 62 +++++++++++++-------------- lib/_007/OpScope.pm | 2 +- lib/_007/Parser/Actions.pm | 34 +++++++-------- lib/_007/Parser/Syntax.pm | 4 +- lib/_007/Q.pm | 16 +++---- lib/_007/Runtime.pm | 86 +++++++++++++++++++------------------- lib/_007/Test.pm | 16 +++---- lib/_007/Val.pm | 10 ++--- 8 files changed, 115 insertions(+), 115 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 5f2fc011..48ff1cad 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -127,7 +127,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { prompt => sub ($arg) { $output.print($arg); $output.flush(); - return sevenize($input.get()); + return wrap($input.get()); }, type => sub ($arg) { $arg ~~ _007::Type @@ -163,21 +163,21 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:==' => op( sub ($lhs, $rhs) { my %*equality-seen; - return sevenize(equal-value($lhs, $rhs)); + return wrap(equal-value($lhs, $rhs)); }, :qtype(Q::Infix::Eq), ), 'infix:!=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return sevenize(!equal-value($lhs, $rhs)) + return wrap(!equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Ne), :precedence{ equal => "infix:==" }, ), 'infix:<' => op( sub ($lhs, $rhs) { - return sevenize(less-value($lhs, $rhs)) + return wrap(less-value($lhs, $rhs)) }, :qtype(Q::Infix::Lt), :precedence{ equal => "infix:==" }, @@ -185,14 +185,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:<=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return sevenize(less-value($lhs, $rhs) || equal-value($lhs, $rhs)) + return wrap(less-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Le), :precedence{ equal => "infix:==" }, ), 'infix:>' => op( sub ($lhs, $rhs) { - return sevenize(more-value($lhs, $rhs) ) + return wrap(more-value($lhs, $rhs) ) }, :qtype(Q::Infix::Gt), :precedence{ equal => "infix:==" }, @@ -200,7 +200,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:>=' => op( sub ($lhs, $rhs) { my %*equality-seen; - return sevenize(more-value($lhs, $rhs) || equal-value($lhs, $rhs)) + return wrap(more-value($lhs, $rhs) || equal-value($lhs, $rhs)) }, :qtype(Q::Infix::Ge), :precedence{ equal => "infix:==" }, @@ -208,13 +208,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return sevenize($lhs ~~ _007::Object && $lhs.type === $rhs); + return wrap($lhs ~~ _007::Object && $lhs.type === $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type; - return sevenize($lhs ~~ $rhs.type); + return wrap($lhs ~~ $rhs.type); }, :qtype(Q::Infix::TypeMatch), :precedence{ equal => "infix:==" }, @@ -222,13 +222,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:!~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return sevenize($lhs !~~ _007::Object || $lhs.type !=== $rhs); + return wrap($lhs !~~ _007::Object || $lhs.type !=== $rhs); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) unless $rhs ~~ Val::Type | _007::Type; - return sevenize($lhs !~~ $rhs.type); + return wrap($lhs !~~ $rhs.type); }, :qtype(Q::Infix::TypeNonMatch), :precedence{ equal => "infix:==" }, @@ -239,7 +239,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<::>, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize([$lhs, |$rhs.value]); + return wrap([$lhs, |$rhs.value]); }, :qtype(Q::Infix::Cons), :assoc, @@ -252,7 +252,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize($lhs.value + $rhs.value); + return wrap($lhs.value + $rhs.value); }, :qtype(Q::Infix::Addition), ), @@ -262,7 +262,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize($lhs.value ~ $rhs.value); + return wrap($lhs.value ~ $rhs.value); }, :qtype(Q::Infix::Concat), :precedence{ equal => "infix:+" }, @@ -273,7 +273,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize($lhs.value - $rhs.value); + return wrap($lhs.value - $rhs.value); }, :qtype(Q::Infix::Subtraction), ), @@ -285,7 +285,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize($lhs.value * $rhs.value); + return wrap($lhs.value * $rhs.value); }, :qtype(Q::Infix::Multiplication), ), @@ -297,7 +297,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.type === TYPE; die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; - return sevenize($lhs.value % $rhs.value); + return wrap($lhs.value % $rhs.value); }, :qtype(Q::Infix::Modulo), ), @@ -309,7 +309,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.type === TYPE; die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; - return sevenize($lhs.value %% $rhs.value); + return wrap($lhs.value %% $rhs.value); }, :qtype(Q::Infix::Divisibility), ), @@ -319,7 +319,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize($lhs.value x $rhs.value); + return wrap($lhs.value x $rhs.value); }, :qtype(Q::Infix::Replicate), :precedence{ equal => "infix:*" }, @@ -330,7 +330,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $lhs ~~ _007::Object && $lhs.type === TYPE; die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) unless $rhs ~~ _007::Object && $rhs.type === TYPE; - return sevenize(| $lhs.value xx $rhs.value); + return wrap(| $lhs.value xx $rhs.value); }, :qtype(Q::Infix::ArrayReplicate), :precedence{ equal => "infix:*" }, @@ -338,14 +338,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # prefixes 'prefix:~' => op( - sub prefix-str($expr) { sevenize($expr.Str) }, + sub prefix-str($expr) { wrap($expr.Str) }, :qtype(Q::Prefix::Str), ), 'prefix:+' => op( sub prefix-plus($expr) { if $expr ~~ _007::Object { if $expr.type === TYPE { - return sevenize($expr.value.Int) + return wrap($expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } elsif $expr.type === TYPE { @@ -363,11 +363,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { sub prefix-minus($expr) { if $expr ~~ _007::Object { if $expr.type === TYPE { - return sevenize(-$expr.value.Int) + return wrap(-$expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } elsif $expr.type === TYPE { - return sevenize(-$expr.value); + return wrap(-$expr.value); } } die X::TypeCheck.new( @@ -379,13 +379,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:?' => op( sub ($a) { - return sevenize(?$a.truthy) + return wrap(?$a.truthy) }, :qtype(Q::Prefix::So), ), 'prefix:!' => op( sub ($a) { - return sevenize(!$a.truthy) + return wrap(!$a.truthy) }, :qtype(Q::Prefix::Not), ), @@ -393,7 +393,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { sub ($n) { die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) unless $n ~~ _007::Object && $n.type === TYPE; - return sevenize([(^$n.value).map(&sevenize)]); + return wrap([(^$n.value).map(&wrap)]); }, :qtype(Q::Prefix::Upto), ), @@ -437,7 +437,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(sevenize($^value))))) }; + my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(wrap($^value))))) }; return @builtins.map: { when .value ~~ _007::Type | Val::Type { @@ -445,7 +445,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } when .value ~~ Block { my @elements = .value.signature.params».name».&ditch-sigil».¶meter; - my $parameters = sevenize(@elements); + my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(.value, .key, $parameterlist, $statementlist); @@ -454,7 +454,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my $name = .key; install-op($name, .value); my @elements = .value.qtype.attributes».name».substr(2).grep({ $_ ne "identifier" })».¶meter; - my $parameters = sevenize(@elements); + my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(sub () {}, $name, $parameterlist, $statementlist); @@ -464,7 +464,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { install-op($name, .value); my &fn = .value.fn; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameters = sevenize(@elements); + my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); .key => Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 18787288..677bbe2e 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -15,7 +15,7 @@ class _007::OpScope { method install($type, $op, $q?, :%precedence, :$assoc) { my $name = "$type:$op"; - my $identifier = Q::Identifier.new(:name(sevenize($name))); + my $identifier = Q::Identifier.new(:name(wrap($name))); %!ops{$type}{$op} = $q !=== Any ?? $q !! { prefix => Q::Prefix.new(:$identifier), diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index f62b0fcb..68be7df6 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -92,7 +92,7 @@ class _007::Parser::Actions { } method statementlist($/) { - my $statements = sevenize($».ast); + my $statements = wrap($».ast); make Q::StatementList.new(:$statements); } @@ -120,7 +120,7 @@ class _007::Parser::Actions { # in the expression tree if $.ast ~~ Q::Block { make Q::Statement::Expr.new(:expr(Q::Postfix::Call.new( - :identifier(Q::Identifier.new(:name(sevenize("postfix:()")))), + :identifier(Q::Identifier.new(:name(wrap("postfix:()")))), :operand(Q::Term::Sub.new(:identifier(NONE), :block($.ast))), :argumentlist(Q::ArgumentList.new) ))); @@ -266,7 +266,7 @@ class _007::Parser::Actions { my $trait = $p.key; die X::Trait::Duplicate.new(:$trait); } - my $traits = sevenize(@traits); + my $traits = wrap(@traits); make Q::TraitList.new(:$traits); } method trait($/) { @@ -320,11 +320,11 @@ class _007::Parser::Actions { } else { if $expansion ~~ Q::Statement { - my $statements = sevenize([$expansion]); + my $statements = wrap([$expansion]); $expansion = Q::StatementList.new(:$statements); } elsif $expansion === NONE { - my $statements = sevenize([]); + my $statements = wrap([]); $expansion = Q::StatementList.new(:$statements); } @@ -508,7 +508,7 @@ class _007::Parser::Actions { method prefix($/) { my $op = ~$/; my $identifier = Q::Identifier.new( - :name(sevenize("prefix:$op")), + :name(wrap("prefix:$op")), :frame($*runtime.current-frame), ); make $*parser.opscope.ops{$op}.new(:$identifier, :operand(TYPE)); @@ -523,7 +523,7 @@ class _007::Parser::Actions { die X::String::Newline.new if $s ~~ /\n/; }(~$0); - my $value = sevenize((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); + my $value = wrap((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); make Q::Literal::Str.new(:$value); } @@ -540,7 +540,7 @@ class _007::Parser::Actions { } method term:int ($/) { - make Q::Literal::Int.new(:value(sevenize(+$/))); + make Q::Literal::Int.new(:value(wrap(+$/))); } method term:str ($/) { @@ -548,7 +548,7 @@ class _007::Parser::Actions { } method term:array ($/) { - my $elements = sevenize($».ast); + my $elements = wrap($».ast); make Q::Term::Array.new(:$elements); } @@ -580,7 +580,7 @@ class _007::Parser::Actions { } method term:quasi ($/) { - my $qtype = sevenize(~($ // "")); + my $qtype = wrap(~($ // "")); if $ -> $block { # If the quasi consists of a block with a single expression statement, it's very @@ -688,7 +688,7 @@ class _007::Parser::Actions { # } make Q::Term::Object.new( - :type(Q::Identifier.new(:name(sevenize($type)))), + :type(Q::Identifier.new(:name(wrap($type)))), :propertylist($.ast)); } @@ -705,7 +705,7 @@ class _007::Parser::Actions { if %seen{$property}++; } - my $properties = sevenize($».ast); + my $properties = wrap($».ast); make Q::PropertyList.new(:$properties); } @@ -737,7 +737,7 @@ class _007::Parser::Actions { method infix($/) { my $op = ~$/; my $identifier = Q::Identifier.new( - :name(sevenize("infix:$op")), + :name(wrap("infix:$op")), :frame($*runtime.current-frame), ); make $*parser.opscope.ops{$op}.new(:$identifier, :lhs(NONE), :rhs(NONE)); @@ -763,7 +763,7 @@ class _007::Parser::Actions { $op = "."; } my $identifier = Q::Identifier.new( - :name(sevenize("postfix:$op")), + :name(wrap("postfix:$op")), :frame($*runtime.current-frame), ); # XXX: this can't stay hardcoded forever, but we don't have the machinery yet @@ -791,17 +791,17 @@ class _007::Parser::Actions { $value ~~ s:g['\\»'] = '»'; $value ~~ s:g['\\\\'] = '\\'; }(); - my $name = sevenize($value); + my $name = wrap($value); make Q::Identifier.new(:$name); } method argumentlist($/) { - my $arguments = sevenize($».ast); + my $arguments = wrap($».ast); make Q::ArgumentList.new(:$arguments); } method parameterlist($/) { - my $parameters = sevenize($».ast); + my $parameters = wrap($».ast); make Q::ParameterList.new(:$parameters); } diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index 11ca5055..3db5d446 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -19,7 +19,7 @@ grammar _007::Parser::Syntax { token newpad { { $*parser.push-opscope; @*declstack.push(@*declstack ?? @*declstack[*-1].clone !! {}); - $*runtime.enter($*runtime.current-frame, sevenize({}), Q::StatementList.new); + $*runtime.enter($*runtime.current-frame, wrap({}), Q::StatementList.new); } } token finishpad { { @@ -41,7 +41,7 @@ grammar _007::Parser::Syntax { my $frame = $*runtime.current-frame(); die X::Redeclaration::Outer.new(:$symbol) if %*assigned{$frame.id ~ $symbol}; - my $name = sevenize($symbol); + my $name = wrap($symbol); my $identifier = Q::Identifier.new(:$name, :$frame); $*runtime.declare-var($identifier); @*declstack[*-1]{$symbol} = $decltype; diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 2ed1a4e2..c86f1926 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -53,7 +53,7 @@ class X::_007::RuntimeException is Exception { } } -sub empty-array() { sevenize([]) } +sub empty-array() { wrap([]) } sub aname($attr) { $attr.name.substr(2) } sub avalue($attr, $obj) { $attr.get_value($obj) } @@ -197,7 +197,7 @@ class Q::Term::Array does Q::Term { has _007::Object $.elements; method eval($runtime) { - sevenize($.elements.value.map(*.eval($runtime))); + wrap($.elements.value.map(*.eval($runtime))); } } @@ -237,7 +237,7 @@ class Q::Term::Dict does Q::Term { has $.propertylist; method eval($runtime) { - return sevenize(hash($.propertylist.properties.value.map({ .key.value => .value.eval($runtime) }))); + return wrap(hash($.propertylist.properties.value.map({ .key.value => .value.eval($runtime) }))); } } @@ -303,7 +303,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { method eval($runtime) { my $name = $.identifier ~~ _007::Object && $.identifier.type === TYPE - ?? sevenize("") + ?? wrap("") !! $.identifier.name; return Val::Sub.new( :$name, @@ -328,7 +328,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { class Q::Block does Q { has $.parameterlist; has $.statementlist; - has _007::Object::Wrapped $.static-lexpad is rw = sevenize({}); + has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); method attribute-order { } } @@ -746,14 +746,14 @@ class Q::Term::Quasi does Q::Term { method eval($runtime) { sub interpolate($thing) { - return sevenize($thing.value.map(&interpolate)) + return wrap($thing.value.map(&interpolate)) if $thing ~~ _007::Object && $thing.type === TYPE; return $thing if $thing ~~ _007::Object; # XXX: won't hold true for everything sub interpolate-entry($_) { .key => interpolate(.value) } - return sevenize(hash($thing.value.map(&interpolate-entry))) + return wrap(hash($thing.value.map(&interpolate-entry))) if $thing ~~ _007::Object && $thing.type === TYPE; return $thing @@ -1020,7 +1020,7 @@ class Q::Statement::Throw does Q::Statement { method run($runtime) { my $value = $.expr ~~ _007::Object && $.expr.type === TYPE - ?? TYPE.create(:message(sevenize("Died"))) + ?? TYPE.create(:message(wrap("Died"))) !! $.expr.eval($runtime); die X::TypeCheck.new(:got($value), :expected(_007::Object)) unless $value ~~ _007::Object && $value.type === TYPE; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 50ac2a56..73ff8232 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -3,9 +3,9 @@ use _007::Q; use _007::Builtins; use _007::OpScope; -constant NO_OUTER = sevenize({}); +constant NO_OUTER = wrap({}); constant RETURN_TO = Q::Identifier.new( - :name(sevenize("--RETURN-TO--")), + :name(wrap("--RETURN-TO--")), :frame(NONE)); class _007::Runtime { @@ -16,7 +16,7 @@ class _007::Runtime { has $.builtin-frame; submethod BUILD(:$!input, :$!output) { - self.enter(NO_OUTER, sevenize({}), Q::StatementList.new); + self.enter(NO_OUTER, wrap({}), Q::StatementList.new); $!builtin-frame = @!frames[*-1]; $!builtin-opscope = _007::OpScope.new; self.load-builtins; @@ -32,14 +32,14 @@ class _007::Runtime { } method enter($outer-frame, $static-lexpad, $statementlist, $routine?) { - my $frame = sevenize({ + my $frame = wrap({ :$outer-frame, - :pad(sevenize({})) + :pad(wrap({})) }); @!frames.push($frame); for $static-lexpad.value.kv -> $name, $value { my $identifier = Q::Identifier.new( - :name(sevenize($name)), + :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); } @@ -146,7 +146,7 @@ class _007::Runtime { my $opscope = $!builtin-opscope; for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { my $identifier = Q::Identifier.new( - :name(sevenize($name)), + :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); } @@ -182,9 +182,9 @@ class _007::Runtime { sub builtin(&fn) { my $name = &fn.name; my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(sevenize($^value))))) }; + my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(wrap($^value))))) }; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameters = sevenize(@elements); + my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); return Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); @@ -197,11 +197,11 @@ class _007::Runtime { sub avalue($attr, $obj) { $attr.get_value($obj) } sub interpolate($thing) { - return sevenize($thing.value.map(&interpolate)) + return wrap($thing.value.map(&interpolate)) if $thing ~~ _007::Object && $thing.type === TYPE; sub interpolate-entry($_) { .key => interpolate(.value) } - return sevenize(hash($thing.value.map(&interpolate-entry))) + return wrap(hash($thing.value.map(&interpolate-entry))) if $thing ~~ _007::Object && $thing.type === TYPE; return $thing @@ -239,90 +239,90 @@ class _007::Runtime { } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "abs" { return builtin(sub abs() { - return sevenize($obj.value.abs); + return wrap($obj.value.abs); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chr" { return builtin(sub chr() { - return sevenize($obj.value.chr); + return wrap($obj.value.chr); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "ord" { return builtin(sub ord() { - return sevenize($obj.value.ord); + return wrap($obj.value.ord); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chars" { return builtin(sub chars() { - return sevenize($obj.value.chars); + return wrap($obj.value.chars); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "uc" { return builtin(sub uc() { - return sevenize($obj.value.uc); + return wrap($obj.value.uc); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "lc" { return builtin(sub lc() { - return sevenize($obj.value.lc); + return wrap($obj.value.lc); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "trim" { return builtin(sub trim() { - return sevenize($obj.value.trim); + return wrap($obj.value.trim); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { return builtin(sub size() { - return sevenize($obj.value.elems); + return wrap($obj.value.elems); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "reverse" { return builtin(sub reverse() { - return sevenize($obj.value.reverse); + return wrap($obj.value.reverse); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "sort" { return builtin(sub sort() { - return sevenize($obj.value.sort); + return wrap($obj.value.sort); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "shuffle" { return builtin(sub shuffle() { - return sevenize($obj.value.pick(*)); + return wrap($obj.value.pick(*)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "concat" { return builtin(sub concat($array) { die X::TypeCheck.new(:operation, :got($array), :expected(_007::Object)) unless $array ~~ _007::Object && $array.type === TYPE; - return sevenize([|$obj.value, |$array.value]); + return wrap([|$obj.value, |$array.value]); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "join" { return builtin(sub join($sep) { - return sevenize($obj.value.join($sep.value.Str)); + return wrap($obj.value.join($sep.value.Str)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { return builtin(sub size() { - return sevenize($obj.value.elems); + return wrap($obj.value.elems); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "split" { return builtin(sub split($sep) { - my @elements = $obj.value.split($sep.value).map(&sevenize); - return sevenize(@elements); + my @elements = $obj.value.split($sep.value).map(&wrap); + return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "index" { return builtin(sub index($substr) { - return sevenize($obj.value.index($substr.value) // -1); + return wrap($obj.value.index($substr.value) // -1); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "substr" { return builtin(sub substr($pos, $chars) { - return sevenize($obj.value.substr( + return wrap($obj.value.substr( $pos.value, $chars.value)); }); @@ -332,19 +332,19 @@ class _007::Runtime { die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) unless $substr ~~ _007::Object && $substr.type === TYPE; - return sevenize($obj.value.contains($substr.value)); + return wrap($obj.value.contains($substr.value)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "prefix" { return builtin(sub prefix($pos) { - return sevenize($obj.value.substr( + return wrap($obj.value.substr( 0, $pos.value)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "suffix" { return builtin(sub suffix($pos) { - return sevenize($obj.value.substr( + return wrap($obj.value.substr( $pos.value)); }); } @@ -355,7 +355,7 @@ class _007::Runtime { die X::Subscript::TooLarge.new(:value($pos.value), :length($s.chars)) if $pos.value >= $s.chars; - return sevenize($s.substr($pos.value, 1)); + return wrap($s.substr($pos.value, 1)); }); } elsif $obj ~~ Val::Regex && $propname eq "fullmatch" { @@ -365,7 +365,7 @@ class _007::Runtime { die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; - return sevenize($regex-string eq $str.value); + return wrap($regex-string eq $str.value); }); } elsif $obj ~~ Val::Regex && $propname eq "search" { @@ -375,19 +375,19 @@ class _007::Runtime { die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; - return sevenize($str.value.contains($regex-string)); + return wrap($str.value.contains($regex-string)); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { return builtin(sub filter($fn) { my @elements = $obj.value.grep({ self.call($fn, [$_]).truthy }); - return sevenize(@elements); + return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { return builtin(sub map($fn) { my @elements = $obj.value.map({ self.call($fn, [$_]) }); - return sevenize(@elements); + return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "push" { @@ -417,15 +417,15 @@ class _007::Runtime { }); } elsif $obj ~~ _007::Type && $propname eq "name" { - return sevenize($obj.name); + return wrap($obj.name); } elsif $obj ~~ Val::Type | _007::Type && $propname eq "name" { - return sevenize($obj.name); + return wrap($obj.name); } elsif $obj ~~ _007::Type && $propname eq "create" { return builtin(sub create($properties) { # XXX: needs more sanity checking - sevenize($properties.value[0].value[1].value); # XXX: won't work for non-wrapped objects + wrap($properties.value[0].value[1].value); # XXX: won't work for non-wrapped objects # _007::Object.new(:value($properties.value[0].value[1].value)); }); } @@ -450,7 +450,7 @@ class _007::Runtime { } elsif $propname eq "keys" { return builtin(sub keys() { - return sevenize($obj.value.keys.map(&sevenize)); + return wrap($obj.value.keys.map(&wrap)); }); } elsif $propname eq "has" { @@ -460,7 +460,7 @@ class _007::Runtime { # substrate, and the special-cased properties # my $value = $obj.value{$prop.value} :exists; - return sevenize($value); + return wrap($value); }); } elsif $propname eq "update" { @@ -481,7 +481,7 @@ class _007::Runtime { } elsif $propname eq "id" { # XXX: Make this work for Q-type objects, too. - return sevenize($obj.id); + return wrap($obj.id); } else { die X::Property::NotFound.new(:$propname, :$type); diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 29901b3b..8cc2ed88 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -8,7 +8,7 @@ use Test; sub read(Str $ast) is export { sub n($type, $op) { - my $name = sevenize($type ~ ":<$op>"); + my $name = wrap($type ~ ":<$op>"); return Q::Identifier.new(:$name); } @@ -109,7 +109,7 @@ sub read(Str $ast) is export { sub check-if-operator() { if $qname ~~ /^ [prefix | infix | postfix] ":"/ { # XXX: it stinks that we have to do this - my $name = sevenize($qname); + my $name = wrap($qname); %arguments = Q::Identifier.new(:$name); shift @attributes; # $.identifier } @@ -118,7 +118,7 @@ sub read(Str $ast) is export { if @attributes == 1 && (%qtype-has-just-array{$qtype.^name} :exists) { my $aname = aname(@attributes[0]); - %arguments{$aname} = sevenize(@rest); + %arguments{$aname} = wrap(@rest); } else { die "{+@rest} arguments passed, only {+@attributes} parameters expected for {$qtype.^name}" @@ -136,8 +136,8 @@ sub read(Str $ast) is export { make $qtype.new(|%arguments); } method expr:symbol ($/) { make ~$/ } - method expr:int ($/) { make sevenize(+$/) } - method expr:str ($/) { make sevenize((~$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) @@ -220,7 +220,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { :statementlist($sub.block.statementlist), :$outer-frame ); - $runtime.enter($outer-frame, sevenize({}), $sub.block.statementlist, $val); + $runtime.enter($outer-frame, wrap({}), $sub.block.statementlist, $val); handle($sub.block); $runtime.leave(); @@ -235,7 +235,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { :statementlist($macro.block.statementlist), :$outer-frame ); - $runtime.enter($outer-frame, sevenize({}), $macro.block.statementlist, $val); + $runtime.enter($outer-frame, wrap({}), $macro.block.statementlist, $val); handle($macro.block); $runtime.leave(); @@ -255,7 +255,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { } multi handle(Q::Block $block) { - $runtime.enter($runtime.current-frame, sevenize({}), Q::StatementList.new); + $runtime.enter($runtime.current-frame, wrap({}), Q::StatementList.new); handle($block.parameterlist); handle($block.statementlist); $block.static-lexpad = $runtime.current-frame.value; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 891a99a3..6e424f9c 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -80,7 +80,7 @@ class _007::Object::Wrapped is _007::Object { return '{' ~ %.value.map({ my $key = .key ~~ /^ [\w+]+ % '::'$/ ?? .key - !! sevenize(.key).quoted-Str; + !! wrap(.key).quoted-Str; "{$key}: {.value.quoted-Str}" }).sort.join(', ') ~ '}'; } @@ -96,7 +96,7 @@ sub truthy($v) { $v !=== NONE && $v !=== FALSE } -sub sevenize($value) is export { +sub wrap($value) is export { if $value ~~ Bool { return $value ?? TRUE !! FALSE; } @@ -116,7 +116,7 @@ sub sevenize($value) is export { return NONE; } else { - die "Tried to sevenize unknown value ", $value.^name; + die "Tried to wrap unknown value ", $value.^name; } } @@ -262,11 +262,11 @@ class Val::Sub is Val { has &.hook = Callable; has $.parameterlist; has $.statementlist; - has _007::Object::Wrapped $.static-lexpad is rw = sevenize({}); + has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); has _007::Object::Wrapped $.outer-frame; method new-builtin(&hook, Str $name, $parameterlist, $statementlist) { - self.bless(:name(sevenize($name)), :&hook, :$parameterlist, :$statementlist); + self.bless(:name(wrap($name)), :&hook, :$parameterlist, :$statementlist); } method escaped-name { From 8f369ffc6130f5443d6ed2f31d7d5438a78fd6dc Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 3 Sep 2017 03:57:54 +0200 Subject: [PATCH 20/91] check for properties that they are declared as fields --- lib/_007/Parser/Actions.pm | 20 -------------------- lib/_007/Val.pm | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 36 insertions(+), 22 deletions(-) diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 68be7df6..93be72c2 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -52,26 +52,6 @@ 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" } -} - class _007::Parser::Actions { method finish-block($block) { $block.static-lexpad = $*runtime.current-frame.value; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 6e424f9c..95b67e4a 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -6,13 +6,33 @@ class X::Uninstantiable is Exception { 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 Helper { ... } class _007::Object::Class { ... } sub unique-id { ++$ } class _007::Type { - has $.name; + has Str $.name; has @.fields; # XXX: $.id @@ -25,7 +45,21 @@ class _007::Type { } method create(*%properties) { - # XXX: need to check %properties agains @.fields + my $type = $.name; + my $fields = set(@.fields); + my $seen = set(); + for %properties.keys.sort -> $property { + die X::Property::NotDeclared.new(:$type, :$property) + unless $property (elem) $fields; + + die X::Property::Duplicate.new(:$type, :$property) + if $property (elem) $seen; + + $seen (|)= $property; + } + # XXX: need to screen for required properties by traversing @.fields, but we don't have the + # infrastructure in terms of a way to mark up a field as required + return _007::Object::Class.new(:type(self), :%properties); } } From 30599b42d2983a7d7637bc1214ccbd7b66520a79 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 4 Sep 2017 12:55:11 +0200 Subject: [PATCH 21/91] Move .call from Runtime to Val::Sub --- lib/_007/Parser/Actions.pm | 2 +- lib/_007/Q.pm | 13 ++++--------- lib/_007/Runtime.pm | 30 ++---------------------------- lib/_007/Val.pm | 31 +++++++++++++++++++++++++++++++ 4 files changed, 38 insertions(+), 38 deletions(-) diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 93be72c2..8bcd9b95 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -289,7 +289,7 @@ class _007::Parser::Actions { } sub expand($macro, @arguments, &unexpanded-callback:()) { - my $expansion = $*runtime.call($macro, @arguments); + my $expansion = $macro.call($*runtime, @arguments); if $expansion ~~ Q::Statement::My { _007::Parser::Syntax::declare(Q::Statement::My, $expansion.identifier.name.value); diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index c86f1926..8dee42c8 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -1,10 +1,5 @@ use _007::Val; -class X::Control::Return is Exception { - has $.frame; - has $.value; -} - class X::Subscript::TooLarge is Exception { has $.value; has $.length; @@ -347,7 +342,7 @@ class Q::Prefix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$e]); + return $c.call($runtime, [$e]); } } @@ -404,7 +399,7 @@ class Q::Infix does Q::Expr { my $l = $.lhs.eval($runtime); my $r = $.rhs.eval($runtime); my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$l, $r]); + return $c.call($runtime, [$l, $r]); } } @@ -587,7 +582,7 @@ class Q::Postfix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - return $runtime.call($c, [$e]); + return $c.call($runtime, [$e]); } } @@ -666,7 +661,7 @@ class Q::Postfix::Call is Q::Postfix { die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: unless $c ~~ Val::Sub; my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); - return $runtime.call($c, @arguments); + return $c.call($runtime, @arguments); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 73ff8232..54201e06 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -152,32 +152,6 @@ class _007::Runtime { } } - method call(Val::Sub $c, @arguments) { - my $paramcount = $c.parameterlist.parameters.value.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.value) 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; @@ -380,13 +354,13 @@ class _007::Runtime { } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { return builtin(sub filter($fn) { - my @elements = $obj.value.grep({ self.call($fn, [$_]).truthy }); + my @elements = $obj.value.grep({ $fn.call(self, [$_]).truthy }); return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { return builtin(sub map($fn) { - my @elements = $obj.value.map({ self.call($fn, [$_]) }); + my @elements = $obj.value.map({ $fn.call(self, [$_]) }); return wrap(@elements); }); } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 95b67e4a..329eb195 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -26,6 +26,11 @@ class X::Property::Duplicate is Exception { 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 Helper { ... } class _007::Object::Class { ... } @@ -303,6 +308,32 @@ class Val::Sub is Val { self.bless(:name(wrap($name)), :&hook, :$parameterlist, :$statementlist); } + method call($runtime, @arguments) { + my $paramcount = $.parameterlist.parameters.value.elems; + my $argcount = @arguments.elems; + die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) + unless $paramcount == $argcount; + if self.hook -> &hook { + return &hook(|@arguments) || NONE; + } + $runtime.enter($.outer-frame, $.static-lexpad, $.statementlist, self); + for @($.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { + $runtime.declare-var($param.identifier, $arg); + } + $runtime.register-subhandler; + my $frame = $runtime.current-frame; + my $value = $.statementlist.run($runtime); + $runtime.leave; + CATCH { + when X::Control::Return { + $runtime.unroll-to($frame); + $runtime.leave; + return .value; + } + } + return $value || NONE; + } + method escaped-name { sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } sub escape-less-thans($s) { $s.subst(/"<"/, "\\<", :g) } From a96c4d6c39367f4cd7ef7e0f061e842eceec70ac Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 4 Sep 2017 17:23:52 +0200 Subject: [PATCH 22/91] Switch from &.hook mechanism to NativeSub --- lib/_007/Builtins.pm | 19 +++++++++++----- lib/_007/Q.pm | 13 +++++++++++ lib/_007/Runtime.pm | 2 +- lib/_007/Val.pm | 52 ++++++++++++++++++++++++++++++++------------ 4 files changed, 65 insertions(+), 21 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 48ff1cad..8e24187c 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -46,6 +46,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return $l === $r; } + elsif $type === TYPE { + return $l.properties.value eq $r.properties.value + && equal-value($l.properties, $r.properties) + && equal-value($l.properties, $r.properties); + } else { die "Unknown type ", $type.^name; } @@ -132,9 +137,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { type => sub ($arg) { $arg ~~ _007::Type ?? TYPE - !! $arg ~~ _007::Object - ?? $arg.type - !! Val::Type.of($arg.WHAT); + !! $arg !~~ _007::Object + ?? Val::Type.of($arg.WHAT) + !! $arg.type === TYPE # lie about NativeSub + ?? Val::Type.of(Val::Sub) + !! $arg.type; }, # OPERATORS (from loosest to tightest within each category) @@ -448,7 +455,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(.value, .key, $parameterlist, $statementlist); + .key => wrap-fn(.value, .key, $parameterlist, $statementlist); } when .value ~~ Placeholder::MacroOp { my $name = .key; @@ -457,7 +464,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(sub () {}, $name, $parameterlist, $statementlist); + .key => wrap-fn(sub () {}, $name, $parameterlist, $statementlist); } when .value ~~ Placeholder::Op { my $name = .key; @@ -467,7 +474,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); - .key => Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); + .key => wrap-fn(&fn, $name, $parameterlist, $statementlist); } default { die "Unknown type {.value.^name}" } }; diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 8dee42c8..fee187f3 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -342,6 +342,9 @@ class Q::Prefix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + return $c.value()($e); + } return $c.call($runtime, [$e]); } } @@ -399,6 +402,9 @@ class Q::Infix does Q::Expr { my $l = $.lhs.eval($runtime); my $r = $.rhs.eval($runtime); my $c = $.identifier.eval($runtime); + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + return $c.value()($l, $r); + } return $c.call($runtime, [$l, $r]); } } @@ -582,6 +588,9 @@ class Q::Postfix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + return $c.value()($e); + } return $c.call($runtime, [$e]); } } @@ -658,6 +667,10 @@ class Q::Postfix::Call is Q::Postfix { my $c = $.operand.eval($runtime); die "macro is called at runtime" if $c ~~ Val::Macro; + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); + return $c.value()(|@arguments); + } die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: unless $c ~~ Val::Sub; my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 54201e06..069971bd 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -161,7 +161,7 @@ class _007::Runtime { my $parameters = wrap(@elements); my $parameterlist = Q::ParameterList.new(:$parameters); my $statementlist = Q::StatementList.new(); - return Val::Sub.new-builtin(&fn, $name, $parameterlist, $statementlist); + return wrap-fn(&fn, $name, $parameterlist, $statementlist); } my $type = Val::Type.of($obj.WHAT).name; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 329eb195..c3e31ede 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -32,7 +32,7 @@ class X::Control::Return is Exception { } class Helper { ... } -class _007::Object::Class { ... } +class _007::Object { ... } sub unique-id { ++$ } @@ -65,7 +65,7 @@ class _007::Type { # XXX: need to screen for required properties by traversing @.fields, but we don't have the # infrastructure in terms of a way to mark up a field as required - return _007::Object::Class.new(:type(self), :%properties); + return _007::Object.new(:type(self), :%properties); } } @@ -73,10 +73,12 @@ constant TYPE = hash(.map(-> $name $name => _007::Type.new(:$name) })); TYPE = _007::Type.new(:name, :fields["message"]); +TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist"]); class _007::Object { has $.type; has $.id = unique-id; + has %.properties; method attributes { () } @@ -90,10 +92,6 @@ class _007::Object { method truthy { truthy(self) } } -class _007::Object::Class is _007::Object { - has %.properties; -} - class _007::Object::Enum is _007::Object { } @@ -159,6 +157,15 @@ sub wrap($value) is export { } } +sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { + my %properties = + name => wrap($name), + :$parameterlist, + :$statementlist, + ; + return _007::Object::Wrapped.new(:type(TYPE), :&value, :%properties); +} + role Val { method truthy { True } method attributes { self.^attributes } @@ -298,24 +305,16 @@ class Val::Type does Val { ### class Val::Sub is Val { has _007::Object $.name; - has &.hook = Callable; has $.parameterlist; has $.statementlist; has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); has _007::Object::Wrapped $.outer-frame; - method new-builtin(&hook, Str $name, $parameterlist, $statementlist) { - self.bless(:name(wrap($name)), :&hook, :$parameterlist, :$statementlist); - } - method call($runtime, @arguments) { my $paramcount = $.parameterlist.parameters.value.elems; my $argcount = @arguments.elems; die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) unless $paramcount == $argcount; - if self.hook -> &hook { - return &hook(|@arguments) || NONE; - } $runtime.enter($.outer-frame, $.static-lexpad, $.statementlist, self); for @($.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { $runtime.declare-var($param.identifier, $arg); @@ -372,6 +371,28 @@ class Val::Macro is Val::Sub { } class Helper { + 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.parameters.value».identifier».name.join(", "); + } + + method Str { "" } + our sub Str($_) { when Val::Regex { .quoted-Str } when Val::Type { "" } @@ -382,6 +403,9 @@ class Helper { when .type === TYPE { .quoted-Str } when .type === TYPE { .quoted-Str } when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } } From caf3db1c5076bb0157b64506b582019e766bf8cc Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:27:31 +0200 Subject: [PATCH 23/91] asset-capture Val::Sub --- lib/_007/Builtins.pm | 6 +-- lib/_007/Parser/Actions.pm | 6 +-- lib/_007/Q.pm | 14 +++---- lib/_007/Runtime.pm | 15 +++++--- lib/_007/Test.pm | 5 ++- lib/_007/Val.pm | 75 ++++++++++++++++++++++++++------------ 6 files changed, 77 insertions(+), 44 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 8e24187c..9ee798e2 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -46,7 +46,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return $l === $r; } - elsif $type === TYPE { + elsif $type === TYPE | TYPE { return $l.properties.value eq $r.properties.value && equal-value($l.properties, $r.properties) && equal-value($l.properties, $r.properties); @@ -59,7 +59,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi equal-value(Val::Type $l, Val::Type $r) { $l.type === $r.type } - multi equal-value(Val::Sub $l, Val::Sub $r) { + multi equal-value(Val::Macro $l, Val::Macro $r) { $l.name eq $r.name && equal-value($l.parameterlist, $r.parameterlist) && equal-value($l.statementlist, $r.statementlist) @@ -140,7 +140,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { !! $arg !~~ _007::Object ?? Val::Type.of($arg.WHAT) !! $arg.type === TYPE # lie about NativeSub - ?? Val::Type.of(Val::Sub) + ?? TYPE !! $arg.type; }, diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 8bcd9b95..75c8cc17 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -181,7 +181,7 @@ class _007::Parser::Actions { my $val; if $ eq "sub" { make Q::Statement::Sub.new(:$identifier, :$traitlist, :$block); - $val = Val::Sub.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); } elsif $ eq "macro" { make Q::Statement::Macro.new(:$identifier, :$traitlist, :$block); @@ -550,7 +550,7 @@ class _007::Parser::Actions { die X::Macro::Postdeclared.new(:$name) if $value ~~ Val::Macro; die X::Undeclared.new(:symbol($name)) - unless $value ~~ Val::Sub; + unless $value ~~ _007::Object && $value.type === TYPE; }; } } @@ -619,7 +619,7 @@ class _007::Parser::Actions { my $name = $.ast.name; my $outer-frame = $*runtime.current-frame.value; my $static-lexpad = $*runtime.current-frame.value; - my $val = Val::Sub.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + my $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); $.ast.put-value($val, $*runtime); } self.finish-block($block); diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index fee187f3..168fe108 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -300,7 +300,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { my $name = $.identifier ~~ _007::Object && $.identifier.type === TYPE ?? wrap("") !! $.identifier.name; - return Val::Sub.new( + return TYPE.create( :$name, :parameterlist($.block.parameterlist), :statementlist($.block.statementlist), @@ -345,7 +345,7 @@ class Q::Prefix does Q::Expr { if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($e); } - return $c.call($runtime, [$e]); + return internal-call($c, $runtime, [$e]); } } @@ -405,7 +405,7 @@ class Q::Infix does Q::Expr { if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($l, $r); } - return $c.call($runtime, [$l, $r]); + return internal-call($c, $runtime, [$l, $r]); } } @@ -591,7 +591,7 @@ class Q::Postfix does Q::Expr { if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($e); } - return $c.call($runtime, [$e]); + return internal-call($c, $runtime, [$e]); } } @@ -617,7 +617,7 @@ class Q::Postfix::Index is Q::Postfix { if $index.value < 0; return .value[$index.value]; } - if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Val::Sub || $_ ~~ Q { + if ($_ ~~ _007::Object && .type === TYPE) || ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Val::Macro || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.type === TYPE; @@ -672,9 +672,9 @@ class Q::Postfix::Call is Q::Postfix { return $c.value()(|@arguments); } die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: - unless $c ~~ Val::Sub; + unless ($c ~~ _007::Object && $c.type === TYPE) || $c ~~ Val::Macro; my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); - return $c.call($runtime, @arguments); + return internal-call($c, $runtime, @arguments); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 069971bd..65f07b7b 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -50,7 +50,7 @@ class _007::Runtime { my $statementlist = .block.statementlist; my $static-lexpad = .block.static-lexpad; my $outer-frame = $frame; - my $val = Val::Sub.new( + my $val = TYPE.create( :$name, :$parameterlist, :$statementlist, @@ -61,7 +61,9 @@ class _007::Runtime { } } if $routine { - my $name = $routine.name; + my $name = $routine ~~ Val::Macro + ?? $routine.name + !! $routine.properties; my $identifier = Q::Identifier.new(:$name, :$frame); self.declare-var($identifier, $routine); } @@ -354,13 +356,13 @@ class _007::Runtime { } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { return builtin(sub filter($fn) { - my @elements = $obj.value.grep({ $fn.call(self, [$_]).truthy }); + my @elements = $obj.value.grep({ internal-call($fn, self, [$_]).truthy }); return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { return builtin(sub map($fn) { - my @elements = $obj.value.map({ $fn.call(self, [$_]) }); + my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); return wrap(@elements); }); } @@ -408,7 +410,10 @@ class _007::Runtime { $obj.create($properties.value.map({ .value[0].value => .value[1] })); }); } - elsif $obj ~~ Val::Sub && $propname eq any { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq any { + return $obj.properties{$propname}; + } + elsif $obj ~~ Val::Macro && $propname eq any { return $obj."$propname"(); } elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 8cc2ed88..4ea3a39b 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -215,10 +215,11 @@ sub check(Q::CompUnit $ast, $runtime) is export { multi handle(Q::Statement::Sub $sub) { my $outer-frame = $runtime.current-frame; my $name = $sub.identifier.name; - my $val = Val::Sub.new(:$name, + my $val = TYPE.create( + :$name, :parameterlist($sub.block.parameterlist), :statementlist($sub.block.statementlist), - :$outer-frame + :$outer-frame, ); $runtime.enter($outer-frame, wrap({}), $sub.block.statementlist, $val); handle($sub.block); diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index c3e31ede..00e0299f 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -74,6 +74,7 @@ constant TYPE = hash(.map(-> $name })); TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist"]); +TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); class _007::Object { has $.type; @@ -310,29 +311,6 @@ class Val::Sub is Val { has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); has _007::Object::Wrapped $.outer-frame; - method call($runtime, @arguments) { - my $paramcount = $.parameterlist.parameters.value.elems; - my $argcount = @arguments.elems; - die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) - unless $paramcount == $argcount; - $runtime.enter($.outer-frame, $.static-lexpad, $.statementlist, self); - for @($.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { - $runtime.declare-var($param.identifier, $arg); - } - $runtime.register-subhandler; - my $frame = $runtime.current-frame; - my $value = $.statementlist.run($runtime); - $runtime.leave; - CATCH { - when X::Control::Return { - $runtime.unroll-to($frame); - $runtime.leave; - return .value; - } - } - return $value || NONE; - } - method escaped-name { sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } sub escape-less-thans($s) { $s.subst(/"<"/, "\\<", :g) } @@ -356,6 +334,32 @@ class Val::Sub is Val { method Str { "" } } +sub internal-call(_007::Object $sub, $runtime, @arguments) is export { + die "Tried to call a {$sub.^name}, expected a Sub" + unless $sub ~~ _007::Object && $sub.type === TYPE; + + my $paramcount = $sub.properties.parameters.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.parameters.value) Z @arguments -> ($param, $arg) { + $runtime.declare-var($param.identifier, $arg); + } + $runtime.register-subhandler; + my $frame = $runtime.current-frame; + my $value = $sub.properties.run($runtime); + $runtime.leave; + CATCH { + when X::Control::Return { + $runtime.unroll-to($frame); + $runtime.leave; + return .value; + } + } + return $value || NONE; +} + ### ### Macro ### ### A macro. When you define a macro in 007, the value of the name bound @@ -367,6 +371,29 @@ class Val::Sub is Val { ### say(agent); # --> `` ### class Val::Macro is Val::Sub { + method call($runtime, @arguments) { + my $paramcount = $.parameterlist.parameters.value.elems; + my $argcount = @arguments.elems; + die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) + unless $paramcount == $argcount; + $runtime.enter($.outer-frame, $.static-lexpad, $.statementlist, self); + for @($.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { + $runtime.declare-var($param.identifier, $arg); + } + $runtime.register-subhandler; + my $frame = $runtime.current-frame; + my $value = $.statementlist.run($runtime); + $runtime.leave; + CATCH { + when X::Control::Return { + $runtime.unroll-to($frame); + $runtime.leave; + return .value; + } + } + return $value || NONE; + } + method Str { "" } } @@ -403,7 +430,7 @@ class Helper { when .type === TYPE { .quoted-Str } when .type === TYPE { .quoted-Str } when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { + when .type === TYPE | TYPE { sprintf "", escaped(.properties.value), pretty(.properties) } when _007::Object::Wrapped { .value.Str } From 1c5b20109889930c6b891065799ddbdb916ca8b9 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:33:20 +0200 Subject: [PATCH 24/91] remove Val::Sub --- lib/_007/Val.pm | 77 +++++++++++++++++-------------------------------- 1 file changed, 27 insertions(+), 50 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 00e0299f..d11642c6 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -286,54 +286,6 @@ class Val::Type does 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 _007::Object $.name; - has $.parameterlist; - has $.statementlist; - has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); - has _007::Object::Wrapped $.outer-frame; - - 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.value».identifier».name.join(", "); - } - - method Str { "" } -} - sub internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" unless $sub ~~ _007::Object && $sub.type === TYPE; @@ -370,7 +322,33 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { ### } ### say(agent); # --> `` ### -class Val::Macro is Val::Sub { +class Val::Macro is Val { + has _007::Object $.name; + has $.parameterlist; + has $.statementlist; + has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); + has _007::Object::Wrapped $.outer-frame; + + 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.value».identifier».name.join(", "); + } + method call($runtime, @arguments) { my $paramcount = $.parameterlist.parameters.value.elems; my $argcount = @arguments.elems; @@ -437,7 +415,6 @@ class Helper { default { die "Unexpected type ", .^name } } when Val::Macro { "" } - when Val::Sub { "" } default { my $self = $_; die "Unexpected type -- some invariant must be broken ({$self.^name})" From 199d15291f47401d1047fed721dfd6c39fee72f1 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:37:24 +0200 Subject: [PATCH 25/91] eliminate NativeSub It turns out it's enough for us to distinguish between the 007 Subs being _007::Object and the Perl 6 wrapped Subs being _007::Object::Wrapped. --- lib/_007/Builtins.pm | 6 ++---- lib/_007/Q.pm | 8 ++++---- lib/_007/Val.pm | 5 ++--- 3 files changed, 8 insertions(+), 11 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 9ee798e2..8ce0befe 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -46,7 +46,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return $l === $r; } - elsif $type === TYPE | TYPE { + elsif $type === TYPE { return $l.properties.value eq $r.properties.value && equal-value($l.properties, $r.properties) && equal-value($l.properties, $r.properties); @@ -139,9 +139,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ?? TYPE !! $arg !~~ _007::Object ?? Val::Type.of($arg.WHAT) - !! $arg.type === TYPE # lie about NativeSub - ?? TYPE - !! $arg.type; + !! $arg.type; }, # OPERATORS (from loosest to tightest within each category) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 168fe108..749c68af 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -342,7 +342,7 @@ class Q::Prefix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($e); } return internal-call($c, $runtime, [$e]); @@ -402,7 +402,7 @@ class Q::Infix does Q::Expr { my $l = $.lhs.eval($runtime); my $r = $.rhs.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($l, $r); } return internal-call($c, $runtime, [$l, $r]); @@ -588,7 +588,7 @@ class Q::Postfix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { return $c.value()($e); } return internal-call($c, $runtime, [$e]); @@ -667,7 +667,7 @@ class Q::Postfix::Call is Q::Postfix { my $c = $.operand.eval($runtime); die "macro is called at runtime" if $c ~~ Val::Macro; - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { + if $c ~~ _007::Object::Wrapped && $c.type === TYPE { my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); return $c.value()(|@arguments); } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index d11642c6..605bf4cc 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -73,7 +73,6 @@ constant TYPE = hash(.map(-> $name $name => _007::Type.new(:$name) })); TYPE = _007::Type.new(:name, :fields["message"]); -TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); class _007::Object { @@ -164,7 +163,7 @@ sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { :$parameterlist, :$statementlist, ; - return _007::Object::Wrapped.new(:type(TYPE), :&value, :%properties); + return _007::Object::Wrapped.new(:type(TYPE), :&value, :%properties); } role Val { @@ -408,7 +407,7 @@ class Helper { when .type === TYPE { .quoted-Str } when .type === TYPE { .quoted-Str } when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE | TYPE { + when .type === TYPE { sprintf "", escaped(.properties.value), pretty(.properties) } when _007::Object::Wrapped { .value.Str } From be4e43f5065f22af7728f1bef6299a00a5e82230 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:42:44 +0200 Subject: [PATCH 26/91] move wrapped sub check inside internal-call --- lib/_007/Q.pm | 13 ------------- lib/_007/Runtime.pm | 2 ++ lib/_007/Val.pm | 8 ++++++++ 3 files changed, 10 insertions(+), 13 deletions(-) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 749c68af..a62a3605 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -342,9 +342,6 @@ class Q::Prefix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { - return $c.value()($e); - } return internal-call($c, $runtime, [$e]); } } @@ -402,9 +399,6 @@ class Q::Infix does Q::Expr { my $l = $.lhs.eval($runtime); my $r = $.rhs.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { - return $c.value()($l, $r); - } return internal-call($c, $runtime, [$l, $r]); } } @@ -588,9 +582,6 @@ class Q::Postfix does Q::Expr { method eval($runtime) { my $e = $.operand.eval($runtime); my $c = $.identifier.eval($runtime); - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { - return $c.value()($e); - } return internal-call($c, $runtime, [$e]); } } @@ -667,10 +658,6 @@ class Q::Postfix::Call is Q::Postfix { my $c = $.operand.eval($runtime); die "macro is called at runtime" if $c ~~ Val::Macro; - if $c ~~ _007::Object::Wrapped && $c.type === TYPE { - my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); - return $c.value()(|@arguments); - } die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: unless ($c ~~ _007::Object && $c.type === TYPE) || $c ~~ Val::Macro; my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 65f07b7b..41c06ed0 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -356,12 +356,14 @@ class _007::Runtime { } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { return builtin(sub filter($fn) { + # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.grep({ internal-call($fn, self, [$_]).truthy }); return wrap(@elements); }); } elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { return builtin(sub map($fn) { + # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); return wrap(@elements); }); diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 605bf4cc..5384e0e8 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -289,6 +289,14 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" unless $sub ~~ _007::Object && $sub.type === TYPE; + 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.parameters.value.elems; my $argcount = @arguments.elems; die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) From 59ebf73558aacfdc175e2367d4f454ae4aaec3b6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:53:16 +0200 Subject: [PATCH 27/91] asset-capture Val::Macro --- lib/_007/Builtins.pm | 7 +------ lib/_007/Parser/Actions.pm | 9 +++++---- lib/_007/Q.pm | 6 +++--- lib/_007/Runtime.pm | 9 ++------- lib/_007/Test.pm | 3 ++- lib/_007/Val.pm | 7 +++++-- 6 files changed, 18 insertions(+), 23 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 8ce0befe..0385fdc2 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -46,7 +46,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return $l === $r; } - elsif $type === TYPE { + elsif $type === TYPE | TYPE { # XXX: should really do subtyping check here return $l.properties.value eq $r.properties.value && equal-value($l.properties, $r.properties) && equal-value($l.properties, $r.properties); @@ -59,11 +59,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi equal-value(Val::Type $l, Val::Type $r) { $l.type === $r.type } - multi equal-value(Val::Macro $l, Val::Macro $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)); diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 75c8cc17..28b87b2d 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -185,7 +185,7 @@ class _007::Parser::Actions { } elsif $ eq "macro" { make Q::Statement::Macro.new(:$identifier, :$traitlist, :$block); - $val = Val::Macro.new(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); } else { die "Unknown routine type $"; # XXX: Turn this into an X:: exception @@ -284,12 +284,13 @@ 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 + && (my $macro = $*runtime.maybe-get-var($identifier.name.value)) ~~ _007::Object + && $macro.type === TYPE && $macro; } sub expand($macro, @arguments, &unexpanded-callback:()) { - my $expansion = $macro.call($*runtime, @arguments); + my $expansion = internal-call($macro, $*runtime, @arguments); if $expansion ~~ Q::Statement::My { _007::Parser::Syntax::declare(Q::Statement::My, $expansion.identifier.name.value); @@ -548,7 +549,7 @@ class _007::Parser::Actions { $*parser.postpone: sub checking-postdeclared { my $value = $*runtime.maybe-get-var($name, $frame); die X::Macro::Postdeclared.new(:$name) - if $value ~~ Val::Macro; + if $value ~~ _007::Object && $value.type === TYPE; die X::Undeclared.new(:symbol($name)) unless $value ~~ _007::Object && $value.type === TYPE; }; diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index a62a3605..3823a509 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -608,7 +608,7 @@ class Q::Postfix::Index is Q::Postfix { if $index.value < 0; return .value[$index.value]; } - if ($_ ~~ _007::Object && .type === TYPE) || ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Val::Macro || $_ ~~ Q { + if ($_ ~~ _007::Object && .type === TYPE | TYPE | TYPE) || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.type === TYPE; @@ -657,9 +657,9 @@ class Q::Postfix::Call is Q::Postfix { method eval($runtime) { my $c = $.operand.eval($runtime); die "macro is called at runtime" - if $c ~~ Val::Macro; + if $c ~~ _007::Object && $c.type === TYPE; die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: - unless ($c ~~ _007::Object && $c.type === TYPE) || $c ~~ Val::Macro; + unless ($c ~~ _007::Object && $c.type === TYPE) || $c ~~ _007::Object && $c.type === TYPE; my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); return internal-call($c, $runtime, @arguments); } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 41c06ed0..ee8e8444 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -61,9 +61,7 @@ class _007::Runtime { } } if $routine { - my $name = $routine ~~ Val::Macro - ?? $routine.name - !! $routine.properties; + my $name = $routine.properties; my $identifier = Q::Identifier.new(:$name, :$frame); self.declare-var($identifier, $routine); } @@ -412,12 +410,9 @@ class _007::Runtime { $obj.create($properties.value.map({ .value[0].value => .value[1] })); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq any { + elsif $obj ~~ _007::Object && $obj.type === TYPE | TYPE && $propname eq any { return $obj.properties{$propname}; } - elsif $obj ~~ Val::Macro && $propname eq any { - return $obj."$propname"(); - } elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { return $obj.properties{$propname}; } diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 4ea3a39b..b259c6a1 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -231,7 +231,8 @@ sub check(Q::CompUnit $ast, $runtime) is export { multi handle(Q::Statement::Macro $macro) { my $outer-frame = $runtime.current-frame; my $name = $macro.identifier.name; - my $val = Val::Macro.new(:$name, + my $val = TYPE.create( + :$name, :parameterlist($macro.block.parameterlist), :statementlist($macro.block.statementlist), :$outer-frame diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 5384e0e8..91bb8282 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -74,6 +74,7 @@ constant TYPE = hash(.map(-> $name })); TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); class _007::Object { has $.type; @@ -287,7 +288,7 @@ class Val::Type does Val { sub internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" - unless $sub ~~ _007::Object && $sub.type === TYPE; + unless $sub ~~ _007::Object && $sub.type === TYPE | TYPE; # XXX: should do subtyping check if $sub ~~ _007::Object::Wrapped && $sub.type === TYPE { die "Don't handle the wrapped macro case yet"; @@ -418,10 +419,12 @@ class Helper { when .type === TYPE { sprintf "", escaped(.properties.value), pretty(.properties) } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } } - when Val::Macro { "" } default { my $self = $_; die "Unexpected type -- some invariant must be broken ({$self.^name})" From 93fc6c66cc63a1aa3da0ca72d6930f9415111439 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 03:55:35 +0200 Subject: [PATCH 28/91] remove Val::Macro --- lib/_007/Val.pm | 63 ------------------------------------------------- 1 file changed, 63 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 91bb8282..5a4c7656 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -320,69 +320,6 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { return $value || NONE; } -### ### 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 { - has _007::Object $.name; - has $.parameterlist; - has $.statementlist; - has _007::Object::Wrapped $.static-lexpad is rw = wrap({}); - has _007::Object::Wrapped $.outer-frame; - - 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.value».identifier».name.join(", "); - } - - method call($runtime, @arguments) { - my $paramcount = $.parameterlist.parameters.value.elems; - my $argcount = @arguments.elems; - die X::ParameterMismatch.new(:type, :$paramcount, :$argcount) - unless $paramcount == $argcount; - $runtime.enter($.outer-frame, $.static-lexpad, $.statementlist, self); - for @($.parameterlist.parameters.value) Z @arguments -> ($param, $arg) { - $runtime.declare-var($param.identifier, $arg); - } - $runtime.register-subhandler; - my $frame = $runtime.current-frame; - my $value = $.statementlist.run($runtime); - $runtime.leave; - CATCH { - when X::Control::Return { - $runtime.unroll-to($frame); - $runtime.leave; - return .value; - } - } - return $value || NONE; - } - - method Str { "" } -} - class Helper { sub escaped($name) { sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } From 817e08da0dab12245a4ce2d991247152f33adece Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 04:03:22 +0200 Subject: [PATCH 29/91] asset-capture Val::Regex --- lib/_007/Q.pm | 2 +- lib/_007/Runtime.pm | 8 ++++---- lib/_007/Val.pm | 5 ++++- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 3823a509..a574b2a4 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -179,7 +179,7 @@ class Q::Term::Regex does Q::Term { has _007::Object $.contents; method eval($runtime) { - Val::Regex.new(:$.contents); + TYPE.create(:$.contents); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index ee8e8444..2918b4c7 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -332,9 +332,9 @@ class _007::Runtime { return wrap($s.substr($pos.value, 1)); }); } - elsif $obj ~~ Val::Regex && $propname eq "fullmatch" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "fullmatch" { return builtin(sub fullmatch($str) { - my $regex-string = $obj.contents.value; + my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; @@ -342,9 +342,9 @@ class _007::Runtime { return wrap($regex-string eq $str.value); }); } - elsif $obj ~~ Val::Regex && $propname eq "search" { + elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "search" { return builtin(sub search($str) { - my $regex-string = $obj.contents.value; + my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new unless $str ~~ _007::Object && $str.type === TYPE; diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 5a4c7656..5699d024 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -75,6 +75,7 @@ constant TYPE = hash(.map(-> $name TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new(:name, :fields["contents"]); class _007::Object { has $.type; @@ -344,7 +345,6 @@ class Helper { method Str { "" } our sub Str($_) { - when Val::Regex { .quoted-Str } when Val::Type { "" } when _007::Type { "" } when _007::Object { @@ -359,6 +359,9 @@ class Helper { when .type === TYPE { sprintf "", escaped(.properties.value), pretty(.properties) } + when .type === TYPE { + "/" ~ .contents.quoted-Str ~ "/" + } when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } } From 3c8c9f06d509c2f53ae6d550d52fa2af8884fee4 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 7 Sep 2017 04:03:47 +0200 Subject: [PATCH 30/91] remove Val::Regex --- lib/_007/Val.pm | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 5699d024..8ce34879 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -179,29 +179,6 @@ role Val { } } -### ### 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 _007::Object $.contents; - - method quoted-Str { - "/" ~ $.contents.quoted-Str ~ "/" - } -} - ### ### Type ### ### A type in 007's type system. All values have a type, which determines From 22f6c2462c0773f90fae768390b834b37ae5a285 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Fri, 8 Sep 2017 07:44:02 +0200 Subject: [PATCH 31/91] quarantine t/features/expr.t for now --- t/features/{expr.t => expr.t_quarantine} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename t/features/{expr.t => expr.t_quarantine} (100%) diff --git a/t/features/expr.t b/t/features/expr.t_quarantine similarity index 100% rename from t/features/expr.t rename to t/features/expr.t_quarantine From 976aece3fa9f99cca431fe5394f85f745c844e25 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Fri, 8 Sep 2017 17:10:38 +0200 Subject: [PATCH 32/91] Split up TYPE declaration and initialization Some of these need to be run in a BEGIN block, because other `constant` declarations need to be able to see them early. --- lib/_007/Val.pm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 8ce34879..f2e0ffb6 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -69,9 +69,15 @@ class _007::Type { } } -constant TYPE = hash(.map(-> $name { - $name => _007::Type.new(:$name) -})); +constant TYPE = hash(); +BEGIN { + for -> $name { + TYPE{$name} = _007::Type.new(:$name); + } +} +for -> $name { + TYPE{$name} = _007::Type.new(:$name); +} TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); From 88e6c4e28340457a99647402d779c5cec75ab4ba Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Fri, 8 Sep 2017 17:24:42 +0200 Subject: [PATCH 33/91] move TYPE above _007::Type Making it available there, so that we can talk about base types. --- lib/_007/Val.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index f2e0ffb6..409cf335 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -36,6 +36,8 @@ class _007::Object { ... } sub unique-id { ++$ } +constant TYPE = hash(); + class _007::Type { has Str $.name; has @.fields; @@ -69,7 +71,6 @@ class _007::Type { } } -constant TYPE = hash(); BEGIN { for -> $name { TYPE{$name} = _007::Type.new(:$name); From 1aeed9d73dbba085e8e9406ec7311e9e1ba3f2c9 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 9 Sep 2017 17:29:34 +0200 Subject: [PATCH 34/91] introduce _007::Type.base And bootstrap it properly. --- lib/_007/Val.pm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 409cf335..79b771f0 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -40,9 +40,14 @@ constant TYPE = hash(); class _007::Type { has Str $.name; + has $.base = TYPE; has @.fields; # XXX: $.id + method install-base($none) { + $!base = $none; + } + method attributes { () } method quoted-Str { self.Str } @@ -81,7 +86,7 @@ for -> $name { } TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); -TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); TYPE = _007::Type.new(:name, :fields["contents"]); class _007::Object { @@ -135,6 +140,10 @@ class _007::Object::Wrapped is _007::Object { } constant NONE is export = _007::Object::Enum.new(:type(TYPE)); + +# Now we can install NONE into TYPE.base +TYPE.install-base(NONE); + constant TRUE is export = _007::Object::Enum.new(:type(TYPE)); constant FALSE is export = _007::Object::Enum.new(:type(TYPE)); From 95a4d7a50178e28fc5aa6bd911174e8e0c18c2ad Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 9 Sep 2017 17:54:12 +0200 Subject: [PATCH 35/91] implement Object.isa --- lib/_007/Val.pm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 79b771f0..e8890863 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -48,6 +48,16 @@ class _007::Type { $!base = $none; } + method type-chain() { + my @chain; + my $t = self; + while $t ~~ _007::Type { + @chain.push($t); + $t.=base; + } + return @chain; + } + method attributes { () } method quoted-Str { self.Str } @@ -94,6 +104,14 @@ class _007::Object { has $.id = unique-id; has %.properties; + multi method isa(Str $typename) { + self.isa(TYPE{$typename}); + } + + multi method isa(_007::Type $type) { + return $type (elem) $.type.type-chain; + } + method attributes { () } method Str { From 5d11bafb3aecd582357dfdcba5a99fa4afaff3b6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 9 Sep 2017 17:54:59 +0200 Subject: [PATCH 36/91] check for Sub/Macro using subtyping check --- lib/_007/Builtins.pm | 2 +- lib/_007/Q.pm | 4 ++-- lib/_007/Runtime.pm | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 0385fdc2..8c33a356 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -46,7 +46,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $type === TYPE { return $l === $r; } - elsif $type === TYPE | TYPE { # XXX: should really do subtyping check here + elsif $l.isa("Sub") { return $l.properties.value eq $r.properties.value && equal-value($l.properties, $r.properties) && equal-value($l.properties, $r.properties); diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index a574b2a4..9b66de4b 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -608,7 +608,7 @@ class Q::Postfix::Index is Q::Postfix { if $index.value < 0; return .value[$index.value]; } - if ($_ ~~ _007::Object && .type === TYPE | TYPE | TYPE) || $_ ~~ Q { + if ($_ ~~ _007::Object && (.type === TYPE || .isa("Sub"))) || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.type === TYPE; @@ -659,7 +659,7 @@ class Q::Postfix::Call is Q::Postfix { die "macro is called at runtime" if $c ~~ _007::Object && $c.type === TYPE; die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: - unless ($c ~~ _007::Object && $c.type === TYPE) || $c ~~ _007::Object && $c.type === TYPE; + unless $c ~~ _007::Object && $c.isa("Sub"); my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); return internal-call($c, $runtime, @arguments); } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 2918b4c7..9db021de 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -410,7 +410,7 @@ class _007::Runtime { $obj.create($properties.value.map({ .value[0].value => .value[1] })); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE | TYPE && $propname eq any { + elsif $obj ~~ _007::Object && $obj.isa("Sub") && $propname eq any { return $obj.properties{$propname}; } elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { From d7c817bce2f96b6bd4f64db6e8df0f7da9fe3d4f Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 9 Sep 2017 18:20:20 +0200 Subject: [PATCH 37/91] Do subtyping checks instead of exact typechecks --- lib/_007/Builtins.pm | 83 ++++++++++++++++++-------------------- lib/_007/Parser/Actions.pm | 6 +-- lib/_007/Q.pm | 37 ++++++++--------- lib/_007/Runtime.pm | 80 ++++++++++++++++++------------------ 4 files changed, 102 insertions(+), 104 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 8c33a356..c5ac1ada 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -7,14 +7,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi equal-value(_007::Object $l, _007::Object $r) { return False unless $l.type === $r.type; - my $type = $l.type; - if $type === TYPE { + if $l.isa("Int") { return $l.value == $r.value; } - elsif $type === TYPE { + elsif $l.isa("Str") { return $l.value eq $r.value; } - elsif $type === TYPE { + elsif $l.isa("Array") { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { return $l === $r; } @@ -27,7 +26,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return [&&] $l.value == $r.value, |(^$l.value).map(&equal-at-index); } - elsif $type === TYPE { + elsif $l.isa("Dict") { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { return $l === $r; } @@ -40,10 +39,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return [&&] $l.value.keys.sort.perl eq $r.value.keys.sort.perl, |($l.value.keys).map(&equal-at-key); } - elsif $type === TYPE { + elsif $l.isa("NoneType") { return True; } - elsif $type === TYPE { + elsif $l.isa("Bool") { return $l === $r; } elsif $l.isa("Sub") { @@ -52,7 +51,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { && equal-value($l.properties, $r.properties); } else { - die "Unknown type ", $type.^name; + die "Unknown type ", $l.type.^name; } } multi equal-value(_007::Type $l, _007::Type $r) { $l === $r } @@ -77,12 +76,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi less-value(_007::Object $l, _007::Object $r) { die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) unless $l.type === $r.type; - my $type = $l.type; - return $type === TYPE + return $l.isa("Int") ?? $l.value < $r.value - !! $type === TYPE + !! $l.isa("Str") ?? $l.value lt $r.value - !! die "Unknown type ", $type.Str; + !! die "Unknown type ", $l.type.Str; } multi more-value($, $) { die X::TypeCheck.new( @@ -93,12 +91,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi more-value(_007::Object $l, _007::Object $r) { die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) unless $l.type === $r.type; - my $type = $l.type; - return $type === TYPE + return $l.isa("Int") ?? $l.value > $r.value - !! $type === TYPE + !! $l.isa("Str") ?? $l.value gt $r.value - !! die "Unknown type ", $type.Str; + !! die "Unknown type ", $l.type.Str; } my role Placeholder { @@ -132,9 +129,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { type => sub ($arg) { $arg ~~ _007::Type ?? TYPE - !! $arg !~~ _007::Object - ?? Val::Type.of($arg.WHAT) - !! $arg.type; + !! $arg ~~ _007::Object + ?? $arg.type + !! Val::Type.of($arg.WHAT); }, # OPERATORS (from loosest to tightest within each category) @@ -208,7 +205,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs ~~ _007::Object && $lhs.type === $rhs); + return wrap($lhs ~~ _007::Object && $lhs.isa($rhs)); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) @@ -222,7 +219,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:!~~' => op( sub ($lhs, $rhs) { if $rhs ~~ _007::Type { - return wrap($lhs !~~ _007::Object || $lhs.type !=== $rhs); + return wrap($lhs !~~ _007::Object || !$lhs.isa($rhs)); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) @@ -238,7 +235,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:::' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<::>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Array"); return wrap([$lhs, |$rhs.value]); }, :qtype(Q::Infix::Cons), @@ -249,9 +246,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:+' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Int"); die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value + $rhs.value); }, :qtype(Q::Infix::Addition), @@ -259,9 +256,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<~>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Str"); die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Str"); return wrap($lhs.value ~ $rhs.value); }, :qtype(Q::Infix::Concat), @@ -270,9 +267,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:-' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<->, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Int"); die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value - $rhs.value); }, :qtype(Q::Infix::Subtraction), @@ -282,9 +279,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:*' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Int"); die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value * $rhs.value); }, :qtype(Q::Infix::Multiplication), @@ -292,9 +289,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Int"); die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value % $rhs.value); @@ -304,9 +301,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Int"); die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); @@ -316,9 +313,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:x' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Str"); die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value x $rhs.value); }, :qtype(Q::Infix::Replicate), @@ -327,9 +324,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:xx' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.type === TYPE; + unless $lhs ~~ _007::Object && $lhs.isa("Array"); die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.type === TYPE; + unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap(| $lhs.value xx $rhs.value); }, :qtype(Q::Infix::ArrayReplicate), @@ -344,11 +341,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:+' => op( sub prefix-plus($expr) { if $expr ~~ _007::Object { - if $expr.type === TYPE { + if $expr.isa("Str") { return wrap($expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } - elsif $expr.type === TYPE { + elsif $expr.isa("Int") { return $expr; } } @@ -362,11 +359,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:-' => op( sub prefix-minus($expr) { if $expr ~~ _007::Object { - if $expr.type === TYPE { + if $expr.isa("Str") { return wrap(-$expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } - elsif $expr.type === TYPE { + elsif $expr.isa("Int") { return wrap(-$expr.value); } } @@ -392,7 +389,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:^' => op( sub ($n) { die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) - unless $n ~~ _007::Object && $n.type === TYPE; + unless $n ~~ _007::Object && $n.isa("Int"); return wrap([(^$n.value).map(&wrap)]); }, :qtype(Q::Prefix::Upto), diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 28b87b2d..d0fe0cbb 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -285,7 +285,7 @@ class _007::Parser::Actions { $q ~~ $qtype && $identifier ~~ Q::Identifier && (my $macro = $*runtime.maybe-get-var($identifier.name.value)) ~~ _007::Object - && $macro.type === TYPE + && $macro.isa("Macro") && $macro; } @@ -549,9 +549,9 @@ class _007::Parser::Actions { $*parser.postpone: sub checking-postdeclared { my $value = $*runtime.maybe-get-var($name, $frame); die X::Macro::Postdeclared.new(:$name) - if $value ~~ _007::Object && $value.type === TYPE; + if $value ~~ _007::Object && $value.isa("Macro"); die X::Undeclared.new(:symbol($name)) - unless $value ~~ _007::Object && $value.type === TYPE; + unless $value ~~ _007::Object && $value.isa("Sub"); }; } } diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 9b66de4b..751f0ffa 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -207,6 +207,7 @@ class Q::Term::Object does Q::Term { method eval($runtime) { my $type = $runtime.get-var($.type.name.value, $.type.frame); + # XXX: Need to do a subtyping check here instead if $type === TYPE { return $type.create(|hash($.propertylist.properties.value.map(-> $property { $property.key.value => $property.value.eval($runtime) @@ -297,7 +298,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { method attribute-order { } method eval($runtime) { - my $name = $.identifier ~~ _007::Object && $.identifier.type === TYPE + my $name = $.identifier ~~ _007::Object && $.identifier.isa("NoneType") ?? wrap("") !! $.identifier.name; return TYPE.create( @@ -598,20 +599,20 @@ class Q::Postfix::Index is Q::Postfix { method eval($runtime) { given $.operand.eval($runtime) { - if $_ ~~ _007::Object && .type === TYPE { + if $_ ~~ _007::Object && .isa("Array") { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.type === TYPE; + unless $index ~~ _007::Object && $index.isa("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 ($_ ~~ _007::Object && (.type === TYPE || .isa("Sub"))) || $_ ~~ Q { + if ($_ ~~ _007::Object && (.isa("Dict") || .isa("Sub"))) || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.type === TYPE; + unless $property ~~ _007::Object && $property.isa("Str"); my $propname = $property.value; return $runtime.property($_, $propname); } @@ -621,10 +622,10 @@ class Q::Postfix::Index is Q::Postfix { method put-value($value, $runtime) { given $.operand.eval($runtime) { - if $_ ~~ _007::Object && .type === TYPE { + if $_ ~~ _007::Object && .isa("Array") { my $index = $.index.eval($runtime); die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.type === TYPE; + unless $index ~~ _007::Object && $index.isa("Int"); die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) if $index.value >= .value; die X::Subscript::Negative.new(:$index, :type([])) @@ -632,10 +633,10 @@ class Q::Postfix::Index is Q::Postfix { .value[$index.value] = $value; return; } - if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Q { + if ($_ ~~ _007::Object && .isa("Dict")) || $_ ~~ Q { my $property = $.index.eval($runtime); die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.type === TYPE; + unless $property ~~ _007::Object && $property.isa("Str"); my $propname = $property.value; $runtime.put-property($_, $propname, $value); return; @@ -657,7 +658,7 @@ class Q::Postfix::Call is Q::Postfix { method eval($runtime) { my $c = $.operand.eval($runtime); die "macro is called at runtime" - if $c ~~ _007::Object && $c.type === TYPE; + if $c ~~ _007::Object && $c.isa("Macro"); die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: unless $c ~~ _007::Object && $c.isa("Sub"); my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); @@ -682,7 +683,7 @@ class Q::Postfix::Property is Q::Postfix { method put-value($value, $runtime) { given $.operand.eval($runtime) { - if ($_ ~~ _007::Object && .type === TYPE) || $_ ~~ Q { + if ($_ ~~ _007::Object && .isa("Dict")) || $_ ~~ Q { my $propname = $.property.name.value; $runtime.put-property($_, $propname, $value); return; @@ -742,14 +743,14 @@ class Q::Term::Quasi does Q::Term { method eval($runtime) { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.type === TYPE; + if $thing ~~ _007::Object && $thing.isa("Array"); return $thing if $thing ~~ _007::Object; # XXX: won't hold true for everything sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.type === TYPE; + if $thing ~~ _007::Object && $thing.isa("Dict"); return $thing if $thing ~~ Val; @@ -839,7 +840,7 @@ class Q::Statement::My does Q::Statement does Q::Declaration { method run($runtime) { return - if $.expr ~~ _007::Object && $.expr.type === TYPE; + if $.expr ~~ _007::Object && $.expr.isa("NoneType"); my $value = $.expr.eval($runtime); $.identifier.put-value($value, $runtime); @@ -953,7 +954,7 @@ class Q::Statement::For does Q::Statement { my $array = $.expr.eval($runtime); die X::TypeCheck.new(:operation("for loop"), :got($array), :expected(_007::Object)) - unless $array ~~ _007::Object && $array.type === TYPE; + unless $array ~~ _007::Object && $array.isa("Array"); for $array.value -> $arg { $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); @@ -1000,7 +1001,7 @@ class Q::Statement::Return does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ _007::Object && $.expr.type === TYPE ?? $.expr !! $.expr.eval($runtime); + my $value = $.expr ~~ _007::Object && $.expr.isa("NoneType") ?? $.expr !! $.expr.eval($runtime); my $frame = $runtime.get-var("--RETURN-TO--"); die X::Control::Return.new(:$value, :$frame); } @@ -1014,11 +1015,11 @@ class Q::Statement::Throw does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ _007::Object && $.expr.type === TYPE + my $value = $.expr ~~ _007::Object && $.expr.isa("NoneType") ?? TYPE.create(:message(wrap("Died"))) !! $.expr.eval($runtime); die X::TypeCheck.new(:got($value), :expected(_007::Object)) - unless $value ~~ _007::Object && $value.type === TYPE; + unless $value ~~ _007::Object && $value.isa("Exception"); die X::_007::RuntimeException.new(:msg($value.properties.value)); } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 9db021de..49e49f8d 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -88,7 +88,7 @@ class _007::Runtime { method !maybe-find-pad(Str $symbol, $frame is copy) { # XXX: make a `defined` method on NoneType so we can use `//` - if $frame ~~ _007::Object && $frame.type === TYPE { + if $frame ~~ _007::Object && $frame.isa("NoneType") { $frame = self.current-frame; } repeat until $frame === NO_OUTER { @@ -102,7 +102,7 @@ class _007::Runtime { method put-var(Q::Identifier $identifier, $value) { my $name = $identifier.name.value; - my $frame = $identifier.frame ~~ _007::Object && $identifier.frame.type === TYPE + my $frame = $identifier.frame ~~ _007::Object && $identifier.frame.isa("NoneType") ?? self.current-frame !! $identifier.frame; my $pad = self!find-pad($name, $frame); @@ -122,7 +122,7 @@ class _007::Runtime { method declare-var(Q::Identifier $identifier, $value?) { my $name = $identifier.name.value; - my _007::Object::Wrapped $frame = $identifier.frame ~~ _007::Object && $identifier.frame.type === TYPE + my _007::Object::Wrapped $frame = $identifier.frame ~~ _007::Object && $identifier.frame.isa("NoneType") ?? self.current-frame !! $identifier.frame; $frame.value.value{$name} = $value // NONE; @@ -172,11 +172,11 @@ class _007::Runtime { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.type === TYPE; + if $thing ~~ _007::Object && $thing.isa("Array"); sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.type === TYPE; + if $thing ~~ _007::Object && $thing.isa("Dict"); return $thing if $thing ~~ Val; @@ -211,118 +211,118 @@ class _007::Runtime { return $obj."$propname"(); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "abs" { + elsif $obj ~~ _007::Object && $obj.isa("Int") && $propname eq "abs" { return builtin(sub abs() { return wrap($obj.value.abs); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chr" { + elsif $obj ~~ _007::Object && $obj.isa("Int") && $propname eq "chr" { return builtin(sub chr() { return wrap($obj.value.chr); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "ord" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "ord" { return builtin(sub ord() { return wrap($obj.value.ord); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "chars" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "chars" { return builtin(sub chars() { return wrap($obj.value.chars); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "uc" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "uc" { return builtin(sub uc() { return wrap($obj.value.uc); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "lc" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "lc" { return builtin(sub lc() { return wrap($obj.value.lc); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "trim" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "trim" { return builtin(sub trim() { return wrap($obj.value.trim); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "reverse" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "reverse" { return builtin(sub reverse() { return wrap($obj.value.reverse); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "sort" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "sort" { return builtin(sub sort() { return wrap($obj.value.sort); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "shuffle" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "shuffle" { return builtin(sub shuffle() { return wrap($obj.value.pick(*)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "concat" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "concat" { return builtin(sub concat($array) { die X::TypeCheck.new(:operation, :got($array), :expected(_007::Object)) - unless $array ~~ _007::Object && $array.type === TYPE; + unless $array ~~ _007::Object && $array.isa("Array"); return wrap([|$obj.value, |$array.value]); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "join" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "join" { return builtin(sub join($sep) { return wrap($obj.value.join($sep.value.Str)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "size" { + elsif $obj ~~ _007::Object && $obj.isa("Dict") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "split" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "split" { return builtin(sub split($sep) { my @elements = $obj.value.split($sep.value).map(&wrap); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "index" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "index" { return builtin(sub index($substr) { return wrap($obj.value.index($substr.value) // -1); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "substr" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "substr" { return builtin(sub substr($pos, $chars) { return wrap($obj.value.substr( $pos.value, $chars.value)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "contains" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "contains" { return builtin(sub contains($substr) { die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) - unless $substr ~~ _007::Object && $substr.type === TYPE; + unless $substr ~~ _007::Object && $substr.isa("Str"); return wrap($obj.value.contains($substr.value)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "prefix" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "prefix" { return builtin(sub prefix($pos) { return wrap($obj.value.substr( 0, $pos.value)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "suffix" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "suffix" { return builtin(sub suffix($pos) { return wrap($obj.value.substr( $pos.value)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "charat" { + elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "charat" { return builtin(sub charat($pos) { my $s = $obj.value; @@ -332,61 +332,61 @@ class _007::Runtime { return wrap($s.substr($pos.value, 1)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "fullmatch" { + elsif $obj ~~ _007::Object && $obj.isa("Regex") && $propname eq "fullmatch" { return builtin(sub fullmatch($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str ~~ _007::Object && $str.type === TYPE; + unless $str ~~ _007::Object && $str.isa("Str"); return wrap($regex-string eq $str.value); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "search" { + elsif $obj ~~ _007::Object && $obj.isa("Regex") && $propname eq "search" { return builtin(sub search($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str ~~ _007::Object && $str.type === TYPE; + unless $str ~~ _007::Object && $str.isa("Str"); return wrap($str.value.contains($regex-string)); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "filter" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "filter" { return builtin(sub filter($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.grep({ internal-call($fn, self, [$_]).truthy }); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "map" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "map" { return builtin(sub map($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "push" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "push" { return builtin(sub push($newelem) { $obj.value.push($newelem); return NONE; }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "pop" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "pop" { return builtin(sub pop() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.pop(); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "shift" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "shift" { return builtin(sub shift() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.shift(); }); } - elsif $obj ~~ _007::Object && $obj.type === TYPE && $propname eq "unshift" { + elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "unshift" { return builtin(sub unshift($newelem) { $obj.value.unshift($newelem); return NONE; @@ -416,7 +416,7 @@ class _007::Runtime { elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { return $obj.properties{$propname}; } - elsif $obj ~~ _007::Object && $obj.type === TYPE && ($obj.value{$propname} :exists) { + elsif $obj ~~ _007::Object && $obj.isa("Dict") && ($obj.value{$propname} :exists) { return $obj.value{$propname}; } elsif $propname eq "get" { @@ -468,7 +468,7 @@ class _007::Runtime { if $obj ~~ Q { die "We don't handle assigning to Q object properties yet"; } - elsif $obj !~~ _007::Object || $obj.type !=== TYPE { + elsif $obj !~~ _007::Object || !$obj.isa("Dict") { die "We don't handle assigning to non-Dict types yet"; } else { From a3213c0026315f423610f3782963ae5bca3223a4 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 9 Sep 2017 18:26:40 +0200 Subject: [PATCH 38/91] Compare with None directly Instead of doing two type checks every time. There used to be a time when I didn't want to risk doing this in the code base, for fear that somehow a second None instance had been created somewhere, or would be in the future. But we're heading into a state where the everything is set up much more deliberately, so it feels like the risk of that is very small. --- lib/_007/Q.pm | 12 +++++++----- lib/_007/Runtime.pm | 7 +++---- lib/_007/Test.pm | 2 +- lib/_007/Val.pm | 2 +- 4 files changed, 12 insertions(+), 11 deletions(-) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 751f0ffa..6bf6ac36 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -298,7 +298,7 @@ class Q::Term::Sub does Q::Term does Q::Declaration { method attribute-order { } method eval($runtime) { - my $name = $.identifier ~~ _007::Object && $.identifier.isa("NoneType") + my $name = $.identifier === NONE ?? wrap("") !! $.identifier.name; return TYPE.create( @@ -535,7 +535,7 @@ class Q::Infix::Or is Q::Infix { class Q::Infix::DefinedOr is Q::Infix { method eval($runtime) { my $l = $.lhs.eval($runtime); - return $l !~~ _007::Object || $l.type !=== TYPE + return $l !=== NONE ?? $l !! $.rhs.eval($runtime); } @@ -840,7 +840,7 @@ class Q::Statement::My does Q::Statement does Q::Declaration { method run($runtime) { return - if $.expr ~~ _007::Object && $.expr.isa("NoneType"); + if $.expr === NONE; my $value = $.expr.eval($runtime); $.identifier.put-value($value, $runtime); @@ -1001,7 +1001,9 @@ class Q::Statement::Return does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ _007::Object && $.expr.isa("NoneType") ?? $.expr !! $.expr.eval($runtime); + my $value = $.expr === NONE + ?? $.expr + !! $.expr.eval($runtime); my $frame = $runtime.get-var("--RETURN-TO--"); die X::Control::Return.new(:$value, :$frame); } @@ -1015,7 +1017,7 @@ class Q::Statement::Throw does Q::Statement { has $.expr = NONE; method run($runtime) { - my $value = $.expr ~~ _007::Object && $.expr.isa("NoneType") + my $value = $.expr === NONE ?? TYPE.create(:message(wrap("Died"))) !! $.expr.eval($runtime); die X::TypeCheck.new(:got($value), :expected(_007::Object)) diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 49e49f8d..7b742fc0 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -87,8 +87,7 @@ class _007::Runtime { } method !maybe-find-pad(Str $symbol, $frame is copy) { - # XXX: make a `defined` method on NoneType so we can use `//` - if $frame ~~ _007::Object && $frame.isa("NoneType") { + if $frame === NONE { $frame = self.current-frame; } repeat until $frame === NO_OUTER { @@ -102,7 +101,7 @@ class _007::Runtime { method put-var(Q::Identifier $identifier, $value) { my $name = $identifier.name.value; - my $frame = $identifier.frame ~~ _007::Object && $identifier.frame.isa("NoneType") + my $frame = $identifier.frame === NONE ?? self.current-frame !! $identifier.frame; my $pad = self!find-pad($name, $frame); @@ -122,7 +121,7 @@ class _007::Runtime { method declare-var(Q::Identifier $identifier, $value?) { my $name = $identifier.name.value; - my _007::Object::Wrapped $frame = $identifier.frame ~~ _007::Object && $identifier.frame.isa("NoneType") + my _007::Object::Wrapped $frame = $identifier.frame === NONE ?? self.current-frame !! $identifier.frame; $frame.value.value{$name} = $value // NONE; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index b259c6a1..9a4dc498 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -188,7 +188,7 @@ sub check(Q::CompUnit $ast, $runtime) is export { if %*assigned{$block ~ $symbol}; $runtime.declare-var($my.identifier); - if $my.expr !~~ _007::Object || $my.expr.type !=== TYPE { + if $my.expr !=== NONE { handle($my.expr); } } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index e8890863..685a30e7 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -359,7 +359,7 @@ class Helper { when Val::Type { "" } when _007::Type { "" } when _007::Object { - when .type === TYPE { "None" } + when NONE { "None" } when .type === TYPE { $_ === TRUE ?? "True" !! "False" } when .type === TYPE { .quoted-Str } when .type === TYPE { .quoted-Str } From 79edb9d803d7a4623faf0424bf22744ae53d37bb Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 10 Sep 2017 09:25:26 +0200 Subject: [PATCH 39/91] field declarations are inherited --- lib/_007/Val.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 685a30e7..9c0607b0 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -68,7 +68,7 @@ class _007::Type { method create(*%properties) { my $type = $.name; - my $fields = set(@.fields); + my $fields = set(self.type-chain.map({ .fields })); my $seen = set(); for %properties.keys.sort -> $property { die X::Property::NotDeclared.new(:$type, :$property) @@ -96,7 +96,7 @@ for -> $name { } TYPE = _007::Type.new(:name, :fields["message"]); TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new(:name, :base(TYPE)); TYPE = _007::Type.new(:name, :fields["contents"]); class _007::Object { From 221d534d3e81ba31447d85718c0459f0cbd22097 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 10 Sep 2017 15:17:13 +0200 Subject: [PATCH 40/91] remove comment --- lib/_007/Q.pm | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 6bf6ac36..a9e11309 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -207,7 +207,6 @@ class Q::Term::Object does Q::Term { method eval($runtime) { my $type = $runtime.get-var($.type.name.value, $.type.frame); - # XXX: Need to do a subtyping check here instead if $type === TYPE { return $type.create(|hash($.propertylist.properties.value.map(-> $property { $property.key.value => $property.value.eval($runtime) From b6b2dd19636610382cf40a245a3ef28c65063cac Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 05:40:42 +0200 Subject: [PATCH 41/91] asset-capture the Q hierarchy --- lib/_007/Backend/JavaScript.pm | 60 +-- lib/_007/Builtins.pm | 96 ++-- lib/_007/Linter.pm | 170 ++++--- lib/_007/OpScope.pm | 11 +- lib/_007/Parser/Actions.pm | 339 +++++++------ lib/_007/Parser/Syntax.pm | 26 +- lib/_007/Q.pm | 47 +- lib/_007/Runtime.pm | 114 +++-- lib/_007/Test.pm | 390 ++++++++------- lib/_007/Val.pm | 693 ++++++++++++++++++++++++++- t/features/builtins/methods.t | 3 +- t/features/builtins/operators.t | 10 +- t/features/macros.t | 6 +- t/features/q.t | 40 +- t/features/quasi.t | 2 +- t/features/unhygienic-declarations.t | 3 +- t/integration/finishblock.t | 2 +- t/self-host/sanity.t | 2 +- 18 files changed, 1394 insertions(+), 620 deletions(-) diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 4f6d38e6..cd622c04 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -10,14 +10,14 @@ my %builtins = ; class _007::Backend::JavaScript { - method emit(Q::CompUnit $compunit) { + method emit(_007::Object $compunit) { return "" - unless $compunit.block.statementlist.statements.value; + unless $compunit.properties.properties.properties.value; my @builtins; my @main; - for $compunit.block.statementlist.statements.value -> $stmt { + for $compunit.properties.properties.properties.value -> $stmt { emit-stmt($stmt); } @@ -29,38 +29,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.isa("Q::Statement::Expr") { + my $expr = $stmt.properties; + when $expr.isa("Q::Postfix::Call") + && $expr.properties.isa("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 .isa("Q::Literal::Str"); + .properties.quoted-Str; + }; + @main.push("say({@arguments.join(", ")});"); + } - @builtins.push(%builtins); - my @arguments = $expr.argumentlist.arguments.value.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.isa("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.isa("Q::Literal::Int"); + my $expr = $stmt.properties.properties.Str; + @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 c5ac1ada..a4807d1b 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -50,6 +50,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { && equal-value($l.properties, $r.properties) && equal-value($l.properties, $r.properties); } + elsif $l.isa("Q") { + sub same-propvalue($prop) { + equal-value($l.properties{$prop}, $r.properties{$prop}); + } + + [&&] $l.type === $r.type, + |$l.type.type-chain.reverse.map({ .fields }).flat.grep({ $_ ne "frame" }).map(&same-propvalue); + } else { die "Unknown type ", $l.type.^name; } @@ -138,22 +146,22 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # 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 @@ -162,21 +170,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( @@ -184,14 +192,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( @@ -199,13 +207,13 @@ 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) { if $rhs ~~ _007::Type { - return wrap($lhs ~~ _007::Object && $lhs.isa($rhs)); + return wrap($lhs ~~ _007::Object && ?$lhs.isa($rhs)); } die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) @@ -213,7 +221,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return wrap($lhs ~~ $rhs.type); }, - :qtype(Q::Infix::TypeMatch), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:!~~' => op( @@ -227,7 +235,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return wrap($lhs !~~ $rhs.type); }, - :qtype(Q::Infix::TypeNonMatch), + :qtype(TYPE), :precedence{ equal => "infix:==" }, ), @@ -238,7 +246,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Array"); return wrap([$lhs, |$rhs.value]); }, - :qtype(Q::Infix::Cons), + :qtype(TYPE), :assoc, ), @@ -251,7 +259,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value + $rhs.value); }, - :qtype(Q::Infix::Addition), + :qtype(TYPE), ), 'infix:~' => op( sub ($lhs, $rhs) { @@ -261,7 +269,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Str"); return wrap($lhs.value ~ $rhs.value); }, - :qtype(Q::Infix::Concat), + :qtype(TYPE), :precedence{ equal => "infix:+" }, ), 'infix:-' => op( @@ -272,7 +280,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value - $rhs.value); }, - :qtype(Q::Infix::Subtraction), + :qtype(TYPE), ), # multiplicative precedence @@ -284,7 +292,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value * $rhs.value); }, - :qtype(Q::Infix::Multiplication), + :qtype(TYPE), ), 'infix:%' => op( sub ($lhs, $rhs) { @@ -296,7 +304,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { if $rhs.value == 0; return wrap($lhs.value % $rhs.value); }, - :qtype(Q::Infix::Modulo), + :qtype(TYPE), ), 'infix:%%' => op( sub ($lhs, $rhs) { @@ -308,7 +316,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); }, - :qtype(Q::Infix::Divisibility), + :qtype(TYPE), ), 'infix:x' => op( sub ($lhs, $rhs) { @@ -318,7 +326,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap($lhs.value x $rhs.value); }, - :qtype(Q::Infix::Replicate), + :qtype(TYPE), :precedence{ equal => "infix:*" }, ), 'infix:xx' => op( @@ -329,14 +337,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $rhs ~~ _007::Object && $rhs.isa("Int"); return wrap(| $lhs.value xx $rhs.value); }, - :qtype(Q::Infix::ArrayReplicate), + :qtype(TYPE), :precedence{ equal => "infix:*" }, ), # prefixes 'prefix:~' => op( sub prefix-str($expr) { wrap($expr.Str) }, - :qtype(Q::Prefix::Str), + :qtype(TYPE), ), 'prefix:+' => op( sub prefix-plus($expr) { @@ -354,7 +362,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { :got($expr), :expected(_007::Object)); }, - :qtype(Q::Prefix::Plus), + :qtype(TYPE), ), 'prefix:-' => op( sub prefix-minus($expr) { @@ -372,19 +380,19 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { :got($expr), :expected(_007::Object)); }, - :qtype(Q::Prefix::Minus), + :qtype(TYPE), ), 'prefix:?' => op( sub ($a) { return wrap(?$a.truthy) }, - :qtype(Q::Prefix::So), + :qtype(TYPE), ), 'prefix:!' => op( sub ($a) { return wrap(!$a.truthy) }, - :qtype(Q::Prefix::Not), + :qtype(TYPE), ), 'prefix:^' => op( sub ($n) { @@ -392,18 +400,18 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { unless $n ~~ _007::Object && $n.isa("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), ), ; @@ -427,14 +435,20 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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({ $_ => NONE })); + my $q = $placeholder.qtype.create(|%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(wrap($^value))))) }; + my ¶meter = { + TYPE.create(:identifier(TYPE.create( + :name(wrap($^value)), + :frame(NONE), + ))) + }; return @builtins.map: { when .value ~~ _007::Type | Val::Type { @@ -443,17 +457,17 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { when .value ~~ Block { my @elements = .value.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = Q::ParameterList.new(:$parameters); - my $statementlist = Q::StatementList.new(); + my $parameterlist = TYPE.create(:$parameters); + my $statementlist = TYPE.create(:statements(wrap([]))); .key => wrap-fn(.value, .key, $parameterlist, $statementlist); } when .value ~~ Placeholder::MacroOp { my $name = .key; install-op($name, .value); - my @elements = .value.qtype.attributes».name».substr(2).grep({ $_ ne "identifier" })».¶meter; + my @elements = .value.qtype.fields.grep({ $_ ne "identifier" })».¶meter; my $parameters = wrap(@elements); - my $parameterlist = Q::ParameterList.new(:$parameters); - my $statementlist = Q::StatementList.new(); + my $parameterlist = TYPE.create(:$parameters); + my $statementlist = TYPE.create(:statements(wrap([]))); .key => wrap-fn(sub () {}, $name, $parameterlist, $statementlist); } when .value ~~ Placeholder::Op { @@ -462,8 +476,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my &fn = .value.fn; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = Q::ParameterList.new(:$parameters); - my $statementlist = Q::StatementList.new(); + my $parameterlist = TYPE.create(:$parameters); + my $statementlist = TYPE.create(:statements(wrap([]))); .key => wrap-fn(&fn, $name, $parameterlist, $statementlist); } default { die "Unknown type {.value.^name}" } diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index d341dbb4..3e1f65a2 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -47,112 +47,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.value -> $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; + my $pad = $block.properties; if $pad.value{$name} { - return "{$block.WHICH.Str}|$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.isa("Q::Statement::Block") -> $stblock { + traverse($stblock.properties); } - } - - multi traverse(Q::ArgumentList $argumentlist) { - for $argumentlist.arguments.value -> $expr { - traverse($expr); + elsif $node.isa("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.isa("Q::StatementList") -> $statementlist { + for $statementlist.properties.value -> $stmt { + traverse($stmt); + } + } + elsif $node.isa("Q::Statement::Sub") -> $sub { + my $name = $sub.properties.properties; + %declared{"{@blocks[*-1].id}|$name"} = L::SubNotUsed; + } + elsif $node.isa("Q::Statement::Expr") -> $stexpr { + traverse($stexpr.properties); + } + elsif $node.isa("Q::Postfix::Call") -> $call { + traverse($call.properties); + traverse($call.properties); + } + elsif $node.isa("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.isa("Q::ArgumentList") -> $argumentlist { + for $argumentlist.properties.value -> $expr { + traverse($expr); + } + } + elsif $node.isa("Q::Statement::For") -> $for { + traverse($for.properties); + traverse($for.properties); + } + elsif $node.isa("Q::Statement::My") -> $my { + my $name = $my.properties.properties; + my $ref = "{@blocks[*-1].id}|$name"; + %declared{$ref} = L::VariableNotUsed; + if $my.properties !=== NONE { + traverse($my.properties); + %assigned{$ref} = True; + if $my.properties.isa("Q::Identifier") && $my.properties.properties.value eq $name { + @complaints.push: L::RedundantAssignment.new(:$name); + %readbeforeassigned{$ref} :delete; + } + } + } + elsif $node.isa("Q::Infix::Assignment") -> $infix { + traverse($infix.properties); + die "LHS was not an identifier" + unless $infix.properties.isa("Q::Identifier"); + my $name = $infix.properties.properties.value; + if $infix.properties.isa("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.isa("Q::Infix::Addition") -> $infix { + traverse($infix.properties); + traverse($infix.properties); + } + elsif $node.isa("Q::ParameterList") -> $parameterlist { + # nothing + } + elsif $node.isa("Q::Literal") -> $literal { + # nothing + } + elsif $node.isa("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/OpScope.pm b/lib/_007/OpScope.pm index 677bbe2e..e6a6ade6 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -15,12 +15,15 @@ class _007::OpScope { method install($type, $op, $q?, :%precedence, :$assoc) { my $name = "$type:$op"; - my $identifier = Q::Identifier.new(:name(wrap($name))); + my $identifier = TYPE.create( + :name(wrap($name)), + :frame(NONE), + ); %!ops{$type}{$op} = $q !=== Any ?? $q !! { - prefix => Q::Prefix.new(:$identifier), - infix => Q::Infix.new(:$identifier), - postfix => Q::Postfix.new(:$identifier), + prefix => TYPE.create(:$identifier, :operand(NONE)), + infix => TYPE.create(:$identifier, :lhs(NONE), :rhs(NONE)), + postfix => TYPE.create(:$identifier, :operand(NONE)), }{$type}; sub prec { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index d0fe0cbb..bb1afe61 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -52,9 +52,12 @@ class X::Precedence::Incompatible is Exception { method message { "Trying to relate a pre/postfix operator with an infix operator" } } +sub empty-array() { wrap([]) } +sub empty-dict() { wrap({}) } + class _007::Parser::Actions { method finish-block($block) { - $block.static-lexpad = $*runtime.current-frame.value; + $block.properties = $*runtime.current-frame.value; $*runtime.leave; } @@ -63,21 +66,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 = TYPE.create( + :parameterlist(TYPE.create( + :parameters(empty-array()), + )), + :statementlist($.ast), + :static-lexpad(empty-dict()), + ); + make TYPE.create(:$block); + self.finish-block($block); } method statementlist($/) { my $statements = wrap($».ast); - make Q::StatementList.new(:$statements); + make TYPE.create(:$statements); } method statement:my ($/) { - make Q::Statement::My.new( + make TYPE.create( :identifier($.ast), :expr($ ?? $.ast !! NONE)); } @@ -86,34 +92,34 @@ class _007::Parser::Actions { die X::Syntax::Missing.new(:what("initializer on constant declaration")) unless $; - make Q::Statement::Constant.new( + make TYPE.create( :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")($value, $*runtime); } 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(wrap("postfix:()")))), - :operand(Q::Term::Sub.new(:identifier(NONE), :block($.ast))), - :argumentlist(Q::ArgumentList.new) + if $.ast.isa("Q::Block") { + make TYPE.create(:expr(TYPE.create( + :identifier(TYPE.create(:name(wrap("postfix:()")))), + :operand(TYPE.create(:identifier(NONE), :block($.ast))), + :argumentlist(TYPE.create()) ))); } else { - make Q::Statement::Expr.new(:expr($.ast)); + make TYPE.create(:expr($.ast)); } } method statement:block ($/) { die X::PointyBlock::SinkContext.new if $; - make Q::Statement::Block.new(:block($.ast)); + make TYPE.create(:block($.ast)); } sub maybe-install-operator($identname, @trait) { @@ -128,26 +134,26 @@ class _007::Parser::Actions { my @prec-traits = ; my $assoc; for @trait -> $trait { - my $name = $trait.ast.name; + my $name = $trait.ast.properties; 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.isa("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.isa("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; @@ -168,30 +174,34 @@ 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 $block = TYPE.create( + :$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); + make TYPE.create(:$identifier, :$traitlist, :$block); $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); } elsif $ eq "macro" { - make Q::Statement::Macro.new(:$identifier, :$traitlist, :$block); + make TYPE.create(:$identifier, :$traitlist, :$block); $val = TYPE.create(:$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")($val, $*runtime); maybe-install-operator($name, $); } @@ -199,11 +209,11 @@ class _007::Parser::Actions { method statement:return ($/) { die X::ControlFlow::Return.new unless $*insub; - make Q::Statement::Return.new(:expr($ ?? $.ast !! NONE)); + make TYPE.create(:expr($ ?? $.ast !! NONE)); } method statement:throw ($/) { - make Q::Statement::Throw.new(:expr($ ?? $.ast !! NONE)); + make TYPE.create(:expr($ ?? $.ast !! NONE)); } method statement:if ($/) { @@ -212,62 +222,66 @@ class _007::Parser::Actions { ?? $.ast !! NONE; - make Q::Statement::If.new(|%parameters); + make TYPE.create(|%parameters); } method statement:for ($/) { - make Q::Statement::For.new(|$.ast); + make TYPE.create(|$.ast); } method statement:while ($/) { - make Q::Statement::While.new(|$.ast); + make TYPE.create(|$.ast); } method statement:BEGIN ($/) { my $block = $.ast; - make Q::Statement::BEGIN.new(:$block); - $*runtime.run(Q::CompUnit.new(:$block)); + make TYPE.create(:$block); + $*runtime.run(TYPE.create(:$block)); } method statement:class ($/) { my $identifier = $.ast; my $block = $.ast; - make Q::Statement::Class.new(:$block); + make TYPE.create(:$block); my $val = Val::Type.of(EVAL qq[class :: \{ method attributes \{ () \} - method ^name(\$) \{ "{$identifier.name.value}" \} + method ^name(\$) \{ "{$identifier.properties.value}" \} \}]); - $identifier.put-value($val, $*runtime); + bound-method($identifier, "put-value")($val, $*runtime); } 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); } my $traits = wrap(@traits); - make Q::TraitList.new(:$traits); + make TYPE.create(:$traits); } method trait($/) { - make Q::Trait.new(:identifier($.ast), :expr($.ast)); + make TYPE.create(:identifier($.ast), :expr($.ast)); } method blockoid ($/) { make $.ast; } method block ($/) { - my $block = Q::Block.new( - :parameterlist(Q::ParameterList.new), - :statementlist($.ast)); + my $block = TYPE.create( + :parameterlist(TYPE.create( + :parameters(empty-array()), + )), + :statementlist($.ast) + :static-lexpad(NONE)); make $block; self.finish-block($block); } method pblock ($/) { if $ { - my $block = Q::Block.new( + my $block = TYPE.create( :parameterlist($.ast), - :statementlist($.ast)); + :statementlist($.ast), + :static-lexpad(empty-dict())); make $block; self.finish-block($block); } else { @@ -282,9 +296,9 @@ class _007::Parser::Actions { } sub is-macro($q, $qtype, $identifier) { - $q ~~ $qtype - && $identifier ~~ Q::Identifier - && (my $macro = $*runtime.maybe-get-var($identifier.name.value)) ~~ _007::Object + $q.isa($qtype) + && $identifier.isa("Q::Identifier") + && (my $macro = $*runtime.maybe-get-var($identifier.properties.value)) ~~ _007::Object && $macro.isa("Macro") && $macro; } @@ -292,29 +306,29 @@ class _007::Parser::Actions { sub expand($macro, @arguments, &unexpanded-callback:()) { 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.isa("Q::Statement::My") { + _007::Parser::Syntax::declare(TYPE, $expansion.properties.properties.value); } if $*unexpanded { return &unexpanded-callback(); } else { - if $expansion ~~ Q::Statement { + if $expansion.isa("Q::Statement") { my $statements = wrap([$expansion]); - $expansion = Q::StatementList.new(:$statements); + $expansion = TYPE.create(:$statements); } elsif $expansion === NONE { my $statements = wrap([]); - $expansion = Q::StatementList.new(:$statements); + $expansion = TYPE.create(:$statements); } - if $expansion ~~ Q::StatementList { - $expansion = Q::Expr::StatementListAdapter.new(:statementlist($expansion)); + if $expansion.isa("Q::StatementList") { + $expansion = TYPE.create(:statementlist($expansion)); } - if $expansion ~~ Q::Block { - $expansion = Q::Expr::StatementListAdapter.new(:statementlist($expansion.statementlist)); + if $expansion.isa("Q::Block") { + $expansion = TYPE.create(:statementlist($expansion.properties)); } return $expansion; @@ -323,7 +337,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) { @@ -342,6 +356,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 { @@ -349,27 +368,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.isa("Q::Unquote") { + @termstack.push(TYPE.create( + :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)) })); + -> { $infix.type.create(:lhs($t1), :rhs($t2), :identifier($infix.properties)) })); } else { - @termstack.push($infix.new(:lhs($t1), :rhs($t2), :identifier($infix.identifier))); + @termstack.push($infix.type.create(:lhs($t1), :rhs($t2), :identifier($infix.properties))); - if $infix ~~ Q::Infix::Assignment && $t1 ~~ Q::Identifier { + if $infix.isa("Q::Infix::Assignment") && $t1.isa("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}++; } } @@ -380,7 +404,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); @@ -394,7 +420,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) { @@ -421,43 +447,47 @@ 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.isa("Q::Unquote") { + make TYPE.create( + :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)) }); + -> { $prefix.type.create(:operand($/.ast), :identifier($prefix.properties)) }); } else { - make $prefix.new(:operand($/.ast), :identifier($prefix.identifier)); + make $prefix.type.create(: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.value, - -> { $postfix.new(:$identifier, :operand($/.ast), :argumentlist($postfix.argumentlist)) }); + my $identifier = $postfix.properties; + if my $macro = is-macro($postfix, TYPE, $/.ast) { + make expand($macro, $postfix.properties.properties.value, + -> { $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)) }); } - elsif $postfix ~~ Q::Postfix::Index { - make $postfix.new(:$identifier, :operand($/.ast), :index($postfix.index)); + elsif $postfix.isa("Q::Postfix::Index") { + make $postfix.type.create(:$identifier, :operand($/.ast), :index($postfix.properties)); } - elsif $postfix ~~ Q::Postfix::Call { - make $postfix.new(:$identifier, :operand($/.ast), :argumentlist($postfix.argumentlist)); + elsif $postfix.isa("Q::Postfix::Call") { + make $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)); } - elsif $postfix ~~ Q::Postfix::Property { - make $postfix.new(:$identifier, :operand($/.ast), :property($postfix.property)); + elsif $postfix.isa("Q::Postfix::Property") { + make $postfix.type.create(:$identifier, :operand($/.ast), :property($postfix.properties)); } else { - if my $macro = is-macro($postfix, Q::Postfix, $identifier) { + if my $macro = is-macro($postfix, TYPE, $identifier) { make expand($macro, [$/.ast], - -> { $postfix.new(:$identifier, :operand($/.ast)) }); + -> { $postfix.type.create(:$identifier, :operand($/.ast)) }); } else { - make $postfix.new(:$identifier, :operand($/.ast)); + make $postfix.type.create(:$identifier, :operand($/.ast)); } } } @@ -488,11 +518,11 @@ class _007::Parser::Actions { method prefix($/) { my $op = ~$/; - my $identifier = Q::Identifier.new( + my $identifier = TYPE.create( :name(wrap("prefix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.new(:$identifier, :operand(TYPE)); + make $*parser.opscope.ops{$op}.type.create(:$identifier, :operand(NONE)); } method prefix-unquote($/) { @@ -505,23 +535,23 @@ class _007::Parser::Actions { if $s ~~ /\n/; }(~$0); my $value = wrap((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); - make Q::Literal::Str.new(:$value); + make TYPE.create(:$value); } method term:none ($/) { - make Q::Literal::None.new; + make TYPE.create(); } method term:false ($/) { - make Q::Literal::Bool.new(:value(FALSE)); + make TYPE.create(:value(FALSE)); } method term:true ($/) { - make Q::Literal::Bool.new(:value(TRUE)); + make TYPE.create(:value(TRUE)); } method term:int ($/) { - make Q::Literal::Int.new(:value(wrap(+$/))); + make TYPE.create(:value(wrap(+$/))); } method term:str ($/) { @@ -530,7 +560,7 @@ class _007::Parser::Actions { method term:array ($/) { my $elements = wrap($».ast); - make Q::Term::Array.new(:$elements); + make TYPE.create(:$elements); } method term:parens ($/) { @@ -538,12 +568,12 @@ class _007::Parser::Actions { } method term:regex ($/) { - make Q::Term::Regex.new(:contents($.ast.value)); + make TYPE.create(: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 { @@ -576,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.value[0]; - make Q::Term::Quasi.new(:$contents, :$qtype); + my $contents = $block.ast.properties.properties.value[0]; + make TYPE.create(:$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 TYPE.create(:$contents, :$qtype); return; } elsif $qtype.value ne "Q::Block" - && $block.ast ~~ Q::Block - && $block.ast.statementlist.statements.value.elems == 1 - && $block.ast.statementlist.statements.value[0] ~~ Q::Statement::Expr { + && $block.ast.isa("Q::Block") + && $block.ast.properties.properties.value.elems == 1 + && $block.ast.properties.properties.value[0].isa("Q::Statement::Expr") { - my $contents = $block.ast.statementlist.statements.value[0].expr; - make Q::Term::Quasi.new(:$contents, :$qtype); + my $contents = $block.ast.properties.properties.value[0].properties; + make TYPE.create(:$contents, :$qtype); return; } } @@ -602,7 +632,7 @@ class _007::Parser::Actions { if $/{$subrule} -> $submatch { my $contents = $submatch.ast; - make Q::Term::Quasi.new(:$contents, :$qtype); + make TYPE.create(:$contents, :$qtype); return; } } @@ -615,32 +645,32 @@ class _007::Parser::Actions { my $traitlist = $.ast; my $statementlist = $.ast; - my $block = Q::Block.new(:$parameterlist, :$statementlist); + my $block = TYPE.create(:$parameterlist, :$statementlist, :static-lexpad(empty-dict())); if $ { - my $name = $.ast.name; + my $name = $.ast.properties; my $outer-frame = $*runtime.current-frame.value; my $static-lexpad = $*runtime.current-frame.value; my $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); - $.ast.put-value($val, $*runtime); + bound-method($.ast, "put-value")($val, $*runtime); } self.finish-block($block); - my $name = $.ast.name; + my $name = $ && $.ast.properties; my $identifier = $ - ?? Q::Identifier.new(:$name) + ?? TYPE.create(:$name, :frame(NONE)) !! NONE; - make Q::Term::Sub.new(:$identifier, :$traitlist, :$block); + make TYPE.create(:$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 TYPE.create(:$qtype, :expr($.ast)); } method term:new-object ($/) { - my $type = $.ast.name.value; + my $type = $.ast.properties.value; my $type-var = $*runtime.get-var($type); my $type-obj = $type-var ~~ _007::Type ?? $type-var @@ -668,65 +698,78 @@ class _007::Parser::Actions { # unless $property eq any($.ast.value.value».key».value); # } - make Q::Term::Object.new( - :type(Q::Identifier.new(:name(wrap($type)))), + make TYPE.create( + :type(TYPE.create( + :name(wrap($type)), + :frame(NONE), + )), :propertylist($.ast)); } method term:dict ($/) { - make Q::Term::Dict.new( + make TYPE.create( :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}++; } my $properties = wrap($».ast); - make Q::PropertyList.new(:$properties); + make TYPE.create(:$properties); } method property:str-expr ($/) { - make Q::Property.new(:key($.ast.value), :value($.ast)); + make TYPE.create(: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 TYPE.create(:$key, :value($.ast)); } method property:identifier ($/) { - my $key = $.ast.name; - make Q::Property.new(:$key, :value($.ast)); + my $key = $.ast.properties; + make TYPE.create(:$key, :value($.ast)); } method property:method ($/) { - my $block = Q::Block.new( + my $block = TYPE.create( :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 = TYPE.create(:$name, :frame(NONE)); + make TYPE.create( + :key($name), + :value(TYPE.create( + :$identifier, + :$block, + :traitlist(TYPE.create( + :traits(wrap([])), + )), + )), + ); self.finish-block($block); } method infix($/) { my $op = ~$/; - my $identifier = Q::Identifier.new( + my $identifier = TYPE.create( :name(wrap("infix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.new(:$identifier, :lhs(NONE), :rhs(NONE)); + make $*parser.opscope.ops{$op}.type.create(:$identifier, :lhs(NONE), :rhs(NONE)); } method infix-unquote($/) { my $got = ~($ // "Q::Term"); - die X::TypeCheck.new(:operation, :$got, :expected(Q::Infix)) + die X::TypeCheck.new(:operation, :$got, :expected(_007::Object)) unless $got eq "Q::Infix"; make $.ast; @@ -743,23 +786,23 @@ class _007::Parser::Actions { elsif $ { $op = "."; } - my $identifier = Q::Identifier.new( + my $identifier = TYPE.create( :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 TYPE.create(index => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make Q::Postfix::Call.new(argumentlist => $.ast, :$identifier, :operand(NONE)); + make TYPE.create(argumentlist => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make Q::Postfix::Property.new(property => $.ast, :$identifier, :operand(NONE)); + make TYPE.create(property => $.ast, :$identifier, :operand(NONE)); } else { - make $*parser.opscope.ops{$op}.new(:$identifier, :operand(NONE)); + make $*parser.opscope.ops{$op}.type.create(:$identifier, :operand(NONE)); } } @@ -773,20 +816,20 @@ class _007::Parser::Actions { $value ~~ s:g['\\\\'] = '\\'; }(); my $name = wrap($value); - make Q::Identifier.new(:$name); + make TYPE.create(:$name, :frame(NONE)); } method argumentlist($/) { my $arguments = wrap($».ast); - make Q::ArgumentList.new(:$arguments); + make TYPE.create(:$arguments); } method parameterlist($/) { my $parameters = wrap($».ast); - make Q::ParameterList.new(:$parameters); + make TYPE.create(:$parameters); } method parameter($/) { - make Q::Parameter.new(:identifier($.ast)); + make TYPE.create(:identifier($.ast)); } } diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index 3db5d446..52a9e5ba 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -19,7 +19,9 @@ grammar _007::Parser::Syntax { token newpad { { $*parser.push-opscope; @*declstack.push(@*declstack ?? @*declstack[*-1].clone !! {}); - $*runtime.enter($*runtime.current-frame, wrap({}), Q::StatementList.new); + $*runtime.enter($*runtime.current-frame, wrap({}), TYPE.create( + :statements(wrap([])), + )); } } token finishpad { { @@ -35,14 +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 $name = wrap($symbol); - my $identifier = Q::Identifier.new(:$name, :$frame); + my $identifier = TYPE.create(:$name, :$frame); $*runtime.declare-var($identifier); @*declstack[*-1]{$symbol} = $decltype; } @@ -50,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); } ['=' ]? } @@ -72,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> '(' ~ ')' @@ -113,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); } } @@ -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 index a9e11309..4c49c9ee 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -1,28 +1,5 @@ use _007::Val; -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; @@ -40,14 +17,6 @@ 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 empty-array() { wrap([]) } sub aname($attr) { $attr.name.substr(2) } @@ -207,19 +176,9 @@ class Q::Term::Object does Q::Term { method eval($runtime) { my $type = $runtime.get-var($.type.name.value, $.type.frame); - if $type === TYPE { - return $type.create(|hash($.propertylist.properties.value.map(-> $property { - $property.key.value => $property.value.eval($runtime) - }))); - } - if $type ~~ _007::Type { - my $value = $.propertylist.properties.value[0].value.eval($runtime); - # XXX: cheat less - return $value; - } - return $runtime.get-var($.type.name.value, $.type.frame).create( - $.propertylist.properties.value.map({.key.value => .value.eval($runtime)}) - ); + return $type.create(|hash($.propertylist.properties.value.map(-> $property { + $property.key.value => $property.value.eval($runtime) + }))); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 7b742fc0..a575b94d 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -4,7 +4,7 @@ use _007::Builtins; use _007::OpScope; constant NO_OUTER = wrap({}); -constant RETURN_TO = Q::Identifier.new( +constant RETURN_TO = TYPE.create( :name(wrap("--RETURN-TO--")), :frame(NONE)); @@ -16,14 +16,16 @@ class _007::Runtime { has $.builtin-frame; submethod BUILD(:$!input, :$!output) { - self.enter(NO_OUTER, wrap({}), Q::StatementList.new); + self.enter(NO_OUTER, wrap({}), TYPE.create( + :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; @@ -38,17 +40,17 @@ class _007::Runtime { }); @!frames.push($frame); for $static-lexpad.value.kv -> $name, $value { - my $identifier = Q::Identifier.new( + my $identifier = TYPE.create( :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); } - for $statementlist.statements.value.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 .isa("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 = TYPE.create( :$name, @@ -57,12 +59,12 @@ class _007::Runtime { :$static-lexpad, :$outer-frame ); - self.declare-var(.identifier, $val); + self.declare-var(.properties, $val); } } if $routine { my $name = $routine.properties; - my $identifier = Q::Identifier.new(:$name, :$frame); + my $identifier = TYPE.create(:$name, :$frame); self.declare-var($identifier, $routine); } } @@ -99,11 +101,11 @@ class _007::Runtime { if $symbol eq RETURN_TO; } - method put-var(Q::Identifier $identifier, $value) { - my $name = $identifier.name.value; - my $frame = $identifier.frame === NONE + 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.value{$name} = $value; } @@ -119,11 +121,11 @@ class _007::Runtime { } } - method declare-var(Q::Identifier $identifier, $value?) { - my $name = $identifier.name.value; - my _007::Object::Wrapped $frame = $identifier.frame === NONE + 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; + !! $identifier.properties; $frame.value.value{$name} = $value // NONE; } @@ -144,7 +146,7 @@ class _007::Runtime { method load-builtins { my $opscope = $!builtin-opscope; for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { - my $identifier = Q::Identifier.new( + my $identifier = TYPE.create( :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); @@ -155,11 +157,18 @@ class _007::Runtime { sub builtin(&fn) { my $name = &fn.name; my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { Q::Parameter.new(:identifier(Q::Identifier.new(:name(wrap($^value))))) }; + my ¶meter = { + TYPE.create( + :identifier(TYPE.create( + :name(wrap($^value)) + :frame(NONE)) + ) + ) + }; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = Q::ParameterList.new(:$parameters); - my $statementlist = Q::StatementList.new(); + my $parameterlist = TYPE.create(:$parameters); + my $statementlist = TYPE.create(:statements(wrap([]))); return wrap-fn(&fn, $name, $parameterlist, $statementlist); } @@ -181,10 +190,10 @@ class _007::Runtime { if $thing ~~ Val; return $thing.new(:name($thing.name), :frame(NONE)) - if $thing ~~ Q::Identifier; + if $thing.isa("Q::Identifier"); return $thing - if $thing ~~ Q::Unquote; + if $thing.isa("Q::Unquote"); my %attributes = $thing.attributes.map: -> $attr { aname($attr) => interpolate(avalue($attr, $thing)) @@ -201,7 +210,7 @@ class _007::Runtime { sub aname($attr) { $attr.name.substr(2) } my %known-properties = $obj.WHAT.attributes.map({ aname($_) => 1 }); # XXX: hack - if $obj ~~ Q::Block { + if $obj.isa("Q::Block") { %known-properties = 1; } @@ -210,6 +219,44 @@ class _007::Runtime { return $obj."$propname"(); } + elsif $obj ~~ _007::Object && $obj.isa("Q") { + if $propname eq "detach" { + sub interpolate($thing) { + return wrap($thing.value.map(&interpolate)) + if $thing ~~ _007::Object && $thing.isa("Array"); + + sub interpolate-entry($_) { .key => interpolate(.value) } + return wrap(hash($thing.value.map(&interpolate-entry))) + if $thing ~~ _007::Object && $thing.isa("Dict"); + + return $thing + if $thing ~~ Val; + + return $thing.type.create(:name($thing.properties), :frame(NONE)) + if $thing.isa("Q::Identifier"); + + return $thing + if $thing.isa("Q::Unquote"); + + my %properties = $thing.type.type-chain.reverse.map({ .fields }).flat.map: -> $fieldname { + $fieldname => interpolate($thing.properties{$fieldname}) + }; + + $thing.type.create(|%properties); + } + + return builtin(sub detach() { + return interpolate($obj); + }); + } + + my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); + + die X::Property::NotFound.new(:$propname, :$type) + unless %known-properties{$propname}; + + return $obj.properties{$propname}; + } elsif $obj ~~ _007::Object && $obj.isa("Int") && $propname eq "abs" { return builtin(sub abs() { return wrap($obj.value.abs); @@ -399,9 +446,11 @@ class _007::Runtime { } elsif $obj ~~ _007::Type && $propname eq "create" { return builtin(sub create($properties) { - # XXX: needs more sanity checking - wrap($properties.value[0].value[1].value); # XXX: won't work for non-wrapped objects - # _007::Object.new(:value($properties.value[0].value[1].value)); + # XXX: check that $properties is an array of [k, v] arrays + $obj.create(|hash($properties.value.map(-> $p { + my ($k, $v) = @($p.value); + $k.value => $v; + }))); }); } elsif $obj ~~ Val::Type && $propname eq "create" { @@ -418,6 +467,9 @@ class _007::Runtime { elsif $obj ~~ _007::Object && $obj.isa("Dict") && ($obj.value{$propname} :exists) { return $obj.value{$propname}; } + elsif $obj ~~ _007::Object && ($obj.properties{$propname} :exists) { + return $obj.properties{$propname}; + } elsif $propname eq "get" { return builtin(sub get($prop) { return self.property($obj, $prop.value); diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 9a4dc498..1f269f14 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -9,69 +9,69 @@ use Test; sub read(Str $ast) is export { sub n($type, $op) { my $name = wrap($type ~ ":<$op>"); - return Q::Identifier.new(:$name); + return TYPE.create(:$name, :frame(NONE)); } my %q_lookup = - none => Q::Literal::None, - int => Q::Literal::Int, - str => Q::Literal::Str, - array => Q::Term::Array, - dict => Q::Term::Dict, - 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 @@ -105,35 +105,58 @@ 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; sub check-if-operator() { if $qname ~~ /^ [prefix | infix | postfix] ":"/ { # XXX: it stinks that we have to do this my $name = wrap($qname); - %arguments = Q::Identifier.new(:$name); + %arguments = TYPE.create(:$name, :frame(NONE)); shift @attributes; # $.identifier } }(); - sub aname($attr) { $attr.name.substr(2) } - if @attributes == 1 && (%qtype-has-just-array{$qtype.^name} :exists) { - my $aname = aname(@attributes[0]); + 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 //= NONE; + } + if $qtype === TYPE { + %arguments //= wrap({}); + } + if $qtype === TYPE | TYPE { + %arguments //= TYPE.create( + :traits(wrap([])), + ); + } + if $qtype === TYPE { + %arguments //= NONE; + } + if $qtype === TYPE { + %arguments //= NONE; + } + if $qtype === TYPE { + %arguments //= NONE; + } + make $qtype.create(|%arguments); } method expr:symbol ($/) { make ~$/ } method expr:int ($/) { make wrap(+$/) } @@ -142,9 +165,12 @@ sub read(Str $ast) is export { 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 TYPE.create(:block(TYPE.create( + :parameterlist(TYPE.create( + :parameters(wrap([])), + )), + :statementlist($/.ast), + :static-lexpad(wrap({})), ))); } @@ -160,122 +186,120 @@ 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.value -> $statement { - handle($statement); + sub handle($ast) { + if $ast.isa("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 !=== NONE { - handle($my.expr); + elsif $ast.isa("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.value; - $runtime.leave(); - } - - multi handle(Q::Statement::Sub $sub) { - my $outer-frame = $runtime.current-frame; - my $name = $sub.identifier.name; - my $val = TYPE.create( - :$name, - :parameterlist($sub.block.parameterlist), - :statementlist($sub.block.statementlist), - :$outer-frame, - ); - $runtime.enter($outer-frame, wrap({}), $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 = TYPE.create( - :$name, - :parameterlist($macro.block.parameterlist), - :statementlist($macro.block.statementlist), - :$outer-frame - ); - $runtime.enter($outer-frame, wrap({}), $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, wrap({}), Q::StatementList.new); - handle($block.parameterlist); - handle($block.statementlist); - $block.static-lexpad = $runtime.current-frame.value; - $runtime.leave(); - } - - multi handle(Q::Term::Object $object) { - handle($object.propertylist); - } - - multi handle(Q::PropertyList $propertylist) { - my %seen; - for $propertylist.properties.value -> Q::Property $p { - my Str $property = $p.key.value; - die X::Property::Duplicate.new(:$property) - if %seen{$property}++; + elsif $ast.isa("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.isa("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.isa("Q::ParameterList") || $ast.isa("Q::Statement::Return") || $ast.isa("Q::Statement::Expr") + || $ast.isa("Q::Statement::BEGIN") || $ast.isa("Q::Literal") || $ast.isa("Q::Term") + || $ast.isa("Q::Postfix") { + # we don't care about descending into these + } + elsif $ast.isa("Q::Statement::Sub") -> $sub { + my $outer-frame = $runtime.current-frame; + my $name = $sub.properties.properties; + my $val = TYPE.create( + :$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.isa("Q::Statement::Macro") -> $macro { + my $outer-frame = $runtime.current-frame; + my $name = $macro.properties.properties; + my $val = TYPE.create( + :$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.isa("Q::Statement::If") -> $if { + handle($if.properties); + } + elsif $ast.isa("Q::Statement::For") -> $for { + handle($for.properties); + } + elsif $ast.isa("Q::Statement::While") -> $while { + handle($while.properties); + } + elsif $ast.isa("Q::Block") -> $block { + $runtime.enter($runtime.current-frame, wrap({}), TYPE.create( + :statements(wrap([])), + )); + handle($block.properties); + handle($block.properties); + $block.properties = $runtime.current-frame.value; + $runtime.leave(); + } + elsif $ast.isa("Q::Term::Object") -> $object { + handle($object.properties); + } + elsif $ast.isa("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}++; + } + } + else { + die "Don't know how to handle type {$ast.type}"; } } + + handle($ast); } sub is-result($input, $expected, $desc = "MISSING TEST DESCRIPTION") is export { diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 9c0607b0..24d9104c 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -31,6 +31,37 @@ class X::Control::Return is Exception { 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" + } +} + class Helper { ... } class _007::Object { ... } @@ -42,6 +73,7 @@ class _007::Type { has Str $.name; has $.base = TYPE; has @.fields; + has Bool $.is-abstract = False; # XXX: $.id method install-base($none) { @@ -67,6 +99,14 @@ class _007::Type { } method create(*%properties) { + die X::Uninstantiable.new(:$.name) + if self.is-abstract; + + # XXX: For Dict and Array, we might instead want to do a shallow copy + if self === TYPE || self === TYPE || self === TYPE || self === TYPE { + return %properties; + } + my $type = $.name; my $fields = set(self.type-chain.map({ .fields })); my $seen = set(); @@ -82,6 +122,14 @@ class _007::Type { # XXX: need to screen for required properties by traversing @.fields, but we don't have the # infrastructure in terms of a way to mark up a field as required + # XXX: for now, let's pretend all properties are required. not pleasant, but we can live with it for a short time + for $fields.keys -> $field { + die "Need to pass property '$field' when creating a $type" + unless $field (elem) $seen; + } + + # XXX: ditto for property default values + return _007::Object.new(:type(self), :%properties); } } @@ -99,17 +147,104 @@ TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "stateme TYPE = _007::Type.new(:name, :base(TYPE)); TYPE = _007::Type.new(:name, :fields["contents"]); +TYPE = _007::Type.new(:name, :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["propertylist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["type", "propertylist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "contents"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["elements"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "frame"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameterlist", "statementlist", "static-lexpad"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "lhs", "rhs"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["index"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["argumentlist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["property"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["operand"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["lhs", "rhs"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["statements"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["arguments"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameters"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["key", "value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["properties"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); + class _007::Object { has $.type; has $.id = unique-id; has %.properties; multi method isa(Str $typename) { - self.isa(TYPE{$typename}); + die "Asked to typecheck against $typename but no such type is declared" + unless TYPE{$typename} :exists; + + return self.isa(TYPE{$typename}); } multi method isa(_007::Type $type) { - return $type (elem) $.type.type-chain; + # 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.isa("Q::StatementList") -> $statementlist { + # # ... + # } + + return $type (elem) $.type.type-chain && self; } method attributes { () } @@ -165,6 +300,522 @@ TYPE.install-base(NONE); constant TRUE is export = _007::Object::Enum.new(:type(TYPE)); constant FALSE is export = _007::Object::Enum.new(:type(TYPE)); +role Val { + method truthy { True } + method attributes { self.^attributes } + method quoted-Str { self.Str } + + method Str { + my %*stringification-seen; + Helper::Str(self); + } +} + +# 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) is export { + if $object.isa("Q::Statement::Block") && $name eq "run" { + return sub run-q-statement-block($runtime) { + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + bound-method($object.properties.properties, "run")($runtime); + $runtime.leave; + }; + } + + if $object.isa("Q::StatementList") && $name eq "run" { + return sub run-q-statementlist($runtime) { + for $object.properties.value -> $statement { + my $value = bound-method($statement, "run")($runtime); + LAST if $statement.isa("Q::Statement::Expr") { + return $value; + } + } + }; + } + + if $object.isa("Q::Statement::Expr") && $name eq "run" { + return sub run-q-statement-expr($runtime) { + return bound-method($object.properties, "eval")($runtime); + }; + } + + if $object.isa("Q::Identifier") && $name eq "eval" { + return sub eval-q-identifier($runtime) { + return $runtime.get-var($object.properties.value, $object.properties); + }; + } + + if $object.isa("Q::Literal::Int") && $name eq "eval" { + return sub eval-q-literal-int($runtime) { + return $object.properties; + }; + } + + if $object.isa("Q::Literal::Str") && $name eq "eval" { + return sub eval-q-literal-str($runtime) { + return $object.properties; + }; + } + + if $object.isa("Q::Term::Dict") && $name eq "eval" { + return sub eval-q-term-dict($runtime) { + return wrap(hash($object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval")($runtime); + }))); + }; + } + + if $object.isa("Q::Identifier") && $name eq "put-value" { + return sub put-value-q-identifier($value, $runtime) { + $runtime.put-var($object, $value); + }; + } + + if $object.isa("Q::Statement::Class") && $name eq "run" { + return sub run-q-statement-class($runtime) { + # a class block does not run at runtime + }; + } + + if $object.isa("Q::Statement::Sub") && $name eq "run" { + return sub run-q-statement-sub($runtime) { + # a sub declaration does not run at runtime + }; + } + + if $object.isa("Q::Statement::Macro") && $name eq "run" { + return sub run-q-statement-macro($runtime) { + # a macro declaration does not run at runtime + }; + } + + if $object.isa("Q::Statement::For") && $name eq "run" { + return sub run-q-statement-for($runtime) { + 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::TypeCheck.new(:operation("for loop"), :got($array), :expected(_007::Object)) + unless $array ~~ _007::Object && $array.isa("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.isa("Q::Statement::While") && $name eq "run" { + return sub run-q-statement-while($runtime) { + while (my $expr = bound-method($object.properties, "eval")($runtime)).truthy { + 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.isa("Q::Term::Object") && $name eq "eval" { + return sub eval-q-term-object($runtime) { + my $type = $runtime.get-var( + $object.properties.properties.value, + $object.properties.properties); + if $type ~~ _007::Type { + return $type.create(|hash($object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval")($runtime) + }))); + } + return $type.create($object.properties.properties.value.map({ + .properties.value => bound-method(.properties, "eval")($runtime) + })); + }; + } + + if $object.isa("Q::Infix::Assignment") && $name eq "eval" { + return sub eval-q-infix-assignment($runtime) { + my $value = bound-method($object.properties, "eval")($runtime); + bound-method($object.properties, "put-value")($value, $runtime); + return $value; + }; + } + + if $object.isa("Q::Infix::And") && $name eq "eval" { + return sub eval-q-infix-and($runtime) { + my $l = bound-method($object.properties, "eval")($runtime); + return $l.truthy + ?? bound-method($object.properties, "eval")($runtime) + !! $l; + }; + } + + if $object.isa("Q::Infix::Or") && $name eq "eval" { + return sub eval-q-infix-or($runtime) { + my $l = bound-method($object.properties, "eval")($runtime); + return $l.truthy + ?? $l + !! bound-method($object.properties, "eval")($runtime); + }; + } + + if $object.isa("Q::Infix::DefinedOr") && $name eq "eval" { + return sub eval-q-infix-definedor($runtime) { + my $l = bound-method($object.properties, "eval")($runtime); + return $l !=== NONE + ?? $l + !! bound-method($object.properties, "eval")($runtime); + }; + } + + # XXX: these should sit on Q::Infix + my @infixes = < + Q::Infix::TypeMatch + Q::Infix::TypeNonMatch + Q::Infix::Eq + Q::Infix::Ne + Q::Infix::Concat + Q::Infix::Addition + Q::Infix::Subtraction + Q::Infix::Multiplication + Q::Infix::Replicate + Q::Infix::ArrayReplicate + Q::Infix::Gt + Q::Infix::Lt + Q::Infix::Ge + Q::Infix::Le + Q::Infix::Modulo + Q::Infix::Divisibility + Q::Infix::Cons + Q::Infix + >; + if any(@infixes.map({ $object.type === TYPE{$_} })) && $name eq "eval" { + return sub eval-q-infix($runtime) { + 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]); + }; + } + + # XXX: these should sit on Q::Prefix + my @prefixes = < + Q::Prefix::Upto + Q::Prefix::Str + Q::Prefix::Plus + Q::Prefix::Minus + Q::Prefix::Not + Q::Prefix + >; + if any(@prefixes.map({ $object.type === TYPE{$_} })) && $name eq "eval" { + return sub eval-q-prefix($runtime) { + my $e = bound-method($object.properties, "eval")($runtime); + my $c = bound-method($object.properties, "eval")($runtime); + return internal-call($c, $runtime, [$e]); + }; + } + + if $object.isa("Q::Postfix::Property") && $name eq "eval" { + return sub eval-q-postfix-property($runtime) { + my $obj = bound-method($object.properties, "eval")($runtime); + my $propname = $object.properties.properties.value; + $runtime.property($obj, $propname); + }; + } + + if $object.isa("Q::Postfix::Index") && $name eq "eval" { + return sub eval-q-postfix-index($runtime) { + given bound-method($object.properties, "eval")($runtime) { + if $_ ~~ _007::Object && .isa("Array") { + my $index = bound-method($object.properties, "eval")($runtime); + die X::Subscript::NonInteger.new + unless $index ~~ _007::Object && $index.isa("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 $_ ~~ _007::Object && (.isa("Dict") || .isa("Sub") || .isa("Q")) { + my $property = bound-method($object.properties, "eval")($runtime); + die X::Subscript::NonString.new + unless $property ~~ _007::Object && $property.isa("Str"); + my $propname = $property.value; + return $runtime.property($_, $propname); + } + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); + } + }; + } + + if $object.isa("Q::Postfix::Call") && $name eq "eval" { + return sub eval-q-postfix-call($runtime) { + my $c = bound-method($object.properties, "eval")($runtime); + die "macro is called at runtime" + if $c ~~ _007::Object && $c.isa("Macro"); + die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: + unless $c ~~ _007::Object && $c.isa("Sub"); + my @arguments = $object.properties.properties.value.map({ + bound-method($_, "eval")($runtime) + }); + return internal-call($c, $runtime, @arguments); + }; + } + + if $object.isa("Q::Postfix") && $name eq "eval" { + return sub eval-q-postfix($runtime) { + my $e = bound-method($object.properties, "eval")($runtime); + my $c = bound-method($object.properties, "eval")($runtime); + return internal-call($c, $runtime, [$e]); + }; + } + + if $object.isa("Q::Statement::My") && $name eq "run" { + return sub run-q-statement-my($runtime) { + return + if $object.properties === NONE; + + my $value = bound-method($object.properties, "eval")($runtime); + bound-method($object.properties, "put-value")($value, $runtime); + }; + } + + if $object.isa("Q::Statement::Constant") && $name eq "run" { + return sub run-q-statement-constant($runtime) { + # value has already been assigned + }; + } + + if $object.isa("Q::Statement::If") && $name eq "run" { + return sub run-q-statement-if($runtime) { + my $expr = bound-method($object.properties, "eval")($runtime); + if $expr.truthy { + 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 .isa("Q::Statement::If") { + bound-method($object.properties, "run")($runtime) + } + when .isa("Q::Block") { + $runtime.enter( + $runtime.current-frame, + $object.properties.properties, + $object.properties.properties); + bound-method($object.properties.properties, "run")($runtime); + $runtime.leave; + } + } + } + }; + } + + if $object.isa("Q::Statement::Return") && $name eq "run" { + return sub run-q-statement-return($runtime) { + 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.isa("Q::Term::Quasi") && $name eq "eval" { + return sub eval-q-term-quasi($runtime) { + sub interpolate($thing) { + return wrap($thing.value.map(&interpolate)) + if $thing ~~ _007::Object && $thing.isa("Array"); + + sub interpolate-entry($_) { .key => interpolate(.value) } + return wrap(hash($thing.value.map(&interpolate-entry))) + if $thing ~~ _007::Object && $thing.isa("Dict"); + + return $thing + if $thing ~~ _007::Type; + + return $thing + if $thing ~~ Val; + + return $thing + if $thing ~~ _007::Object && ($thing.isa("Int") || $thing.isa("Str")); + + return $thing + if $thing ~~ _007::Object && $thing.isa("Sub"); + + return $thing.type.create(:name($thing.properties), :frame($runtime.current-frame)) + if $thing ~~ _007::Object && $thing.isa("Q::Identifier"); + + if $thing ~~ _007::Object && $thing.isa("Q::Unquote::Prefix") { + my $prefix = bound-method($thing.properties, "eval")($runtime); + die X::TypeCheck.new(:operation("interpolating an unquote"), :got($prefix), :expected(_007::Object)) + unless $prefix ~~ _007::Object && $prefix.isa("Q::Prefix"); + return $prefix.type.create(:identifier($prefix.properties), :operand($thing.properties)); + } + elsif $thing ~~ _007::Object && $thing.isa("Q::Unquote::Infix") { + my $infix = bound-method($thing.properties, "eval")($runtime); + die X::TypeCheck.new(:operation("interpolating an unquote"), :got($infix), :expected(_007::Object)) + unless $infix ~~ _007::Object && $infix.isa("Q::Infix"); + return $infix.type.create(:identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); + } + + if $thing ~~ _007::Object && $thing.isa("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 ~~ _007::Object && $ast.isa("Q"); + return $ast; + } + + my %properties = $thing.properties.keys.map: -> $key { $key => interpolate($thing.properties{$key}) }; + + $thing.type.create(|%properties); + } + + if $object.properties.value eq "Q::Unquote" && $object.properties.isa("Q::Unquote") { + return $object.properties; + } + return interpolate($object.properties); + }; + } + + if $object.isa("Q::Term::Sub") && $name eq "eval" { + return sub eval-q-term-sub($runtime) { + 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 TYPE.create(:$name, :$parameterlist, :$statementlist, :$static-lexpad, :$outer-frame); + }; + } + + if $object.isa("Q::Term::Array") && $name eq "eval" { + return sub eval-q-term-array($runtime) { + return wrap($object.properties.value.map({ bound-method($_, "eval")($runtime) })); + }; + } + + if $object.isa("Q::Statement::Throw") && $name eq "run" { + return sub eval-q-statement-throw($runtime) { + my $value = $object.properties === NONE + ?? TYPE.create(:message(wrap("Died"))) + !! bound-method($object.properties, "eval")($runtime); + die X::TypeCheck.new(:got($value), :expected(_007::Object)) + unless $value ~~ _007::Object && $value.isa("Exception"); + + die X::_007::RuntimeException.new(:msg($value.properties.value)); + }; + } + + if $object.isa("Q::Postfix::Index") && $name eq "put-value" { + return sub put-value-q-postfix-index($value, $runtime) { + given bound-method($object.properties, "eval")($runtime) { + if $_ ~~ _007::Object && .isa("Array") { + my $index = bound-method($object.properties, "eval")($runtime); + die X::Subscript::NonInteger.new + unless $index ~~ _007::Object && $index.isa("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 $_ ~~ _007::Object && (.isa("Dict") || .isa("Q")) { + my $property = bound-method($object.properties, "eval")($runtime); + die X::Subscript::NonString.new + unless $property ~~ _007::Object && $property.isa("Str"); + my $propname = $property.value; + $runtime.put-property($_, $propname, $value); + return; + } + die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); + } + }; + } + + if $object.isa("Q::Postfix::Property") && $name eq "put-value" { + return sub put-value-q-postfix-property($value, $runtime) { + given bound-method($object.properties, "eval")($runtime) { + if $_ ~~ _007::Object && (.isa("Dict") || .isa("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.isa("Q::Statement::BEGIN") && $name eq "run" { + return sub run-q-statement-begin($runtime) { + # a BEGIN block does not run at runtime + }; + } + + if $object.isa("Q::Term::Regex") && $name eq "eval" { + return sub eval-q-term-regex($runtime) { + TYPE.create(:contents($object.properties)); + }; + } + + if $object.isa("Q::Literal::None") && $name eq "eval" { + return sub eval-q-literal-none($runtime) { + NONE; + }; + } + + if $object.isa("Q::Literal::Bool") && $name eq "eval" { + return sub eval-q-literal-bool($runtime) { + $object.properties; + }; + } + + if $object.isa("Q::Expr::StatementListAdapter") && $name eq "eval" { + return sub eval-q-expr-statementlistadapter($runtime) { + return bound-method($object.properties, "run")($runtime); + }; + } + + die "The invocant is undefined" + if $object === Any; + die "Method '$name' does not exist on {$object.type.Str}"; +} + sub truthy($v) { $v !=== NONE && $v !=== FALSE } @@ -202,17 +853,6 @@ sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { return _007::Object::Wrapped.new(:type(TYPE), :&value, :%properties); } -role Val { - method truthy { True } - method attributes { self.^attributes } - method quoted-Str { self.Str } - - method Str { - my %*stringification-seen; - Helper::Str(self); - } -} - ### ### Type ### ### A type in 007's type system. All values have a type, which determines @@ -310,17 +950,17 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { return $sub.value()(|@arguments); } - my $paramcount = $sub.properties.parameters.value.elems; + 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.parameters.value) Z @arguments -> ($param, $arg) { - $runtime.declare-var($param.identifier, $arg); + 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 = $sub.properties.run($runtime); + my $value = bound-method($sub.properties, "run")($runtime); $runtime.leave; CATCH { when X::Control::Return { @@ -350,7 +990,9 @@ class Helper { } sub pretty($parameterlist) { - return sprintf "(%s)", $parameterlist.parameters.value».identifier».name.join(", "); + return sprintf "(%s)", $parameterlist.properties.value.map({ + .properties.properties + }).join(", "); } method Str { "" } @@ -373,6 +1015,21 @@ class Helper { when .type === TYPE { "/" ~ .contents.quoted-Str ~ "/" } + when .isa("Q") { + my $self = $_; + my @props = $self.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($self.isa("Q::Identifier") && $_ eq "frame") && + !($self.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return "{$self.type.name} { ($self.properties{@props[0]} // NONE).quoted-Str }"; + } + sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return "{$self.type.name} \{\n$contents\n\}"; + } when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } } diff --git a/t/features/builtins/methods.t b/t/features/builtins/methods.t index 0db74a87..c5bcb6ef 100644 --- a/t/features/builtins/methods.t +++ b/t/features/builtins/methods.t @@ -402,7 +402,8 @@ use _007::Test; { my $program = q:to/./; - say(Q::Identifier.create([["name", "Steve"]])); + # XXX: can remove this "frame" prop once we have property initializers + say(Q::Identifier.create([["name", "Steve"], ["frame", None]])); . outputs $program, qq[Q::Identifier "Steve"\n], "Type.create() method to create a Q::Identifier"; diff --git a/t/features/builtins/operators.t b/t/features/builtins/operators.t index 7c1646a5..3c9b31bc 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -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"))))) @@ -348,7 +348,8 @@ use _007::Test; outputs 'macro foo() {}; say(foo == foo)', "True\n", "a macro is equal to itself"; outputs 'say(say == say)', "True\n", "a built-in sub is equal to itself"; outputs 'say(infix:<+> == infix:<+>)', "True\n", "a built-in operator is equal to itself"; - outputs 'say(new Q::Identifier { name: "foo" } == new Q::Identifier { name: "foo" })', "True\n", + # XXX: can skip `frame` prop once initializers exist + outputs 'say(new Q::Identifier { name: "foo", frame: None } == new Q::Identifier { name: "foo", frame: None })', "True\n", "two Qtrees with equal content are equal"; outputs 'my a = []; for [1, 2] { sub fn() {}; a = [fn, a] }; say(a[1][0] == a[0])', "True\n", "the same sub from two different frames compares favorably to itself"; @@ -368,7 +369,8 @@ use _007::Test; "subs with different parameters are unequal"; outputs 'sub foo() {}; my x = foo; { sub foo() { say("OH HAI") }; say(x == foo) }', "False\n", "subs with different bodies are unequal"; - outputs 'say(new Q::Identifier { name: "foo" } == new Q::Identifier { name: "bar" })', "False\n", + # XXX: can skip `frame` prop once initializers exist + outputs 'say(new Q::Identifier { name: "foo", frame: None } == new Q::Identifier { name: "bar", frame: None })', "False\n", "two Qtrees with distinct content are unequal"; } diff --git a/t/features/macros.t b/t/features/macros.t index f2b890c9..c0c849b1 100644 --- a/t/features/macros.t +++ b/t/features/macros.t @@ -28,8 +28,10 @@ use _007::Test; my $program = q:to/./; macro foo() { return new Q::Postfix::Call { - identifier: new Q::Identifier { name: "postfix:()" }, - operand: new Q::Identifier { name: "say" }, + # XXX: can remove `frame: None` once we have property initializers + identifier: new Q::Identifier { name: "postfix:()", frame: None }, + # XXX: and here + operand: new Q::Identifier { name: "say", frame: None }, argumentlist: new Q::ArgumentList { arguments: [new Q::Literal::Str { value: "OH HAI" }] } diff --git a/t/features/q.t b/t/features/q.t index e4995629..3a82c6c5 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -4,7 +4,12 @@ use _007::Test; { my $program = q:to/./; - my q = new Q::Statement::My { identifier: new Q::Identifier { name: "foo" } }; + # XXX: can remove `frame: None` once we have proper initializers + my q = new Q::Statement::My { + identifier: new Q::Identifier { name: "foo", frame: None }, + # XXX: and `expr: None` too + expr: None, + }; say(q.expr); . @@ -16,7 +21,8 @@ use _007::Test; { my $program = q:to/./; - my q = new Q::Statement::Return {}; + # XXX: Can remove `expr: None` once we have proper initializers + my q = new Q::Statement::Return { expr: None }; say(q.expr); . @@ -36,8 +42,12 @@ use _007::Test; }, statementlist: new Q::StatementList { statements: [] - } - } + }, + # XXX: can remove this later + "static-lexpad": {}, + }, + # XXX: and this + else: None, }; say(q.else); . @@ -51,11 +61,16 @@ use _007::Test; { my $program = q:to/./; my q = new Q::Statement::Sub { - identifier: new Q::Identifier { name: "foo" }, + # XXX: can remove `frame: None` once we have proper initializers + identifier: new Q::Identifier { name: "foo", frame: None }, 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); . @@ -69,11 +84,16 @@ use _007::Test; { my $program = q:to/./; my q = new Q::Statement::Macro { - identifier: new Q::Identifier { name: "moo" }, + # XXX: can remove `frame: None` once we have proper initializers + identifier: new Q::Identifier { name: "moo", frame: None }, 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 c2b02ca5..3f5087b7 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -9,7 +9,7 @@ use _007::Test; my $expected = read( "(statementlist (stexpr (infix:+ (int 1) (int 1))))" - ).block.statementlist.statements.value[0].expr.Str; + ).properties.properties.properties.value[0].properties.Str; outputs $program, "$expected\n", "Basic quasi quoting"; } diff --git a/t/features/unhygienic-declarations.t b/t/features/unhygienic-declarations.t index 06de2f8e..49f41848 100644 --- a/t/features/unhygienic-declarations.t +++ b/t/features/unhygienic-declarations.t @@ -7,7 +7,8 @@ use _007::Test; macro moo() { return new Q::Statement::My { identifier: new Q::Identifier { - name: "agent_name" + name: "agent_name", + frame: None, }, expr: new Q::Literal::Str { value: "James Bond" diff --git a/t/integration/finishblock.t b/t/integration/finishblock.t index 552d162a..80127d76 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 ~~ /"TYPE.create("/ { $blocks-minus-finishblocks++; } if $line ~~ /"self.finish-block("/ { diff --git a/t/self-host/sanity.t b/t/self-host/sanity.t index c0475731..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.value = $compunit; + $ast.properties.properties.value = $compunit; $runtime.run($ast); return $output.result; } From 2f2e0e469672febabdf9bf00a3c664a13d031ec4 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 05:46:01 +0200 Subject: [PATCH 42/91] move a few exception types to where they belong --- lib/_007/OpScope.pm | 4 ++++ lib/_007/Q.pm | 17 ----------------- lib/_007/Runtime.pm | 13 +++++++++++++ 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index e6a6ade6..0a1ebf91 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -2,6 +2,10 @@ use _007::Val; use _007::Q; use _007::Precedence; +class X::Associativity::Conflict is Exception { + method message { "The operator already has a defined associativity" } +} + class _007::OpScope { has %.ops = prefix => {}, diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm index 4c49c9ee..d9f814bc 100644 --- a/lib/_007/Q.pm +++ b/lib/_007/Q.pm @@ -1,22 +1,5 @@ use _007::Val; -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" } -} - sub empty-array() { wrap([]) } sub aname($attr) { $attr.name.substr(2) } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index a575b94d..7860a88a 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -3,6 +3,19 @@ use _007::Q; use _007::Builtins; use _007::OpScope; +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" } +} + constant NO_OUTER = wrap({}); constant RETURN_TO = TYPE.create( :name(wrap("--RETURN-TO--")), From 31b84e73868c60cfef8e2d3b849096902eb499fb Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 06:54:36 +0200 Subject: [PATCH 43/91] remove Q.pm --- META6.json | 1 - lib/_007/Backend/JavaScript.pm | 1 - lib/_007/Builtins.pm | 11 - lib/_007/Linter.pm | 1 - lib/_007/OpScope.pm | 1 - lib/_007/Parser/Actions.pm | 15 +- lib/_007/Parser/Syntax.pm | 1 - lib/_007/Q.pm | 1065 --------------------------- lib/_007/Runtime.pm | 59 +- lib/_007/Test.pm | 1 - t/api-documentation/code-snippets.t | 2 +- t/api-documentation/comments.t | 2 +- 12 files changed, 12 insertions(+), 1148 deletions(-) delete mode 100644 lib/_007/Q.pm diff --git a/META6.json b/META6.json index dc2a6dbe..634cf9b5 100644 --- a/META6.json +++ b/META6.json @@ -15,7 +15,6 @@ "_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", diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index cd622c04..97fffe03 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; my %builtins = "say" => q:to '----', diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index a4807d1b..280258dd 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; sub builtins(:$input!, :$output!, :$opscope!) is export { # These multis are used below by infix:<==> and infix: @@ -66,14 +65,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi equal-value(Val::Type $l, Val::Type $r) { $l.type === $r.type } - multi equal-value(Q $l, Q $r) { - sub same-avalue($attr) { - equal-value($attr.get_value($l), $attr.get_value($r)); - } - - [&&] $l.WHAT === $r.WHAT, - |$l.attributes.map(&same-avalue); - } multi less-value($, $) { die X::TypeCheck.new( @@ -423,8 +414,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } } tree-walk(Val::); - tree-walk(Q::); - push @builtins, "Q" => Val::Type.of(Q); for TYPE.keys -> $type { next if $type eq "Type"; push @builtins, ($type => TYPE{$type}); diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 3e1f65a2..3cf91617 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; role Lint { method message { ... } diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 0a1ebf91..ad58beb6 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; use _007::Precedence; class X::Associativity::Conflict is Exception { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index bb1afe61..038176df 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; use _007::Parser::Syntax; use MONKEY-SEE-NO-EVAL; @@ -468,9 +467,10 @@ class _007::Parser::Actions { sub handle-postfix($/) { my $postfix = @postfixes.shift.ast; my $identifier = $postfix.properties; - if my $macro = is-macro($postfix, TYPE, $/.ast) { - make expand($macro, $postfix.properties.properties.value, - -> { $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)) }); + if is-macro($postfix, TYPE, $/.ast) -> $macro { + make expand($macro, $postfix.properties.properties.value, -> { + $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)); + }); } elsif $postfix.isa("Q::Postfix::Index") { make $postfix.type.create(:$identifier, :operand($/.ast), :index($postfix.properties)); @@ -482,9 +482,10 @@ class _007::Parser::Actions { make $postfix.type.create(:$identifier, :operand($/.ast), :property($postfix.properties)); } else { - if my $macro = is-macro($postfix, TYPE, $identifier) { - make expand($macro, [$/.ast], - -> { $postfix.type.create(:$identifier, :operand($/.ast)) }); + if is-macro($postfix, TYPE, $identifier) -> $macro { + make expand($macro, [$/.ast], -> { + $postfix.type.create(:$identifier, :operand($/.ast)); + }); } else { make $postfix.type.create(:$identifier, :operand($/.ast)); diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index 52a9e5ba..aa190755 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; sub check-feature-flag($feature, $word) { my $flag = "FLAG_007_{$word}"; diff --git a/lib/_007/Q.pm b/lib/_007/Q.pm deleted file mode 100644 index d9f814bc..00000000 --- a/lib/_007/Q.pm +++ /dev/null @@ -1,1065 +0,0 @@ -use _007::Val; - -sub empty-array() { wrap([]) } - -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 _007::Object $.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 _007::Object $.value; - - method eval($) { $.value } -} - -### ### Q::Literal::Str -### -### A string literal. -### -class Q::Literal::Str does Q::Literal { - has _007::Object $.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 _007::Object $.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 _007::Object $.contents; - - method eval($runtime) { - TYPE.create(:$.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 _007::Object $.elements; - - method eval($runtime) { - wrap($.elements.value.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) { - my $type = $runtime.get-var($.type.name.value, $.type.frame); - return $type.create(|hash($.propertylist.properties.value.map(-> $property { - $property.key.value => $property.value.eval($runtime) - }))); - } -} - -### ### Q::Term::Dict -### -### An dictionary. Dict terms consist of a property list -### with zero or more key/value pairs. -### -class Q::Term::Dict does Q::Term { - has $.propertylist; - - method eval($runtime) { - return wrap(hash($.propertylist.properties.value.map({ .key.value => .value.eval($runtime) }))); - } -} - -### ### Q::Property -### -### An object property. Properties have a key and a value. -### -class Q::Property does Q { - has _007::Object $.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 _007::Object $.properties = empty-array(); -} - -### ### 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 _007::Object $.traits = empty-array(); - - 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 === NONE - ?? wrap("") - !! $.identifier.name; - return TYPE.create( - :$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 _007::Object::Wrapped $.static-lexpad is rw = wrap({}); - - 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 internal-call($c, $runtime, [$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 internal-call($c, $runtime, [$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 !=== NONE - ?? $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 internal-call($c, $runtime, [$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) { - if $_ ~~ _007::Object && .isa("Array") { - my $index = $.index.eval($runtime); - die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.isa("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 ($_ ~~ _007::Object && (.isa("Dict") || .isa("Sub"))) || $_ ~~ Q { - my $property = $.index.eval($runtime); - die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.isa("Str"); - my $propname = $property.value; - return $runtime.property($_, $propname); - } - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); - } - } - - method put-value($value, $runtime) { - given $.operand.eval($runtime) { - if $_ ~~ _007::Object && .isa("Array") { - my $index = $.index.eval($runtime); - die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.isa("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 ($_ ~~ _007::Object && .isa("Dict")) || $_ ~~ Q { - my $property = $.index.eval($runtime); - die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.isa("Str"); - my $propname = $property.value; - $runtime.put-property($_, $propname, $value); - return; - } - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); - } - } -} - -### ### 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 ~~ _007::Object && $c.isa("Macro"); - die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: - unless $c ~~ _007::Object && $c.isa("Sub"); - my @arguments = $.argumentlist.arguments.value.map(*.eval($runtime)); - return internal-call($c, $runtime, @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) { - if ($_ ~~ _007::Object && .isa("Dict")) || $_ ~~ Q { - my $propname = $.property.name.value; - $runtime.put-property($_, $propname, $value); - return; - } - 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 wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.isa("Array"); - - return $thing - if $thing ~~ _007::Object; # XXX: won't hold true for everything - - sub interpolate-entry($_) { .key => interpolate(.value) } - return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.isa("Dict"); - - 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 _007::Object $.parameters = empty-array(); -} - -### ### Q::ArgumentList -### -### A list of zero or more arguments. -### -class Q::ArgumentList does Q { - has _007::Object $.arguments = empty-array(); -} - -### ### 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 - if $.expr === NONE; - - 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); - if $.block.parameterlist.parameters.value == 1 { - $runtime.declare-var($.block.parameterlist.parameters.value[0].identifier, $expr); - } - $.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.value.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(_007::Object)) - unless $array ~~ _007::Object && $array.isa("Array"); - - for $array.value -> $arg { - $runtime.enter($runtime.current-frame, $.block.static-lexpad, $.block.statementlist); - if $count == 1 { - $runtime.declare-var($.block.parameterlist.parameters.value[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.value.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.value) 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 === NONE - ?? $.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 === NONE - ?? TYPE.create(:message(wrap("Died"))) - !! $.expr.eval($runtime); - die X::TypeCheck.new(:got($value), :expected(_007::Object)) - unless $value ~~ _007::Object && $value.isa("Exception"); - - die X::_007::RuntimeException.new(:msg($value.properties.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 _007::Object $.statements = empty-array(); - - method run($runtime) { - for $.statements.value -> $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 7860a88a..07c5a399 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -1,5 +1,4 @@ use _007::Val; -use _007::Q; use _007::Builtins; use _007::OpScope; @@ -110,8 +109,6 @@ class _007::Runtime { if $frame.value.value{$symbol} :exists; $frame = $frame.value; } - die X::ControlFlow::Return.new - if $symbol eq RETURN_TO; } method put-var(_007::Object $identifier, $value) { @@ -186,53 +183,7 @@ class _007::Runtime { } 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 wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.isa("Array"); - - sub interpolate-entry($_) { .key => interpolate(.value) } - return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.isa("Dict"); - - return $thing - if $thing ~~ Val; - - return $thing.new(:name($thing.name), :frame(NONE)) - if $thing.isa("Q::Identifier"); - - return $thing - if $thing.isa("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.isa("Q::Block") { - %known-properties = 1; - } - - die X::Property::NotFound.new(:$propname, :$type) - unless %known-properties{$propname}; - - return $obj."$propname"(); - } - elsif $obj ~~ _007::Object && $obj.isa("Q") { + if $obj ~~ _007::Object && $obj.isa("Q") { if $propname eq "detach" { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) @@ -474,9 +425,6 @@ class _007::Runtime { elsif $obj ~~ _007::Object && $obj.isa("Sub") && $propname eq any { return $obj.properties{$propname}; } - elsif $obj ~~ Q && ($obj.properties{$propname} :exists) { - return $obj.properties{$propname}; - } elsif $obj ~~ _007::Object && $obj.isa("Dict") && ($obj.value{$propname} :exists) { return $obj.value{$propname}; } @@ -529,10 +477,7 @@ class _007::Runtime { } method put-property($obj, Str $propname, $newvalue) { - if $obj ~~ Q { - die "We don't handle assigning to Q object properties yet"; - } - elsif $obj !~~ _007::Object || !$obj.isa("Dict") { + if $obj !~~ _007::Object || !$obj.isa("Dict") { die "We don't handle assigning to non-Dict types yet"; } else { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 1f269f14..896703c0 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -1,7 +1,6 @@ use v6; use _007; use _007::Val; -use _007::Q; use _007::Backend::JavaScript; use Test; diff --git a/t/api-documentation/code-snippets.t b/t/api-documentation/code-snippets.t index 8d5d4882..d3475641 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..e7cd795e 100644 --- a/t/api-documentation/comments.t +++ b/t/api-documentation/comments.t @@ -1,7 +1,7 @@ use v6; use Test; -for -> $file { +for -> $file { # I am a state machine. Hello. my enum State ; my $state = Normal; From 92d1a134a9975de97b0da6433fcc55d9cda79a38 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 07:33:36 +0200 Subject: [PATCH 44/91] asset-capture Val::Type --- lib/_007/Builtins.pm | 39 +++++++++++--------------------------- lib/_007/Parser/Actions.pm | 6 ++---- lib/_007/Runtime.pm | 8 ++------ lib/_007/Val.pm | 10 +++++++++- 4 files changed, 24 insertions(+), 39 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 280258dd..b2f9ca95 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,5 +1,9 @@ use _007::Val; +proto type-of($) is export {*} +multi type-of(_007::Object $obj) { $obj.type } +multi type-of(_007::Type $obj) { TYPE } + sub builtins(:$input!, :$output!, :$opscope!) is export { # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } @@ -126,11 +130,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return wrap($input.get()); }, type => sub ($arg) { - $arg ~~ _007::Type - ?? TYPE - !! $arg ~~ _007::Object - ?? $arg.type - !! Val::Type.of($arg.WHAT); + type-of($arg); }, # OPERATORS (from loosest to tightest within each category) @@ -203,28 +203,20 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:~~' => op( sub ($lhs, $rhs) { - if $rhs ~~ _007::Type { - return wrap($lhs ~~ _007::Object && ?$lhs.isa($rhs)); - } + die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(_007::Type)) + unless $rhs ~~ _007::Type; - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) - unless $rhs ~~ Val::Type; - - return wrap($lhs ~~ $rhs.type); + return wrap(?$lhs.isa($rhs)); }, :qtype(TYPE), :precedence{ equal => "infix:==" }, ), 'infix:!~~' => op( sub ($lhs, $rhs) { - if $rhs ~~ _007::Type { - return wrap($lhs !~~ _007::Object || !$lhs.isa($rhs)); - } + die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(_007::Type)) + unless $rhs ~~ _007::Type; - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(Val::Type)) - unless $rhs ~~ Val::Type | _007::Type; - - return wrap($lhs !~~ $rhs.type); + return wrap(!$lhs.isa($rhs)); }, :qtype(TYPE), :precedence{ equal => "infix:==" }, @@ -406,16 +398,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), ; - 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); - } - } - tree-walk(Val::); for TYPE.keys -> $type { - next if $type eq "Type"; push @builtins, ($type => TYPE{$type}); } diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 038176df..d9729f42 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -242,10 +242,8 @@ class _007::Parser::Actions { my $identifier = $.ast; my $block = $.ast; make TYPE.create(:$block); - my $val = Val::Type.of(EVAL qq[class :: \{ - method attributes \{ () \} - method ^name(\$) \{ "{$identifier.properties.value}" \} - \}]); + my $name = $identifier.properties.value; + my $val = _007::Type.new(:$name); bound-method($identifier, "put-value")($val, $*runtime); } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 07c5a399..5fb6a044 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -182,7 +182,6 @@ class _007::Runtime { return wrap-fn(&fn, $name, $parameterlist, $statementlist); } - my $type = Val::Type.of($obj.WHAT).name; if $obj ~~ _007::Object && $obj.isa("Q") { if $propname eq "detach" { sub interpolate($thing) { @@ -216,6 +215,7 @@ class _007::Runtime { my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); + my $type = type-of($obj); die X::Property::NotFound.new(:$propname, :$type) unless %known-properties{$propname}; @@ -417,11 +417,6 @@ class _007::Runtime { }))); }); } - elsif $obj ~~ Val::Type && $propname eq "create" { - return builtin(sub create($properties) { - $obj.create($properties.value.map({ .value[0].value => .value[1] })); - }); - } elsif $obj ~~ _007::Object && $obj.isa("Sub") && $propname eq any { return $obj.properties{$propname}; } @@ -472,6 +467,7 @@ class _007::Runtime { return wrap($obj.id); } else { + my $type = type-of($obj); die X::Property::NotFound.new(:$propname, :$type); } } diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 24d9104c..246b8a26 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -107,6 +107,15 @@ class _007::Type { return %properties; } + if self === TYPE { + return _007::Type.new( + :name(%properties ?? %properties.value !! ""), + :base(%properties // TYPE), + :fields(%properties ?? %properties.value !! []), + :is-abstract(%properties // False), + ); + } + my $type = $.name; my $fields = set(self.type-chain.map({ .fields })); my $seen = set(); @@ -998,7 +1007,6 @@ class Helper { method Str { "" } our sub Str($_) { - when Val::Type { "" } when _007::Type { "" } when _007::Object { when NONE { "None" } From 01e87229f1d240d109c2ff315f80cf791d58ed43 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 07:41:07 +0200 Subject: [PATCH 45/91] remove Val::Type --- lib/_007/Builtins.pm | 5 +-- lib/_007/Parser/Syntax.pm | 2 +- lib/_007/Runtime.pm | 2 +- lib/_007/Val.pm | 85 --------------------------------------- 4 files changed, 3 insertions(+), 91 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index b2f9ca95..e4b6d79c 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -66,9 +66,6 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { } } multi equal-value(_007::Type $l, _007::Type $r) { $l === $r } - multi equal-value(Val::Type $l, Val::Type $r) { - $l.type === $r.type - } multi less-value($, $) { die X::TypeCheck.new( @@ -423,7 +420,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { }; return @builtins.map: { - when .value ~~ _007::Type | Val::Type { + when .value ~~ _007::Type { .key => .value; } when .value ~~ Block { diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index aa190755..f8d514c3 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -220,7 +220,7 @@ grammar _007::Parser::Syntax { } token term:new-object { new» <.ws> - ) ~~ Val::Type | _007::Type }> <.ws> + ) ~~ _007::Type }> <.ws> '{' ~ '}' } token term:dict { diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 5fb6a044..3d78c526 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -405,7 +405,7 @@ class _007::Runtime { elsif $obj ~~ _007::Type && $propname eq "name" { return wrap($obj.name); } - elsif $obj ~~ Val::Type | _007::Type && $propname eq "name" { + elsif $obj ~~ _007::Type && $propname eq "name" { return wrap($obj.name); } elsif $obj ~~ _007::Type && $propname eq "create" { diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 246b8a26..4ae053ff 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -862,91 +862,6 @@ sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { return _007::Object::Wrapped.new(:type(TYPE), :&value, :%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) { - # XXX: there used to be a Val__Object case here - if $.type ~~ _007::Object { - return $.type.new(:value(@properties[0].value.value)); - } - 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 internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" unless $sub ~~ _007::Object && $sub.type === TYPE | TYPE; # XXX: should do subtyping check From 14babac8358edad371007de913e94b902db54bfc Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 07:47:20 +0200 Subject: [PATCH 46/91] remove Val --- lib/_007/Runtime.pm | 3 --- lib/_007/Val.pm | 16 +--------------- 2 files changed, 1 insertion(+), 18 deletions(-) diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 3d78c526..949dd14d 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -192,9 +192,6 @@ class _007::Runtime { return wrap(hash($thing.value.map(&interpolate-entry))) if $thing ~~ _007::Object && $thing.isa("Dict"); - return $thing - if $thing ~~ Val; - return $thing.type.create(:name($thing.properties), :frame(NONE)) if $thing.isa("Q::Identifier"); diff --git a/lib/_007/Val.pm b/lib/_007/Val.pm index 4ae053ff..2a27f1d3 100644 --- a/lib/_007/Val.pm +++ b/lib/_007/Val.pm @@ -309,17 +309,6 @@ TYPE.install-base(NONE); constant TRUE is export = _007::Object::Enum.new(:type(TYPE)); constant FALSE is export = _007::Object::Enum.new(:type(TYPE)); -role Val { - method truthy { True } - method attributes { self.^attributes } - method quoted-Str { self.Str } - - method Str { - my %*stringification-seen; - Helper::Str(self); - } -} - # 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) is export { @@ -582,7 +571,7 @@ sub bound-method($object, $name) is export { my $c = bound-method($object.properties, "eval")($runtime); die "macro is called at runtime" if $c ~~ _007::Object && $c.isa("Macro"); - die "Trying to invoke a {$c.^name.subst(/^'Val::'/, '')}" # XXX: make this into an X:: + die "Trying to invoke a {$c.type.name}" # XXX: make this into an X:: unless $c ~~ _007::Object && $c.isa("Sub"); my @arguments = $object.properties.properties.value.map({ bound-method($_, "eval")($runtime) @@ -675,9 +664,6 @@ sub bound-method($object, $name) is export { return $thing if $thing ~~ _007::Type; - return $thing - if $thing ~~ Val; - return $thing if $thing ~~ _007::Object && ($thing.isa("Int") || $thing.isa("Str")); From 66eb8d7cf53a6e942973dd68ff6871d4662e568b Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 08:32:23 +0200 Subject: [PATCH 47/91] rename Val.pm -> Object.pm --- META6.json | 2 +- lib/_007/Backend/JavaScript.pm | 2 +- lib/_007/Builtins.pm | 2 +- lib/_007/Linter.pm | 2 +- lib/_007/{Val.pm => Object.pm} | 0 lib/_007/OpScope.pm | 2 +- lib/_007/Parser/Actions.pm | 2 +- lib/_007/Parser/Syntax.pm | 2 +- lib/_007/Runtime.pm | 2 +- lib/_007/Test.pm | 2 +- t/api-documentation/code-snippets.t | 2 +- t/api-documentation/comments.t | 2 +- 12 files changed, 11 insertions(+), 11 deletions(-) rename lib/_007/{Val.pm => Object.pm} (100%) diff --git a/META6.json b/META6.json index 634cf9b5..e15c0e55 100644 --- a/META6.json +++ b/META6.json @@ -18,7 +18,7 @@ "_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" }, "support" : { "source" : "git://github.com/masak/007.git" } } diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 97fffe03..6a246468 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; my %builtins = "say" => q:to '----', diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index e4b6d79c..c999c809 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; proto type-of($) is export {*} multi type-of(_007::Object $obj) { $obj.type } diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 3cf91617..ed04b64a 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; role Lint { method message { ... } diff --git a/lib/_007/Val.pm b/lib/_007/Object.pm similarity index 100% rename from lib/_007/Val.pm rename to lib/_007/Object.pm diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index ad58beb6..9829f8d3 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; use _007::Precedence; class X::Associativity::Conflict is Exception { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index d9729f42..807f187e 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; use _007::Parser::Syntax; use MONKEY-SEE-NO-EVAL; diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index f8d514c3..cc9c46ae 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; sub check-feature-flag($feature, $word) { my $flag = "FLAG_007_{$word}"; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 949dd14d..28b9db4b 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -1,4 +1,4 @@ -use _007::Val; +use _007::Object; use _007::Builtins; use _007::OpScope; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 896703c0..fd47176d 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -1,6 +1,6 @@ use v6; use _007; -use _007::Val; +use _007::Object; use _007::Backend::JavaScript; use Test; diff --git a/t/api-documentation/code-snippets.t b/t/api-documentation/code-snippets.t index d3475641..8ce66d04 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 e7cd795e..fb2ee25b 100644 --- a/t/api-documentation/comments.t +++ b/t/api-documentation/comments.t @@ -1,7 +1,7 @@ use v6; use Test; -for -> $file { +for -> $file { # I am a state machine. Hello. my enum State ; my $state = Normal; From e55daa7c123bdf7fa837781034a1b96b498d53e0 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 08:35:42 +0200 Subject: [PATCH 48/91] remove MONKEY-SEE-NO-EVAL imports --- lib/_007/Object.pm | 2 -- lib/_007/Parser/Actions.pm | 1 - 2 files changed, 3 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 2a27f1d3..24f3e0a0 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -1,5 +1,3 @@ -use MONKEY-SEE-NO-EVAL; - class X::Uninstantiable is Exception { has Str $.name; diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 807f187e..b3cbcbfb 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -1,6 +1,5 @@ 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" } From 6df31305bbda166e62e9b5cbf236759788780dea Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 13:47:25 +0200 Subject: [PATCH 49/91] remove unnecessary exception for Subs --- lib/_007/Runtime.pm | 3 --- 1 file changed, 3 deletions(-) diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 28b9db4b..f07918a8 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -414,9 +414,6 @@ class _007::Runtime { }))); }); } - elsif $obj ~~ _007::Object && $obj.isa("Sub") && $propname eq any { - return $obj.properties{$propname}; - } elsif $obj ~~ _007::Object && $obj.isa("Dict") && ($obj.value{$propname} :exists) { return $obj.value{$propname}; } From 234b2aa5d757876260951fdeba98334d9656edc6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 15:18:51 +0200 Subject: [PATCH 50/91] Sort out some Dict/property confusion With Object, it's obj.prop (or obj.get("complicated-prop"). With Dict, it's dict["prop"]. --- examples/hanoi.007 | 2 +- lib/_007/Object.pm | 6 +++--- lib/_007/Parser/Actions.pm | 1 + lib/_007/Runtime.pm | 8 +++++--- self-host/runtime.007 | 18 +++++++++--------- t/features/builtins/operators.t | 11 +++++++---- 6 files changed, 26 insertions(+), 20 deletions(-) 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/Object.pm b/lib/_007/Object.pm index 24f3e0a0..1c48a8e7 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -552,12 +552,12 @@ sub bound-method($object, $name) is export { if $index.value < 0; return .value[$index.value]; } - if $_ ~~ _007::Object && (.isa("Dict") || .isa("Sub") || .isa("Q")) { + if $_ ~~ _007::Object && .isa("Dict") { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new unless $property ~~ _007::Object && $property.isa("Str"); - my $propname = $property.value; - return $runtime.property($_, $propname); + my $key = $property.value; + return .value{$key}; } die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); } diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index b3cbcbfb..edac500c 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -800,6 +800,7 @@ class _007::Parser::Actions { make TYPE.create(property => $.ast, :$identifier, :operand(NONE)); } else { + say $; make $*parser.opscope.ops{$op}.type.create(:$identifier, :operand(NONE)); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index f07918a8..173a80ff 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -209,6 +209,11 @@ class _007::Runtime { return interpolate($obj); }); } + elsif $propname eq "get" { + return builtin(sub get($prop) { + return self.property($obj, $prop.value); + }); + } my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); @@ -414,9 +419,6 @@ class _007::Runtime { }))); }); } - elsif $obj ~~ _007::Object && $obj.isa("Dict") && ($obj.value{$propname} :exists) { - return $obj.value{$propname}; - } elsif $obj ~~ _007::Object && ($obj.properties{$propname} :exists) { return $obj.properties{$propname}; } diff --git a/self-host/runtime.007 b/self-host/runtime.007 index 9df60b01..8c0e7ffc 100644 --- a/self-host/runtime.007 +++ b/self-host/runtime.007 @@ -69,7 +69,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 +197,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 +226,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 +234,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 +245,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 +257,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 +281,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 +307,5 @@ my Runtime = { } }; -my runtime = Runtime.new(); -runtime.run(ast); +my runtime = Runtime["new"](); +runtime["run"](ast); diff --git a/t/features/builtins/operators.t b/t/features/builtins/operators.t index 3c9b31bc..c6f7e499 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -456,19 +456,22 @@ use _007::Test; { 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", frame: None }; 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"; } { From 4278daa5c243ba097579b001dc0ff852d5b87a9b Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 16:04:18 +0200 Subject: [PATCH 51/91] Turn _007::Type.create into a sub We can then avoid forward-declaring _007::Object, separating the two classes a little further. --- lib/_007/Builtins.pm | 16 ++-- lib/_007/Object.pm | 106 +++++++++++----------- lib/_007/OpScope.pm | 8 +- lib/_007/Parser/Actions.pm | 174 ++++++++++++++++++------------------ lib/_007/Parser/Syntax.pm | 4 +- lib/_007/Runtime.pm | 26 +++--- lib/_007/Test.pm | 18 ++-- t/integration/finishblock.t | 2 +- 8 files changed, 176 insertions(+), 178 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index c999c809..59d7b0a6 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -405,7 +405,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my $type = ~$0; my $opname = ~$1; my %properties = hash($placeholder.qtype.type-chain.reverse.map({ .fields }).flat.map({ $_ => NONE })); - my $q = $placeholder.qtype.create(|%properties); + my $q = create($placeholder.qtype, |%properties); my $assoc = $placeholder.assoc; my %precedence = $placeholder.precedence; $opscope.install($type, $opname, $q, :$assoc, :%precedence); @@ -413,7 +413,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my &ditch-sigil = { $^str.substr(1) }; my ¶meter = { - TYPE.create(:identifier(TYPE.create( + create(TYPE, :identifier(create(TYPE, :name(wrap($^value)), :frame(NONE), ))) @@ -426,8 +426,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { when .value ~~ Block { my @elements = .value.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = TYPE.create(:$parameters); - my $statementlist = TYPE.create(:statements(wrap([]))); + my $parameterlist = create(TYPE, :$parameters); + my $statementlist = create(TYPE, :statements(wrap([]))); .key => wrap-fn(.value, .key, $parameterlist, $statementlist); } when .value ~~ Placeholder::MacroOp { @@ -435,8 +435,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { install-op($name, .value); my @elements = .value.qtype.fields.grep({ $_ ne "identifier" })».¶meter; my $parameters = wrap(@elements); - my $parameterlist = TYPE.create(:$parameters); - my $statementlist = TYPE.create(:statements(wrap([]))); + my $parameterlist = create(TYPE, :$parameters); + my $statementlist = create(TYPE, :statements(wrap([]))); .key => wrap-fn(sub () {}, $name, $parameterlist, $statementlist); } when .value ~~ Placeholder::Op { @@ -445,8 +445,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my &fn = .value.fn; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = TYPE.create(:$parameters); - my $statementlist = TYPE.create(:statements(wrap([]))); + my $parameterlist = create(TYPE, :$parameters); + my $statementlist = create(TYPE, :statements(wrap([]))); .key => wrap-fn(&fn, $name, $parameterlist, $statementlist); } default { die "Unknown type {.value.^name}" } diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 1c48a8e7..581ef102 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -61,7 +61,6 @@ class X::ParameterMismatch is Exception { } class Helper { ... } -class _007::Object { ... } sub unique-id { ++$ } @@ -95,50 +94,6 @@ class _007::Type { my %*stringification-seen; Helper::Str(self); } - - method create(*%properties) { - die X::Uninstantiable.new(:$.name) - if self.is-abstract; - - # XXX: For Dict and Array, we might instead want to do a shallow copy - if self === TYPE || self === TYPE || self === TYPE || self === TYPE { - return %properties; - } - - if self === TYPE { - return _007::Type.new( - :name(%properties ?? %properties.value !! ""), - :base(%properties // TYPE), - :fields(%properties ?? %properties.value !! []), - :is-abstract(%properties // False), - ); - } - - my $type = $.name; - my $fields = set(self.type-chain.map({ .fields })); - my $seen = set(); - for %properties.keys.sort -> $property { - die X::Property::NotDeclared.new(:$type, :$property) - unless $property (elem) $fields; - - die X::Property::Duplicate.new(:$type, :$property) - if $property (elem) $seen; - - $seen (|)= $property; - } - # XXX: need to screen for required properties by traversing @.fields, but we don't have the - # infrastructure in terms of a way to mark up a field as required - - # XXX: for now, let's pretend all properties are required. not pleasant, but we can live with it for a short time - for $fields.keys -> $field { - die "Need to pass property '$field' when creating a $type" - unless $field (elem) $seen; - } - - # XXX: ditto for property default values - - return _007::Object.new(:type(self), :%properties); - } } BEGIN { @@ -266,6 +221,49 @@ class _007::Object { method truthy { truthy(self) } } +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 = set($type.type-chain.map({ .fields })); + my $seen = set(); + for %properties.keys.sort -> $property { + die X::Property::NotDeclared.new(:type($type.name), :$property) + unless $property (elem) $fields; + + die X::Property::Duplicate.new(:type($type.name), :$property) + if $property (elem) $seen; + + $seen (|)= $property; + } + # XXX: need to screen for required properties by traversing @.fields, but we don't have the + # infrastructure in terms of a way to mark up a field as required + + # XXX: for now, let's pretend all properties are required. not pleasant, but we can live with it for a short time + for $fields.keys -> $field { + die "Need to pass property '$field' when creating a {$type.name}" + unless $field (elem) $seen; + } + + # XXX: ditto for property default values + + return _007::Object.new(:$type, :%properties); +} + class _007::Object::Enum is _007::Object { } @@ -439,11 +437,11 @@ sub bound-method($object, $name) is export { $object.properties.properties.value, $object.properties.properties); if $type ~~ _007::Type { - return $type.create(|hash($object.properties.properties.value.map({ + return create($type, |hash($object.properties.properties.value.map({ .properties.value => bound-method(.properties, "eval")($runtime) }))); } - return $type.create($object.properties.properties.value.map({ + return create($type, $object.properties.properties.value.map({ .properties.value => bound-method(.properties, "eval")($runtime) })); }; @@ -668,20 +666,20 @@ sub bound-method($object, $name) is export { return $thing if $thing ~~ _007::Object && $thing.isa("Sub"); - return $thing.type.create(:name($thing.properties), :frame($runtime.current-frame)) + return create($thing.type, :name($thing.properties), :frame($runtime.current-frame)) if $thing ~~ _007::Object && $thing.isa("Q::Identifier"); if $thing ~~ _007::Object && $thing.isa("Q::Unquote::Prefix") { my $prefix = bound-method($thing.properties, "eval")($runtime); die X::TypeCheck.new(:operation("interpolating an unquote"), :got($prefix), :expected(_007::Object)) unless $prefix ~~ _007::Object && $prefix.isa("Q::Prefix"); - return $prefix.type.create(:identifier($prefix.properties), :operand($thing.properties)); + return create($prefix.type, :identifier($prefix.properties), :operand($thing.properties)); } elsif $thing ~~ _007::Object && $thing.isa("Q::Unquote::Infix") { my $infix = bound-method($thing.properties, "eval")($runtime); die X::TypeCheck.new(:operation("interpolating an unquote"), :got($infix), :expected(_007::Object)) unless $infix ~~ _007::Object && $infix.isa("Q::Infix"); - return $infix.type.create(:identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); + return create($infix.type, :identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); } if $thing ~~ _007::Object && $thing.isa("Q::Unquote") { @@ -693,7 +691,7 @@ sub bound-method($object, $name) is export { my %properties = $thing.properties.keys.map: -> $key { $key => interpolate($thing.properties{$key}) }; - $thing.type.create(|%properties); + create($thing.type, |%properties); } if $object.properties.value eq "Q::Unquote" && $object.properties.isa("Q::Unquote") { @@ -712,7 +710,7 @@ sub bound-method($object, $name) is export { my $statementlist = $object.properties.properties; my $static-lexpad = $object.properties.properties; my $outer-frame = $runtime.current-frame; - return TYPE.create(:$name, :$parameterlist, :$statementlist, :$static-lexpad, :$outer-frame); + return create(TYPE, :$name, :$parameterlist, :$statementlist, :$static-lexpad, :$outer-frame); }; } @@ -725,7 +723,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Statement::Throw") && $name eq "run" { return sub eval-q-statement-throw($runtime) { my $value = $object.properties === NONE - ?? TYPE.create(:message(wrap("Died"))) + ?? create(TYPE, :message(wrap("Died"))) !! bound-method($object.properties, "eval")($runtime); die X::TypeCheck.new(:got($value), :expected(_007::Object)) unless $value ~~ _007::Object && $value.isa("Exception"); @@ -782,7 +780,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Term::Regex") && $name eq "eval" { return sub eval-q-term-regex($runtime) { - TYPE.create(:contents($object.properties)); + create(TYPE, :contents($object.properties)); }; } diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 9829f8d3..b6e43a9c 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -18,15 +18,15 @@ class _007::OpScope { method install($type, $op, $q?, :%precedence, :$assoc) { my $name = "$type:$op"; - my $identifier = TYPE.create( + my $identifier = create(TYPE, :name(wrap($name)), :frame(NONE), ); %!ops{$type}{$op} = $q !=== Any ?? $q !! { - prefix => TYPE.create(:$identifier, :operand(NONE)), - infix => TYPE.create(:$identifier, :lhs(NONE), :rhs(NONE)), - postfix => TYPE.create(:$identifier, :operand(NONE)), + 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 edac500c..ea77ddb1 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -64,24 +64,24 @@ class _007::Parser::Actions { } method compunit($/) { - my $block = TYPE.create( - :parameterlist(TYPE.create( + my $block = create(TYPE, + :parameterlist(create(TYPE, :parameters(empty-array()), )), :statementlist($.ast), :static-lexpad(empty-dict()), ); - make TYPE.create(:$block); + make create(TYPE, :$block); self.finish-block($block); } method statementlist($/) { my $statements = wrap($».ast); - make TYPE.create(:$statements); + make create(TYPE, :$statements); } method statement:my ($/) { - make TYPE.create( + make create(TYPE, :identifier($.ast), :expr($ ?? $.ast !! NONE)); } @@ -90,7 +90,7 @@ class _007::Parser::Actions { die X::Syntax::Missing.new(:what("initializer on constant declaration")) unless $; - make TYPE.create( + make create(TYPE, :identifier($.ast), :expr($.ast)); @@ -103,21 +103,21 @@ class _007::Parser::Actions { # top level of an expression statement, but it could happen anywhere # in the expression tree if $.ast.isa("Q::Block") { - make TYPE.create(:expr(TYPE.create( - :identifier(TYPE.create(:name(wrap("postfix:()")))), - :operand(TYPE.create(:identifier(NONE), :block($.ast))), - :argumentlist(TYPE.create()) + make create(TYPE, :expr(create(TYPE, + :identifier(create(TYPE, :name(wrap("postfix:()")))), + :operand(create(TYPE, :identifier(NONE), :block($.ast))), + :argumentlist(create(TYPE)) ))); } else { - make TYPE.create(:expr($.ast)); + make create(TYPE, :expr($.ast)); } } method statement:block ($/) { die X::PointyBlock::SinkContext.new if $; - make TYPE.create(:block($.ast)); + make create(TYPE, :block($.ast)); } sub maybe-install-operator($identname, @trait) { @@ -177,7 +177,7 @@ class _007::Parser::Actions { my $traitlist = $.ast; my $statementlist = $.ast; - my $block = TYPE.create( + my $block = create(TYPE, :$parameterlist, :$statementlist, :static-lexpad(empty-dict()), @@ -188,12 +188,12 @@ class _007::Parser::Actions { my $outer-frame = $*runtime.current-frame; my $val; if $ eq "sub" { - make TYPE.create(:$identifier, :$traitlist, :$block); - $val = TYPE.create(:$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 TYPE.create(:$identifier, :$traitlist, :$block); - $val = TYPE.create(:$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 @@ -207,11 +207,11 @@ class _007::Parser::Actions { method statement:return ($/) { die X::ControlFlow::Return.new unless $*insub; - make TYPE.create(:expr($ ?? $.ast !! NONE)); + make create(TYPE, :expr($ ?? $.ast !! NONE)); } method statement:throw ($/) { - make TYPE.create(:expr($ ?? $.ast !! NONE)); + make create(TYPE, :expr($ ?? $.ast !! NONE)); } method statement:if ($/) { @@ -220,27 +220,27 @@ class _007::Parser::Actions { ?? $.ast !! NONE; - make TYPE.create(|%parameters); + make create(TYPE, |%parameters); } method statement:for ($/) { - make TYPE.create(|$.ast); + make create(TYPE, |$.ast); } method statement:while ($/) { - make TYPE.create(|$.ast); + make create(TYPE, |$.ast); } method statement:BEGIN ($/) { my $block = $.ast; - make TYPE.create(:$block); - $*runtime.run(TYPE.create(:$block)); + make create(TYPE, :$block); + $*runtime.run(create(TYPE, :$block)); } method statement:class ($/) { my $identifier = $.ast; my $block = $.ast; - make TYPE.create(:$block); + make create(TYPE, :$block); my $name = $identifier.properties.value; my $val = _007::Type.new(:$name); bound-method($identifier, "put-value")($val, $*runtime); @@ -253,18 +253,18 @@ class _007::Parser::Actions { die X::Trait::Duplicate.new(:$trait); } my $traits = wrap(@traits); - make TYPE.create(:$traits); + make create(TYPE, :$traits); } method trait($/) { - make TYPE.create(:identifier($.ast), :expr($.ast)); + make create(TYPE, :identifier($.ast), :expr($.ast)); } method blockoid ($/) { make $.ast; } method block ($/) { - my $block = TYPE.create( - :parameterlist(TYPE.create( + my $block = create(TYPE, + :parameterlist(create(TYPE, :parameters(empty-array()), )), :statementlist($.ast) @@ -274,7 +274,7 @@ class _007::Parser::Actions { } method pblock ($/) { if $ { - my $block = TYPE.create( + my $block = create(TYPE, :parameterlist($.ast), :statementlist($.ast), :static-lexpad(empty-dict())); @@ -312,19 +312,19 @@ class _007::Parser::Actions { else { if $expansion.isa("Q::Statement") { my $statements = wrap([$expansion]); - $expansion = TYPE.create(:$statements); + $expansion = create(TYPE, :$statements); } elsif $expansion === NONE { my $statements = wrap([]); - $expansion = TYPE.create(:$statements); + $expansion = create(TYPE, :$statements); } if $expansion.isa("Q::StatementList") { - $expansion = TYPE.create(:statementlist($expansion)); + $expansion = create(TYPE, :statementlist($expansion)); } if $expansion.isa("Q::Block") { - $expansion = TYPE.create(:statementlist($expansion.properties)); + $expansion = create(TYPE, :statementlist($expansion.properties)); } return $expansion; @@ -365,7 +365,7 @@ class _007::Parser::Actions { my $t1 = @termstack.pop; if $infix.isa("Q::Unquote") { - @termstack.push(TYPE.create( + @termstack.push(create(TYPE, :qtype($infix.properties), :expr($infix.properties), :lhs($t1), @@ -376,10 +376,10 @@ class _007::Parser::Actions { if my $macro = is-macro($infix, TYPE, $infix.properties) { @termstack.push(expand($macro, [$t1, $t2], - -> { $infix.type.create(:lhs($t1), :rhs($t2), :identifier($infix.properties)) })); + -> { create($infix.type, :lhs($t1), :rhs($t2), :identifier($infix.properties)) })); } else { - @termstack.push($infix.type.create(:lhs($t1), :rhs($t2), :identifier($infix.properties))); + @termstack.push(create($infix.type, :lhs($t1), :rhs($t2), :identifier($infix.properties))); if $infix.isa("Q::Infix::Assignment") && $t1.isa("Q::Identifier") { my $frame = $*runtime.current-frame; @@ -444,7 +444,7 @@ class _007::Parser::Actions { my $prefix = @prefixes.shift.ast; if $prefix.isa("Q::Unquote") { - make TYPE.create( + make create(TYPE, :qtype($prefix.properties), :expr($prefix.properties), :operand($/.ast), @@ -454,10 +454,10 @@ class _007::Parser::Actions { if my $macro = is-macro($prefix, TYPE, $prefix.properties) { make expand($macro, [$/.ast], - -> { $prefix.type.create(:operand($/.ast), :identifier($prefix.properties)) }); + -> { create($prefix.type, :operand($/.ast), :identifier($prefix.properties)) }); } else { - make $prefix.type.create(:operand($/.ast), :identifier($prefix.properties)); + make create($prefix.type, :operand($/.ast), :identifier($prefix.properties)); } } @@ -466,26 +466,26 @@ class _007::Parser::Actions { my $identifier = $postfix.properties; if is-macro($postfix, TYPE, $/.ast) -> $macro { make expand($macro, $postfix.properties.properties.value, -> { - $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)); + create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); }); } elsif $postfix.isa("Q::Postfix::Index") { - make $postfix.type.create(:$identifier, :operand($/.ast), :index($postfix.properties)); + make create($postfix.type, :$identifier, :operand($/.ast), :index($postfix.properties)); } elsif $postfix.isa("Q::Postfix::Call") { - make $postfix.type.create(:$identifier, :operand($/.ast), :argumentlist($postfix.properties)); + make create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); } elsif $postfix.isa("Q::Postfix::Property") { - make $postfix.type.create(:$identifier, :operand($/.ast), :property($postfix.properties)); + make create($postfix.type, :$identifier, :operand($/.ast), :property($postfix.properties)); } else { if is-macro($postfix, TYPE, $identifier) -> $macro { make expand($macro, [$/.ast], -> { - $postfix.type.create(:$identifier, :operand($/.ast)); + create($postfix.type, :$identifier, :operand($/.ast)); }); } else { - make $postfix.type.create(:$identifier, :operand($/.ast)); + make create($postfix.type, :$identifier, :operand($/.ast)); } } } @@ -516,11 +516,11 @@ class _007::Parser::Actions { method prefix($/) { my $op = ~$/; - my $identifier = TYPE.create( + my $identifier = create(TYPE, :name(wrap("prefix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.type.create(:$identifier, :operand(NONE)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :operand(NONE)); } method prefix-unquote($/) { @@ -533,23 +533,23 @@ class _007::Parser::Actions { if $s ~~ /\n/; }(~$0); my $value = wrap((~$0).subst(q[\"], q["], :g).subst(q[\\\\], q[\\], :g)); - make TYPE.create(:$value); + make create(TYPE, :$value); } method term:none ($/) { - make TYPE.create(); + make create(TYPE); } method term:false ($/) { - make TYPE.create(:value(FALSE)); + make create(TYPE, :value(FALSE)); } method term:true ($/) { - make TYPE.create(:value(TRUE)); + make create(TYPE, :value(TRUE)); } method term:int ($/) { - make TYPE.create(:value(wrap(+$/))); + make create(TYPE, :value(wrap(+$/))); } method term:str ($/) { @@ -558,7 +558,7 @@ class _007::Parser::Actions { method term:array ($/) { my $elements = wrap($».ast); - make TYPE.create(:$elements); + make create(TYPE, :$elements); } method term:parens ($/) { @@ -566,7 +566,7 @@ class _007::Parser::Actions { } method term:regex ($/) { - make TYPE.create(:contents($.ast.properties)); + make create(TYPE, :contents($.ast.properties)); } method term:identifier ($/) { @@ -605,12 +605,12 @@ 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.properties.properties.value[0]; - make TYPE.create(:$contents, :$qtype); + make create(TYPE, :$contents, :$qtype); return; } elsif $qtype.value eq "Q::StatementList" { my $contents = $block.ast.properties; - make TYPE.create(:$contents, :$qtype); + make create(TYPE, :$contents, :$qtype); return; } elsif $qtype.value ne "Q::Block" @@ -619,7 +619,7 @@ class _007::Parser::Actions { && $block.ast.properties.properties.value[0].isa("Q::Statement::Expr") { my $contents = $block.ast.properties.properties.value[0].properties; - make TYPE.create(:$contents, :$qtype); + make create(TYPE, :$contents, :$qtype); return; } } @@ -630,7 +630,7 @@ class _007::Parser::Actions { if $/{$subrule} -> $submatch { my $contents = $submatch.ast; - make TYPE.create(:$contents, :$qtype); + make create(TYPE, :$contents, :$qtype); return; } } @@ -643,28 +643,28 @@ class _007::Parser::Actions { my $traitlist = $.ast; my $statementlist = $.ast; - my $block = TYPE.create(:$parameterlist, :$statementlist, :static-lexpad(empty-dict())); + my $block = create(TYPE, :$parameterlist, :$statementlist, :static-lexpad(empty-dict())); if $ { my $name = $.ast.properties; my $outer-frame = $*runtime.current-frame.value; my $static-lexpad = $*runtime.current-frame.value; - my $val = TYPE.create(:$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); + my $val = create(TYPE, :$name, :$parameterlist, :$statementlist, :$outer-frame, :$static-lexpad); bound-method($.ast, "put-value")($val, $*runtime); } self.finish-block($block); my $name = $ && $.ast.properties; my $identifier = $ - ?? TYPE.create(:$name, :frame(NONE)) + ?? create(TYPE, :$name, :frame(NONE)) !! NONE; - make TYPE.create(:$identifier, :$traitlist, :$block); + make create(TYPE, :$identifier, :$traitlist, :$block); } method unquote ($/) { my $qtype = $ ?? $*runtime.get-var($.ast.properties.value) !! TYPE; - make TYPE.create(:$qtype, :expr($.ast)); + make create(TYPE, :$qtype, :expr($.ast)); } method term:new-object ($/) { @@ -696,8 +696,8 @@ class _007::Parser::Actions { # unless $property eq any($.ast.value.value».key».value); # } - make TYPE.create( - :type(TYPE.create( + make create(TYPE, + :type(create(TYPE, :name(wrap($type)), :frame(NONE), )), @@ -705,7 +705,7 @@ class _007::Parser::Actions { } method term:dict ($/) { - make TYPE.create( + make create(TYPE, :propertylist($.ast)); } @@ -718,37 +718,37 @@ class _007::Parser::Actions { } my $properties = wrap($».ast); - make TYPE.create(:$properties); + make create(TYPE, :$properties); } method property:str-expr ($/) { - make TYPE.create(:key($.ast.properties), :value($.ast)); + make create(TYPE, :key($.ast.properties), :value($.ast)); } method property:identifier-expr ($/) { my $key = $.ast.properties; - make TYPE.create(:$key, :value($.ast)); + make create(TYPE, :$key, :value($.ast)); } method property:identifier ($/) { my $key = $.ast.properties; - make TYPE.create(:$key, :value($.ast)); + make create(TYPE, :$key, :value($.ast)); } method property:method ($/) { - my $block = TYPE.create( + my $block = create(TYPE, :parameterlist($.ast), :statementlist($.ast), :static-lexpad(wrap({})), ); my $name = $.ast.properties; - my $identifier = TYPE.create(:$name, :frame(NONE)); - make TYPE.create( + my $identifier = create(TYPE, :$name, :frame(NONE)); + make create(TYPE, :key($name), - :value(TYPE.create( + :value(create(TYPE, :$identifier, :$block, - :traitlist(TYPE.create( + :traitlist(create(TYPE, :traits(wrap([])), )), )), @@ -758,11 +758,11 @@ class _007::Parser::Actions { method infix($/) { my $op = ~$/; - my $identifier = TYPE.create( + my $identifier = create(TYPE, :name(wrap("infix:$op")), :frame($*runtime.current-frame), ); - make $*parser.opscope.ops{$op}.type.create(:$identifier, :lhs(NONE), :rhs(NONE)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :lhs(NONE), :rhs(NONE)); } method infix-unquote($/) { @@ -784,24 +784,24 @@ class _007::Parser::Actions { elsif $ { $op = "."; } - my $identifier = TYPE.create( + 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 TYPE.create(index => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, index => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make TYPE.create(argumentlist => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, argumentlist => $.ast, :$identifier, :operand(NONE)); } elsif $ { - make TYPE.create(property => $.ast, :$identifier, :operand(NONE)); + make create(TYPE, property => $.ast, :$identifier, :operand(NONE)); } else { say $; - make $*parser.opscope.ops{$op}.type.create(:$identifier, :operand(NONE)); + make create($*parser.opscope.ops{$op}.type, :$identifier, :operand(NONE)); } } @@ -815,20 +815,20 @@ class _007::Parser::Actions { $value ~~ s:g['\\\\'] = '\\'; }(); my $name = wrap($value); - make TYPE.create(:$name, :frame(NONE)); + make create(TYPE, :$name, :frame(NONE)); } method argumentlist($/) { my $arguments = wrap($».ast); - make TYPE.create(:$arguments); + make create(TYPE, :$arguments); } method parameterlist($/) { my $parameters = wrap($».ast); - make TYPE.create(:$parameters); + make create(TYPE, :$parameters); } method parameter($/) { - make TYPE.create(:identifier($.ast)); + make create(TYPE, :identifier($.ast)); } } diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index cc9c46ae..6bb5c886 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -18,7 +18,7 @@ grammar _007::Parser::Syntax { token newpad { { $*parser.push-opscope; @*declstack.push(@*declstack ?? @*declstack[*-1].clone !! {}); - $*runtime.enter($*runtime.current-frame, wrap({}), TYPE.create( + $*runtime.enter($*runtime.current-frame, wrap({}), create(TYPE, :statements(wrap([])), )); } } @@ -43,7 +43,7 @@ grammar _007::Parser::Syntax { die X::Redeclaration::Outer.new(:$symbol) if %*assigned{$frame.id ~ $symbol}; my $name = wrap($symbol); - my $identifier = TYPE.create(:$name, :$frame); + my $identifier = create(TYPE, :$name, :$frame); $*runtime.declare-var($identifier); @*declstack[*-1]{$symbol} = $decltype; } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 173a80ff..90b24d32 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -16,7 +16,7 @@ class X::Regex::InvalidMatchType is Exception { } constant NO_OUTER = wrap({}); -constant RETURN_TO = TYPE.create( +constant RETURN_TO = create(TYPE, :name(wrap("--RETURN-TO--")), :frame(NONE)); @@ -28,7 +28,7 @@ class _007::Runtime { has $.builtin-frame; submethod BUILD(:$!input, :$!output) { - self.enter(NO_OUTER, wrap({}), TYPE.create( + self.enter(NO_OUTER, wrap({}), create(TYPE, :statements(wrap([])), )); $!builtin-frame = @!frames[*-1]; @@ -52,7 +52,7 @@ class _007::Runtime { }); @!frames.push($frame); for $static-lexpad.value.kv -> $name, $value { - my $identifier = TYPE.create( + my $identifier = create(TYPE, :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); @@ -64,7 +64,7 @@ class _007::Runtime { my $statementlist = .properties.properties; my $static-lexpad = .properties.properties; my $outer-frame = $frame; - my $val = TYPE.create( + my $val = create(TYPE, :$name, :$parameterlist, :$statementlist, @@ -76,7 +76,7 @@ class _007::Runtime { } if $routine { my $name = $routine.properties; - my $identifier = TYPE.create(:$name, :$frame); + my $identifier = create(TYPE, :$name, :$frame); self.declare-var($identifier, $routine); } } @@ -156,7 +156,7 @@ class _007::Runtime { method load-builtins { my $opscope = $!builtin-opscope; for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { - my $identifier = TYPE.create( + my $identifier = create(TYPE, :name(wrap($name)), :frame(NONE)); self.declare-var($identifier, $value); @@ -168,8 +168,8 @@ class _007::Runtime { my $name = &fn.name; my &ditch-sigil = { $^str.substr(1) }; my ¶meter = { - TYPE.create( - :identifier(TYPE.create( + create(TYPE, + :identifier(create(TYPE, :name(wrap($^value)) :frame(NONE)) ) @@ -177,8 +177,8 @@ class _007::Runtime { }; my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; my $parameters = wrap(@elements); - my $parameterlist = TYPE.create(:$parameters); - my $statementlist = TYPE.create(:statements(wrap([]))); + my $parameterlist = create(TYPE, :$parameters); + my $statementlist = create(TYPE, :statements(wrap([]))); return wrap-fn(&fn, $name, $parameterlist, $statementlist); } @@ -192,7 +192,7 @@ class _007::Runtime { return wrap(hash($thing.value.map(&interpolate-entry))) if $thing ~~ _007::Object && $thing.isa("Dict"); - return $thing.type.create(:name($thing.properties), :frame(NONE)) + return create($thing.type, :name($thing.properties), :frame(NONE)) if $thing.isa("Q::Identifier"); return $thing @@ -202,7 +202,7 @@ class _007::Runtime { $fieldname => interpolate($thing.properties{$fieldname}) }; - $thing.type.create(|%properties); + create($thing.type, |%properties); } return builtin(sub detach() { @@ -413,7 +413,7 @@ class _007::Runtime { elsif $obj ~~ _007::Type && $propname eq "create" { return builtin(sub create($properties) { # XXX: check that $properties is an array of [k, v] arrays - $obj.create(|hash($properties.value.map(-> $p { + create($obj, |hash($properties.value.map(-> $p { my ($k, $v) = @($p.value); $k.value => $v; }))); diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index fd47176d..7654d7c7 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -8,7 +8,7 @@ use Test; sub read(Str $ast) is export { sub n($type, $op) { my $name = wrap($type ~ ":<$op>"); - return TYPE.create(:$name, :frame(NONE)); + return create(TYPE, :$name, :frame(NONE)); } my %q_lookup = @@ -109,7 +109,7 @@ sub read(Str $ast) is export { if $qname ~~ /^ [prefix | infix | postfix] ":"/ { # XXX: it stinks that we have to do this my $name = wrap($qname); - %arguments = TYPE.create(:$name, :frame(NONE)); + %arguments = create(TYPE, :$name, :frame(NONE)); shift @attributes; # $.identifier } }(); @@ -142,7 +142,7 @@ sub read(Str $ast) is export { %arguments //= wrap({}); } if $qtype === TYPE | TYPE { - %arguments //= TYPE.create( + %arguments //= create(TYPE, :traits(wrap([])), ); } @@ -155,7 +155,7 @@ sub read(Str $ast) is export { if $qtype === TYPE { %arguments //= NONE; } - make $qtype.create(|%arguments); + make create($qtype, |%arguments); } method expr:symbol ($/) { make ~$/ } method expr:int ($/) { make wrap(+$/) } @@ -164,8 +164,8 @@ sub read(Str $ast) is export { AST::Syntax.parse($ast, :$actions) or die "couldn't parse AST syntax"; - return TYPE.create(:block(TYPE.create( - :parameterlist(TYPE.create( + return create(TYPE, :block(create(TYPE, + :parameterlist(create(TYPE, :parameters(wrap([])), )), :statementlist($/.ast), @@ -235,7 +235,7 @@ sub check(_007::Object $ast, $runtime) is export { elsif $ast.isa("Q::Statement::Sub") -> $sub { my $outer-frame = $runtime.current-frame; my $name = $sub.properties.properties; - my $val = TYPE.create( + my $val = create(TYPE, :$name, :parameterlist($sub.properties.properties), :statementlist($sub.properties.properties), @@ -251,7 +251,7 @@ sub check(_007::Object $ast, $runtime) is export { elsif $ast.isa("Q::Statement::Macro") -> $macro { my $outer-frame = $runtime.current-frame; my $name = $macro.properties.properties; - my $val = TYPE.create( + my $val = create(TYPE, :$name, :parameterlist($macro.properties.properties), :statementlist($macro.properties.properties), @@ -274,7 +274,7 @@ sub check(_007::Object $ast, $runtime) is export { handle($while.properties); } elsif $ast.isa("Q::Block") -> $block { - $runtime.enter($runtime.current-frame, wrap({}), TYPE.create( + $runtime.enter($runtime.current-frame, wrap({}), create(TYPE, :statements(wrap([])), )); handle($block.properties); diff --git a/t/integration/finishblock.t b/t/integration/finishblock.t index 80127d76..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 ~~ /"TYPE.create("/ { + if $line ~~ /"create(TYPE"/ { $blocks-minus-finishblocks++; } if $line ~~ /"self.finish-block("/ { From 8966922725c676b15758a6f115d607c7fbe6c532 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 16:11:46 +0200 Subject: [PATCH 52/91] remove some obsolete/redundant code --- lib/_007/Object.pm | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 581ef102..d6f8e4a2 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -901,8 +901,6 @@ class Helper { }).join(", "); } - method Str { "" } - our sub Str($_) { when _007::Type { "" } when _007::Object { @@ -938,21 +936,5 @@ class Helper { when _007::Object::Wrapped { .value.Str } default { die "Unexpected type ", .^name } } - default { - my $self = $_; - die "Unexpected type -- some invariant must be broken ({$self.^name})" - 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\}"; - } } } From 0e83895d85c5cd3b77743acde7f57eb6637bb681 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 16:28:44 +0200 Subject: [PATCH 53/91] Simplify Helper::Str a bit Part of this involves giving _007::Object::Enum a .name property, so that we can forward-reference them safely. --- lib/_007/Object.pm | 66 ++++++++++++++++++++++------------------------ 1 file changed, 32 insertions(+), 34 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index d6f8e4a2..f9e0c80e 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -265,6 +265,7 @@ sub create(_007::Type $type, *%properties) is export { } class _007::Object::Enum is _007::Object { + has Str $.name; } class _007::Object::Wrapped is _007::Object { @@ -297,13 +298,13 @@ class _007::Object::Wrapped is _007::Object { } } -constant NONE is export = _007::Object::Enum.new(:type(TYPE)); +constant NONE is export = _007::Object::Enum.new(:type(TYPE), :name); # Now we can install NONE into TYPE.base TYPE.install-base(NONE); -constant TRUE is export = _007::Object::Enum.new(:type(TYPE)); -constant FALSE is export = _007::Object::Enum.new(:type(TYPE)); +constant TRUE is export = _007::Object::Enum.new(:type(TYPE), :name); +constant FALSE is export = _007::Object::Enum.new(:type(TYPE), :name); # 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 @@ -903,38 +904,35 @@ class Helper { our sub Str($_) { when _007::Type { "" } - when _007::Object { - when NONE { "None" } - when .type === TYPE { $_ === TRUE ?? "True" !! "False" } - when .type === TYPE { .quoted-Str } - when .type === TYPE { .quoted-Str } - when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - "/" ~ .contents.quoted-Str ~ "/" - } - when .isa("Q") { - my $self = $_; - my @props = $self.type.type-chain.reverse.map({ .fields }).flat; - # XXX: thuggish way to hide things that weren't listed in `attributes` before - @props.=grep: { - !($self.isa("Q::Identifier") && $_ eq "frame") && - !($self.isa("Q::Block") && $_ eq "static-lexpad") - }; - if @props == 1 { - return "{$self.type.name} { ($self.properties{@props[0]} // NONE).quoted-Str }"; - } - sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } - my $contents = @props.map(&keyvalue).join(",\n").indent(4); - return "{$self.type.name} \{\n$contents\n\}"; + when .type === TYPE | TYPE { .name } + when .type === TYPE { .quoted-Str } + when .type === TYPE { .quoted-Str } + when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + "/" ~ .contents.quoted-Str ~ "/" + } + when .isa("Q") { + my $self = $_; + my @props = $self.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($self.isa("Q::Identifier") && $_ eq "frame") && + !($self.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return "{$self.type.name} { ($self.properties{@props[0]} // NONE).quoted-Str }"; } - when _007::Object::Wrapped { .value.Str } - default { die "Unexpected type ", .^name } + sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return "{$self.type.name} \{\n$contents\n\}"; } + when _007::Object::Wrapped { .value.Str } + default { die "Unexpected type ", .^name } } } From 421eaad3d1c0fe5cdf2547eb917d42f093d3e8f6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 16:34:04 +0200 Subject: [PATCH 54/91] move Helper up --- lib/_007/Object.pm | 116 ++++++++++++++++++++++----------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index f9e0c80e..8402ce90 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -186,6 +186,64 @@ TYPE = _007::Type.new(:name, :base(TYPE), :fields["identi TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); +class Helper { + 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 + }).join(", "); + } + + our sub Str($_) { + when _007::Type { "" } + when .type === TYPE | TYPE { .name } + when .type === TYPE { .quoted-Str } + when .type === TYPE { .quoted-Str } + when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + "/" ~ .contents.quoted-Str ~ "/" + } + when .isa("Q") { + my $self = $_; + my @props = $self.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($self.isa("Q::Identifier") && $_ eq "frame") && + !($self.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return "{$self.type.name} { ($self.properties{@props[0]} // wrap(Nil)).quoted-Str }"; + } + sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return "{$self.type.name} \{\n$contents\n\}"; + } + when .^name eq "_007::Object::Wrapped" { .value.Str } + default { die "Unexpected type ", .^name } + } +} + class _007::Object { has $.type; has $.id = unique-id; @@ -878,61 +936,3 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { } return $value || NONE; } - -class Helper { - 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 - }).join(", "); - } - - our sub Str($_) { - when _007::Type { "" } - when .type === TYPE | TYPE { .name } - when .type === TYPE { .quoted-Str } - when .type === TYPE { .quoted-Str } - when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - "/" ~ .contents.quoted-Str ~ "/" - } - when .isa("Q") { - my $self = $_; - my @props = $self.type.type-chain.reverse.map({ .fields }).flat; - # XXX: thuggish way to hide things that weren't listed in `attributes` before - @props.=grep: { - !($self.isa("Q::Identifier") && $_ eq "frame") && - !($self.isa("Q::Block") && $_ eq "static-lexpad") - }; - if @props == 1 { - return "{$self.type.name} { ($self.properties{@props[0]} // NONE).quoted-Str }"; - } - sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } - my $contents = @props.map(&keyvalue).join(",\n").indent(4); - return "{$self.type.name} \{\n$contents\n\}"; - } - when _007::Object::Wrapped { .value.Str } - default { die "Unexpected type ", .^name } - } -} From 9f7e027346002d063e539b2da05c2d90f8fb3a60 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 16:50:54 +0200 Subject: [PATCH 55/91] separate Type.pm from Object.pm --- META6.json | 3 +- lib/_007/Builtins.pm | 1 + lib/_007/Object.pm | 186 +------------------------------------ lib/_007/OpScope.pm | 1 + lib/_007/Parser/Actions.pm | 1 + lib/_007/Parser/Syntax.pm | 1 + lib/_007/Runtime.pm | 1 + lib/_007/Test.pm | 1 + lib/_007/Type.pm | 183 ++++++++++++++++++++++++++++++++++++ 9 files changed, 193 insertions(+), 185 deletions(-) create mode 100644 lib/_007/Type.pm diff --git a/META6.json b/META6.json index e15c0e55..4f9ea2e2 100644 --- a/META6.json +++ b/META6.json @@ -18,7 +18,8 @@ "_007::Runtime" : "lib/_007/Runtime.pm", "_007::Builtins" : "lib/_007/Builtins.pm", "_007::Test" : "lib/_007/Test.pm", - "_007::Object" : "lib/_007/Object.pm" + "_007::Object" : "lib/_007/Object.pm", + "_007::Type" : "lib/_007/Type.pm" }, "support" : { "source" : "git://github.com/masak/007.git" } } diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 59d7b0a6..947f1b6f 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,3 +1,4 @@ +use _007::Type; use _007::Object; proto type-of($) is export {*} diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 8402ce90..65ac4f8f 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -1,3 +1,5 @@ +use _007::Type; + class X::Uninstantiable is Exception { has Str $.name; @@ -60,190 +62,6 @@ class X::ParameterMismatch is Exception { } } -class Helper { ... } - -sub unique-id { ++$ } - -constant TYPE = hash(); - -class _007::Type { - 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; - } - - method attributes { () } - - method quoted-Str { self.Str } - method Str { - my %*stringification-seen; - Helper::Str(self); - } -} - -BEGIN { - for -> $name { - TYPE{$name} = _007::Type.new(:$name); - } -} -for -> $name { - TYPE{$name} = _007::Type.new(:$name); -} -TYPE = _007::Type.new(:name, :fields["message"]); -TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :fields["contents"]); - -TYPE = _007::Type.new(:name, :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["propertylist"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["type", "propertylist"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "contents"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["elements"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "frame"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameterlist", "statementlist", "static-lexpad"]); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "lhs", "rhs"]); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["index"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["argumentlist"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["property"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["operand"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["lhs", "rhs"]); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["statements"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["arguments"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameters"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["key", "value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["properties"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); - -class Helper { - 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 - }).join(", "); - } - - our sub Str($_) { - when _007::Type { "" } - when .type === TYPE | TYPE { .name } - when .type === TYPE { .quoted-Str } - when .type === TYPE { .quoted-Str } - when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - "/" ~ .contents.quoted-Str ~ "/" - } - when .isa("Q") { - my $self = $_; - my @props = $self.type.type-chain.reverse.map({ .fields }).flat; - # XXX: thuggish way to hide things that weren't listed in `attributes` before - @props.=grep: { - !($self.isa("Q::Identifier") && $_ eq "frame") && - !($self.isa("Q::Block") && $_ eq "static-lexpad") - }; - if @props == 1 { - return "{$self.type.name} { ($self.properties{@props[0]} // wrap(Nil)).quoted-Str }"; - } - sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } - my $contents = @props.map(&keyvalue).join(",\n").indent(4); - return "{$self.type.name} \{\n$contents\n\}"; - } - when .^name eq "_007::Object::Wrapped" { .value.Str } - default { die "Unexpected type ", .^name } - } -} - class _007::Object { has $.type; has $.id = unique-id; diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index b6e43a9c..4ebcafdb 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -1,3 +1,4 @@ +use _007::Type; use _007::Object; use _007::Precedence; diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index ea77ddb1..01fedbdc 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -1,3 +1,4 @@ +use _007::Type; use _007::Object; use _007::Parser::Syntax; diff --git a/lib/_007/Parser/Syntax.pm b/lib/_007/Parser/Syntax.pm index 6bb5c886..7af3ccac 100644 --- a/lib/_007/Parser/Syntax.pm +++ b/lib/_007/Parser/Syntax.pm @@ -1,3 +1,4 @@ +use _007::Type; use _007::Object; sub check-feature-flag($feature, $word) { diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 90b24d32..4bcce65a 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -1,3 +1,4 @@ +use _007::Type; use _007::Object; use _007::Builtins; use _007::OpScope; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 7654d7c7..f7b20158 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -1,5 +1,6 @@ use v6; use _007; +use _007::Type; use _007::Object; use _007::Backend::JavaScript; diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm new file mode 100644 index 00000000..5a1c995f --- /dev/null +++ b/lib/_007/Type.pm @@ -0,0 +1,183 @@ +class Helper { ... } + +sub unique-id is export { ++$ } + +constant TYPE = hash(); + +class _007::Type { + 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; + } + + method attributes { () } + + method quoted-Str { self.Str } + method Str { + my %*stringification-seen; + Helper::Str(self); + } +} + +BEGIN { + for -> $name { + TYPE{$name} = _007::Type.new(:$name); + } +} +for -> $name { + TYPE{$name} = _007::Type.new(:$name); +} +TYPE = _007::Type.new(:name, :fields["message"]); +TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :fields["contents"]); + +TYPE = _007::Type.new(:name, :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["propertylist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["type", "propertylist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "contents"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["elements"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "frame"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameterlist", "statementlist", "static-lexpad"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "lhs", "rhs"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["index"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["argumentlist"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["property"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["operand"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["lhs", "rhs"]); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new(:name, :base(TYPE)); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["statements"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["arguments"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameters"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["key", "value"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["properties"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); +TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); + +class Helper { + 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 + }).join(", "); + } + + our sub Str($_) { + when _007::Type { "" } + when .type === TYPE | TYPE { .name } + when .type === TYPE { .quoted-Str } + when .type === TYPE { .quoted-Str } + when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + "/" ~ .contents.quoted-Str ~ "/" + } + when .isa("Q") { + my $self = $_; + my @props = $self.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($self.isa("Q::Identifier") && $_ eq "frame") && + !($self.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return "{$self.type.name} { $self.properties{@props[0]}.quoted-Str }"; + } + sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return "{$self.type.name} \{\n$contents\n\}"; + } + when .^name eq "_007::Object::Wrapped" { .value.Str } + default { die "Unexpected type ", .^name } + } +} From b6f1a23226483052e74d4187b71a9c5f9bff711b Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 17:04:19 +0200 Subject: [PATCH 56/91] demote Helper from class to sub --- lib/_007/Object.pm | 2 +- lib/_007/Type.pm | 98 ++++++++++++++++++++++------------------------ 2 files changed, 48 insertions(+), 52 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 65ac4f8f..43ec0b01 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -89,7 +89,7 @@ class _007::Object { method Str { my %*stringification-seen; - Helper::Str(self); + str-helper(self); } method quoted-Str { self.Str } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 5a1c995f..79132139 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -1,5 +1,3 @@ -class Helper { ... } - sub unique-id is export { ++$ } constant TYPE = hash(); @@ -30,7 +28,7 @@ class _007::Type { method quoted-Str { self.Str } method Str { my %*stringification-seen; - Helper::Str(self); + str-helper(self); } } @@ -124,60 +122,58 @@ TYPE = _007::Type.new(:name, :base(TYPE), :fields["identi TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); -class Helper { - sub escaped($name) { - sub escape-backslashes($s) { $s.subst(/\\/, "\\\\", :g) } - sub escape-less-thans($s) { $s.subst(/"<"/, "\\<", :g) } +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 $name + unless $name ~~ /^ (prefix | infix | postfix) ':' (.+) /; - return "{$0}:<{escape-less-thans escape-backslashes $1}>" - if $1.contains(">") && $1.contains("»"); + 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}»" + if $1.contains(">"); - return "{$0}:<{escape-backslashes $1}>"; - } + return "{$0}:<{escape-backslashes $1}>"; +} - sub pretty($parameterlist) { - return sprintf "(%s)", $parameterlist.properties.value.map({ - .properties.properties - }).join(", "); - } +sub pretty($parameterlist) { + return sprintf "(%s)", $parameterlist.properties.value.map({ + .properties.properties + }).join(", "); +} - our sub Str($_) { - when _007::Type { "" } - when .type === TYPE | TYPE { .name } - when .type === TYPE { .quoted-Str } - when .type === TYPE { .quoted-Str } - when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - "/" ~ .contents.quoted-Str ~ "/" - } - when .isa("Q") { - my $self = $_; - my @props = $self.type.type-chain.reverse.map({ .fields }).flat; - # XXX: thuggish way to hide things that weren't listed in `attributes` before - @props.=grep: { - !($self.isa("Q::Identifier") && $_ eq "frame") && - !($self.isa("Q::Block") && $_ eq "static-lexpad") - }; - if @props == 1 { - return "{$self.type.name} { $self.properties{@props[0]}.quoted-Str }"; - } - sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } - my $contents = @props.map(&keyvalue).join(",\n").indent(4); - return "{$self.type.name} \{\n$contents\n\}"; +our sub str-helper($_) is export { + when _007::Type { "" } + when .type === TYPE | TYPE { .name } + when .type === TYPE { .quoted-Str } + when .type === TYPE { .quoted-Str } + when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + sprintf "", escaped(.properties.value), pretty(.properties) + } + when .type === TYPE { + "/" ~ .contents.quoted-Str ~ "/" + } + when .isa("Q") { + my $self = $_; + my @props = $self.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($self.isa("Q::Identifier") && $_ eq "frame") && + !($self.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return "{$self.type.name} { $self.properties{@props[0]}.quoted-Str }"; } - when .^name eq "_007::Object::Wrapped" { .value.Str } - default { die "Unexpected type ", .^name } + sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return "{$self.type.name} \{\n$contents\n\}"; } + when .^name eq "_007::Object::Wrapped" { .value.Str } + default { die "Unexpected type ", .^name } } From 0917b3ac3b40d0f0dbea7d5376be48a04503018d Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 17:26:33 +0200 Subject: [PATCH 57/91] remove a lot of unnecessary typechecks These have played out their role now that we have fully bootstrapped onto _007::Object. --- lib/_007/Builtins.pm | 64 +++++++++++++++----------------- lib/_007/Object.pm | 50 ++++++++++++------------- lib/_007/Parser/Actions.pm | 8 ++-- lib/_007/Runtime.pm | 76 +++++++++++++++++++------------------- lib/_007/Type.pm | 7 ++++ 5 files changed, 103 insertions(+), 102 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 947f1b6f..beff8464 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -224,7 +224,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:::' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<::>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Array"); + unless $rhs.isa("Array"); return wrap([$lhs, |$rhs.value]); }, :qtype(TYPE), @@ -235,9 +235,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:+' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Int"); + unless $lhs.isa("Int"); die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); return wrap($lhs.value + $rhs.value); }, :qtype(TYPE), @@ -245,9 +245,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<~>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Str"); + unless $lhs.isa("Str"); die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Str"); + unless $rhs.isa("Str"); return wrap($lhs.value ~ $rhs.value); }, :qtype(TYPE), @@ -256,9 +256,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:-' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<->, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Int"); + unless $lhs.isa("Int"); die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); return wrap($lhs.value - $rhs.value); }, :qtype(TYPE), @@ -268,9 +268,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:*' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Int"); + unless $lhs.isa("Int"); die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); return wrap($lhs.value * $rhs.value); }, :qtype(TYPE), @@ -278,9 +278,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Int"); + unless $lhs.isa("Int"); die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value % $rhs.value); @@ -290,9 +290,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%%' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation<%%>, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Int"); + unless $lhs.isa("Int"); die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); @@ -302,9 +302,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:x' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Str"); + unless $lhs.isa("Str"); die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); return wrap($lhs.value x $rhs.value); }, :qtype(TYPE), @@ -313,9 +313,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:xx' => op( sub ($lhs, $rhs) { die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) - unless $lhs ~~ _007::Object && $lhs.isa("Array"); + unless $lhs.isa("Array"); die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) - unless $rhs ~~ _007::Object && $rhs.isa("Int"); + unless $rhs.isa("Int"); return wrap(| $lhs.value xx $rhs.value); }, :qtype(TYPE), @@ -329,14 +329,12 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:+' => op( sub prefix-plus($expr) { - if $expr ~~ _007::Object { - if $expr.isa("Str") { - return wrap($expr.value.Int) - if $expr.value ~~ /^ '-'? \d+ $/; - } - elsif $expr.isa("Int") { - return $expr; - } + if $expr.isa("Str") { + return wrap($expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; + } + elsif $expr.isa("Int") { + return $expr; } die X::TypeCheck.new( :operation("prefix:<+>"), @@ -347,14 +345,12 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:-' => op( sub prefix-minus($expr) { - if $expr ~~ _007::Object { - if $expr.isa("Str") { - return wrap(-$expr.value.Int) - if $expr.value ~~ /^ '-'? \d+ $/; - } - elsif $expr.isa("Int") { - return wrap(-$expr.value); - } + if $expr.isa("Str") { + return wrap(-$expr.value.Int) + if $expr.value ~~ /^ '-'? \d+ $/; + } + elsif $expr.isa("Int") { + return wrap(-$expr.value); } die X::TypeCheck.new( :operation("prefix:<->"), @@ -378,7 +374,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:^' => op( sub ($n) { die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) - unless $n ~~ _007::Object && $n.isa("Int"); + unless $n.isa("Int"); return wrap([(^$n.value).map(&wrap)]); }, :qtype(TYPE), diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 43ec0b01..e1c6c22f 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -272,7 +272,7 @@ sub bound-method($object, $name) is export { my $array = bound-method($object.properties, "eval")($runtime); die X::TypeCheck.new(:operation("for loop"), :got($array), :expected(_007::Object)) - unless $array ~~ _007::Object && $array.isa("Array"); + unless $array.isa("Array"); for $array.value -> $arg { $runtime.enter( @@ -417,20 +417,20 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Postfix::Index") && $name eq "eval" { return sub eval-q-postfix-index($runtime) { given bound-method($object.properties, "eval")($runtime) { - if $_ ~~ _007::Object && .isa("Array") { + if .isa("Array") { my $index = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.isa("Int"); + unless $index.isa("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 $_ ~~ _007::Object && .isa("Dict") { + if .isa("Dict") { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.isa("Str"); + unless $property.isa("Str"); my $key = $property.value; return .value{$key}; } @@ -443,9 +443,9 @@ sub bound-method($object, $name) is export { return sub eval-q-postfix-call($runtime) { my $c = bound-method($object.properties, "eval")($runtime); die "macro is called at runtime" - if $c ~~ _007::Object && $c.isa("Macro"); + if $c.isa("Macro"); die "Trying to invoke a {$c.type.name}" # XXX: make this into an X:: - unless $c ~~ _007::Object && $c.isa("Sub"); + unless $c.isa("Sub"); my @arguments = $object.properties.properties.value.map({ bound-method($_, "eval")($runtime) }); @@ -528,41 +528,41 @@ sub bound-method($object, $name) is export { return sub eval-q-term-quasi($runtime) { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.isa("Array"); + if $thing.isa("Array"); sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.isa("Dict"); + if $thing.isa("Dict"); return $thing if $thing ~~ _007::Type; return $thing - if $thing ~~ _007::Object && ($thing.isa("Int") || $thing.isa("Str")); + if $thing.isa("Int") || $thing.isa("Str"); return $thing - if $thing ~~ _007::Object && $thing.isa("Sub"); + if $thing.isa("Sub"); return create($thing.type, :name($thing.properties), :frame($runtime.current-frame)) - if $thing ~~ _007::Object && $thing.isa("Q::Identifier"); + if $thing.isa("Q::Identifier"); - if $thing ~~ _007::Object && $thing.isa("Q::Unquote::Prefix") { + if $thing.isa("Q::Unquote::Prefix") { my $prefix = bound-method($thing.properties, "eval")($runtime); die X::TypeCheck.new(:operation("interpolating an unquote"), :got($prefix), :expected(_007::Object)) - unless $prefix ~~ _007::Object && $prefix.isa("Q::Prefix"); + unless $prefix.isa("Q::Prefix"); return create($prefix.type, :identifier($prefix.properties), :operand($thing.properties)); } - elsif $thing ~~ _007::Object && $thing.isa("Q::Unquote::Infix") { + elsif $thing.isa("Q::Unquote::Infix") { my $infix = bound-method($thing.properties, "eval")($runtime); die X::TypeCheck.new(:operation("interpolating an unquote"), :got($infix), :expected(_007::Object)) - unless $infix ~~ _007::Object && $infix.isa("Q::Infix"); + unless $infix.isa("Q::Infix"); return create($infix.type, :identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); } - if $thing ~~ _007::Object && $thing.isa("Q::Unquote") { + if $thing.isa("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 ~~ _007::Object && $ast.isa("Q"); + unless $ast.isa("Q"); return $ast; } @@ -603,7 +603,7 @@ sub bound-method($object, $name) is export { ?? create(TYPE, :message(wrap("Died"))) !! bound-method($object.properties, "eval")($runtime); die X::TypeCheck.new(:got($value), :expected(_007::Object)) - unless $value ~~ _007::Object && $value.isa("Exception"); + unless $value.isa("Exception"); die X::_007::RuntimeException.new(:msg($value.properties.value)); }; @@ -612,10 +612,10 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Postfix::Index") && $name eq "put-value" { return sub put-value-q-postfix-index($value, $runtime) { given bound-method($object.properties, "eval")($runtime) { - if $_ ~~ _007::Object && .isa("Array") { + if .isa("Array") { my $index = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonInteger.new - unless $index ~~ _007::Object && $index.isa("Int"); + unless $index.isa("Int"); die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) if $index.value >= .value; die X::Subscript::Negative.new(:$index, :type([])) @@ -623,10 +623,10 @@ sub bound-method($object, $name) is export { .value[$index.value] = $value; return; } - if $_ ~~ _007::Object && (.isa("Dict") || .isa("Q")) { + if .isa("Dict") || .isa("Q") { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new - unless $property ~~ _007::Object && $property.isa("Str"); + unless $property.isa("Str"); my $propname = $property.value; $runtime.put-property($_, $propname, $value); return; @@ -639,7 +639,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Postfix::Property") && $name eq "put-value" { return sub put-value-q-postfix-property($value, $runtime) { given bound-method($object.properties, "eval")($runtime) { - if $_ ~~ _007::Object && (.isa("Dict") || .isa("Q")) { + if .isa("Dict") || .isa("Q") { my $propname = $object.properties.properties.value; $runtime.put-property($_, $propname, $value); return; @@ -723,7 +723,7 @@ sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { sub internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" - unless $sub ~~ _007::Object && $sub.type === TYPE | TYPE; # XXX: should do subtyping check + unless $sub.isa("Sub"); # XXX: should do subtyping check if $sub ~~ _007::Object::Wrapped && $sub.type === TYPE { die "Don't handle the wrapped macro case yet"; diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 01fedbdc..c46435de 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -295,9 +295,7 @@ class _007::Parser::Actions { sub is-macro($q, $qtype, $identifier) { $q.isa($qtype) && $identifier.isa("Q::Identifier") - && (my $macro = $*runtime.maybe-get-var($identifier.properties.value)) ~~ _007::Object - && $macro.isa("Macro") - && $macro; + && $*runtime.maybe-get-var($identifier.properties.value).isa("Macro"); } sub expand($macro, @arguments, &unexpanded-callback:()) { @@ -578,9 +576,9 @@ class _007::Parser::Actions { $*parser.postpone: sub checking-postdeclared { my $value = $*runtime.maybe-get-var($name, $frame); die X::Macro::Postdeclared.new(:$name) - if $value ~~ _007::Object && $value.isa("Macro"); + if $value.isa("Macro"); die X::Undeclared.new(:symbol($name)) - unless $value ~~ _007::Object && $value.isa("Sub"); + unless $value.isa("Sub"); }; } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 4bcce65a..0dac7912 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -183,15 +183,15 @@ class _007::Runtime { return wrap-fn(&fn, $name, $parameterlist, $statementlist); } - if $obj ~~ _007::Object && $obj.isa("Q") { + if $obj.isa("Q") { if $propname eq "detach" { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing ~~ _007::Object && $thing.isa("Array"); + if $thing.isa("Array"); sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing ~~ _007::Object && $thing.isa("Dict"); + if $thing.isa("Dict"); return create($thing.type, :name($thing.properties), :frame(NONE)) if $thing.isa("Q::Identifier"); @@ -224,118 +224,118 @@ class _007::Runtime { return $obj.properties{$propname}; } - elsif $obj ~~ _007::Object && $obj.isa("Int") && $propname eq "abs" { + elsif $obj.isa("Int") && $propname eq "abs" { return builtin(sub abs() { return wrap($obj.value.abs); }); } - elsif $obj ~~ _007::Object && $obj.isa("Int") && $propname eq "chr" { + elsif $obj.isa("Int") && $propname eq "chr" { return builtin(sub chr() { return wrap($obj.value.chr); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "ord" { + elsif $obj.isa("Str") && $propname eq "ord" { return builtin(sub ord() { return wrap($obj.value.ord); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "chars" { + elsif $obj.isa("Str") && $propname eq "chars" { return builtin(sub chars() { return wrap($obj.value.chars); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "uc" { + elsif $obj.isa("Str") && $propname eq "uc" { return builtin(sub uc() { return wrap($obj.value.uc); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "lc" { + elsif $obj.isa("Str") && $propname eq "lc" { return builtin(sub lc() { return wrap($obj.value.lc); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "trim" { + elsif $obj.isa("Str") && $propname eq "trim" { return builtin(sub trim() { return wrap($obj.value.trim); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "size" { + elsif $obj.isa("Array") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "reverse" { + elsif $obj.isa("Array") && $propname eq "reverse" { return builtin(sub reverse() { return wrap($obj.value.reverse); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "sort" { + elsif $obj.isa("Array") && $propname eq "sort" { return builtin(sub sort() { return wrap($obj.value.sort); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "shuffle" { + elsif $obj.isa("Array") && $propname eq "shuffle" { return builtin(sub shuffle() { return wrap($obj.value.pick(*)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "concat" { + elsif $obj.isa("Array") && $propname eq "concat" { return builtin(sub concat($array) { die X::TypeCheck.new(:operation, :got($array), :expected(_007::Object)) - unless $array ~~ _007::Object && $array.isa("Array"); + unless $array.isa("Array"); return wrap([|$obj.value, |$array.value]); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "join" { + elsif $obj.isa("Array") && $propname eq "join" { return builtin(sub join($sep) { return wrap($obj.value.join($sep.value.Str)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Dict") && $propname eq "size" { + elsif $obj.isa("Dict") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "split" { + elsif $obj.isa("Str") && $propname eq "split" { return builtin(sub split($sep) { my @elements = $obj.value.split($sep.value).map(&wrap); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "index" { + elsif $obj.isa("Str") && $propname eq "index" { return builtin(sub index($substr) { return wrap($obj.value.index($substr.value) // -1); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "substr" { + elsif $obj.isa("Str") && $propname eq "substr" { return builtin(sub substr($pos, $chars) { return wrap($obj.value.substr( $pos.value, $chars.value)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "contains" { + elsif $obj.isa("Str") && $propname eq "contains" { return builtin(sub contains($substr) { die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) - unless $substr ~~ _007::Object && $substr.isa("Str"); + unless $substr.isa("Str"); return wrap($obj.value.contains($substr.value)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "prefix" { + elsif $obj.isa("Str") && $propname eq "prefix" { return builtin(sub prefix($pos) { return wrap($obj.value.substr( 0, $pos.value)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "suffix" { + elsif $obj.isa("Str") && $propname eq "suffix" { return builtin(sub suffix($pos) { return wrap($obj.value.substr( $pos.value)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Str") && $propname eq "charat" { + elsif $obj.isa("Str") && $propname eq "charat" { return builtin(sub charat($pos) { my $s = $obj.value; @@ -345,61 +345,61 @@ class _007::Runtime { return wrap($s.substr($pos.value, 1)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Regex") && $propname eq "fullmatch" { + elsif $obj.isa("Regex") && $propname eq "fullmatch" { return builtin(sub fullmatch($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str ~~ _007::Object && $str.isa("Str"); + unless $str.isa("Str"); return wrap($regex-string eq $str.value); }); } - elsif $obj ~~ _007::Object && $obj.isa("Regex") && $propname eq "search" { + elsif $obj.isa("Regex") && $propname eq "search" { return builtin(sub search($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str ~~ _007::Object && $str.isa("Str"); + unless $str.isa("Str"); return wrap($str.value.contains($regex-string)); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "filter" { + elsif $obj.isa("Array") && $propname eq "filter" { return builtin(sub filter($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.grep({ internal-call($fn, self, [$_]).truthy }); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "map" { + elsif $obj.isa("Array") && $propname eq "map" { return builtin(sub map($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); return wrap(@elements); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "push" { + elsif $obj.isa("Array") && $propname eq "push" { return builtin(sub push($newelem) { $obj.value.push($newelem); return NONE; }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "pop" { + elsif $obj.isa("Array") && $propname eq "pop" { return builtin(sub pop() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.pop(); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "shift" { + elsif $obj.isa("Array") && $propname eq "shift" { return builtin(sub shift() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.shift(); }); } - elsif $obj ~~ _007::Object && $obj.isa("Array") && $propname eq "unshift" { + elsif $obj.isa("Array") && $propname eq "unshift" { return builtin(sub unshift($newelem) { $obj.value.unshift($newelem); return NONE; @@ -420,7 +420,7 @@ class _007::Runtime { }))); }); } - elsif $obj ~~ _007::Object && ($obj.properties{$propname} :exists) { + elsif $obj.properties{$propname} :exists { return $obj.properties{$propname}; } elsif $propname eq "get" { @@ -470,7 +470,7 @@ class _007::Runtime { } method put-property($obj, Str $propname, $newvalue) { - if $obj !~~ _007::Object || !$obj.isa("Dict") { + if !$obj.isa("Dict") { die "We don't handle assigning to non-Dict types yet"; } else { diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 79132139..497a4f17 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -23,6 +23,13 @@ class _007::Type { return @chain; } + multi method isa(Str $typename) { + ($typename eq "Object" || $typename eq "Type") && self; + } + multi method isa(_007::Type $type) { + ($type === TYPE || $type === TYPE) && self; + } + method attributes { () } method quoted-Str { self.Str } From 5373115e048c4e1c6cb63d734a23e5f544973b7b Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 16 Sep 2017 17:31:18 +0200 Subject: [PATCH 58/91] get rid of type-of sub Just put a .type method on _007::Type instead. --- lib/_007/Builtins.pm | 6 +----- lib/_007/Runtime.pm | 4 ++-- lib/_007/Type.pm | 4 ++++ 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index beff8464..a2e3efa3 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,10 +1,6 @@ use _007::Type; use _007::Object; -proto type-of($) is export {*} -multi type-of(_007::Object $obj) { $obj.type } -multi type-of(_007::Type $obj) { TYPE } - sub builtins(:$input!, :$output!, :$opscope!) is export { # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } @@ -128,7 +124,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return wrap($input.get()); }, type => sub ($arg) { - type-of($arg); + $arg.type; }, # OPERATORS (from loosest to tightest within each category) diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 0dac7912..dd670ec4 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -218,7 +218,7 @@ class _007::Runtime { my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); - my $type = type-of($obj); + my $type = $obj.type; die X::Property::NotFound.new(:$propname, :$type) unless %known-properties{$propname}; @@ -464,7 +464,7 @@ class _007::Runtime { return wrap($obj.id); } else { - my $type = type-of($obj); + my $type = $obj.type; die X::Property::NotFound.new(:$propname, :$type); } } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 497a4f17..b23695b1 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -23,6 +23,10 @@ class _007::Type { return @chain; } + method type { + TYPE; + } + multi method isa(Str $typename) { ($typename eq "Object" || $typename eq "Type") && self; } From 2ed8c5ef52c46bb42d5d82e2f3a2e221371f52cf Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 17 Sep 2017 16:58:35 +0200 Subject: [PATCH 59/91] Put back the API documentation the way it was. Some of the API documentation tests now fail because this branch has introduced two new types. --- lib/_007/Type.pm | 879 +++++++++++++++++++++++++++- t/api-documentation/code-snippets.t | 2 +- t/api-documentation/comments.t | 4 +- 3 files changed, 856 insertions(+), 29 deletions(-) diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index b23695b1..278bdc5b 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -44,93 +44,920 @@ class _007::Type { } BEGIN { - for -> $name { - TYPE{$name} = _007::Type.new(:$name); - } -} -for -> $name { - TYPE{$name} = _007::Type.new(:$name); + ### ### Object + ### + ### (XXX: much of the following is wrong now that Dict has been separated out from 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` + ### + 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); + + ### ### 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); + + ### ### 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); } + +### ### 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); + +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["message"]); + +### ### 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", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); + +### ### 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["contents"]); +### ### Q +### +### An program element; anything that forms a node in the syntax tree +### representing a program. +### TYPE = _007::Type.new(:name, :is-abstract); -TYPE = _007::Type.new(:name, :base(TYPE), :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["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`. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); + +### ### Q::Literal::Str +### +### A string literal. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### 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", "frame"]); + +### ### Q::Term::Regex +### +### A regular expression (*regex*). +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); + +### ### 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["elements"]); + TYPE = _007::Type.new(:name, :base(TYPE), :fields["propertylist"]); + +### ### 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["type", "propertylist"]); + +### ### Q::Property +### +### An object property. Properties have a key and a value. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["key", "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. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["properties"]); + +### ### 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["identifier", "expr"]); + +### ### Q::TraitList +### +### A list of zero or more traits. Each routine has a traitlist. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); + +### ### Q::Term::Sub +### +### A subroutine. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "contents"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["elements"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "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. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameterlist", "statementlist", "static-lexpad"]); -TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); + +### ### Q::Prefix +### +### A prefix operator; an operator that occurs before a term, like the +### `-` in `-5`. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); + +### ### 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["identifier", "lhs", "rhs"]); + +### ### 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["identifier", "operand"]); + +### ### 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["index"]); + +### ### Q::Postfix::Call +### +### An invocation operator; calls a routine. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["argumentlist"]); + +### ### Q::Postfix::Property +### +### An object property operator; fetches a property out of an object. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["property"]); + +### ### Q::Unquote +### +### An unquote; allows Qtree fragments to be inserted into places in a quasi. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "expr"]); + +### ### Q::Unquote::Prefix +### +### An unquote which is a prefix operator. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["operand"]); + +### ### Q::Unquote::Infix +### +### An unquote which is an infix operator. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["lhs", "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. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "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. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier"]); + +### ### Q::ParameterList +### +### A list of zero or more parameters. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameters"]); + +### ### Q::ArgumentList +### +### A list of zero or more arguments. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["arguments"]); + +### ### 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["identifier", "expr"]); + +### ### Q::Statement::Constant +### +### A `constant` declaration statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); + +### ### Q::Statement::Expr +### +### A statement consisting of an expression. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); + +### ### Q::Statement::If +### +### An `if` statement. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); + +### ### Q::Statement::Block +### +### A block statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); + +### ### 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["expr", "block"]); + +### ### Q::Statement::While +### +### A `while` loop statement. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); + +### ### Q::Statement::Return +### +### A `return` statement. +### +TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); + +### ### Q::Statement::Throw +### +### A `throw` statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); + +### ### Q::Statement::Sub +### +### A subroutine declaration statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); + +### ### Q::Statement::Macro +### +### A macro declaration statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); + +### ### Q::Statement::BEGIN +### +### A `BEGIN` block statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); + +### ### Q::Statement::Class +### +### A class declaration statement. +### TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); -TYPE = _007::Type.new(:name, :base(TYPE)); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); + +### ### 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["statements"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["arguments"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameters"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["key", "value"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["properties"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); -TYPE = _007::Type.new(:name, :base(TYPE), :fields["traits"]); + +### ### 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["statementlist"]); sub escaped($name) { diff --git a/t/api-documentation/code-snippets.t b/t/api-documentation/code-snippets.t index 8ce66d04..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 fb2ee25b..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"; } From c43a515994b3fb12fa55bc19daea76b7d1731644 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 17 Sep 2017 17:13:51 +0200 Subject: [PATCH 60/91] sort out Object/Dict in the documentation --- lib/_007/Type.pm | 107 ++++++++++------------------------------------- 1 file changed, 22 insertions(+), 85 deletions(-) diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 278bdc5b..89ee0496 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -46,90 +46,10 @@ class _007::Type { BEGIN { ### ### Object ### - ### (XXX: much of the following is wrong now that Dict has been separated out from 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` + ### 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); @@ -141,7 +61,7 @@ BEGIN { ### ### say(type(007)); # --> `` ### say(type("Bond")); # --> `` - ### say(type({})); # --> `` + ### say(type({})); # --> `` ### say(type(type({}))); # --> `` ### ### 007 comes with a number of built-in types: `NoneType`, `Bool`, `Int`, @@ -388,6 +308,23 @@ TYPE = _007::Type.new(:name); ### 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({})); # --> `` +### TYPE = _007::Type.new(:name); ### ### Exception From 8d4d20975d1d403400feda84ad602bcdcff9ad0d Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 17 Sep 2017 17:18:36 +0200 Subject: [PATCH 61/91] document Q::Term::Dict --- lib/_007/Type.pm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 89ee0496..61bdfc70 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -462,6 +462,11 @@ TYPE = _007::Type.new(:name, :base(TYPE ### TYPE = _007::Type.new(:name, :base(TYPE), :fields["elements"]); +### ### 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["propertylist"]); ### ### Q::Term::Object From 41b5c8d1784994ef93dfb5cfcc0ee9f5b7e80361 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 08:13:11 +0200 Subject: [PATCH 62/91] simplify the lookup for prefixes/infixes --- lib/_007/Object.pm | 34 ++-------------------------------- 1 file changed, 2 insertions(+), 32 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index e1c6c22f..9e216bdb 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -359,28 +359,7 @@ sub bound-method($object, $name) is export { }; } - # XXX: these should sit on Q::Infix - my @infixes = < - Q::Infix::TypeMatch - Q::Infix::TypeNonMatch - Q::Infix::Eq - Q::Infix::Ne - Q::Infix::Concat - Q::Infix::Addition - Q::Infix::Subtraction - Q::Infix::Multiplication - Q::Infix::Replicate - Q::Infix::ArrayReplicate - Q::Infix::Gt - Q::Infix::Lt - Q::Infix::Ge - Q::Infix::Le - Q::Infix::Modulo - Q::Infix::Divisibility - Q::Infix::Cons - Q::Infix - >; - if any(@infixes.map({ $object.type === TYPE{$_} })) && $name eq "eval" { + if $object.isa("Q::Infix") && $name eq "eval" { return sub eval-q-infix($runtime) { my $l = bound-method($object.properties, "eval")($runtime); my $r = bound-method($object.properties, "eval")($runtime); @@ -389,16 +368,7 @@ sub bound-method($object, $name) is export { }; } - # XXX: these should sit on Q::Prefix - my @prefixes = < - Q::Prefix::Upto - Q::Prefix::Str - Q::Prefix::Plus - Q::Prefix::Minus - Q::Prefix::Not - Q::Prefix - >; - if any(@prefixes.map({ $object.type === TYPE{$_} })) && $name eq "eval" { + if $object.isa("Q::Prefix") && $name eq "eval" { return sub eval-q-prefix($runtime) { my $e = bound-method($object.properties, "eval")($runtime); my $c = bound-method($object.properties, "eval")($runtime); From 2838b0a1cee6a803367be8b2b43a82c09b9e2532 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 08:54:26 +0200 Subject: [PATCH 63/91] add count-builtins script Less error-prone than having to count them ourselves. --- bin/count-builtins | 74 ++++++++++++++++++++++++++++++++++ t/integration/count-builtins.t | 13 ++++++ 2 files changed, 87 insertions(+) create mode 100755 bin/count-builtins create mode 100644 t/integration/count-builtins.t diff --git a/bin/count-builtins b/bin/count-builtins new file mode 100755 index 00000000..b4c5c3c3 --- /dev/null +++ b/bin/count-builtins @@ -0,0 +1,74 @@ +#!/usr/bin/env perl6 +use v6; + +my $type_count = 0; +my $bound_method_count = 0; +my $runtime_builtin_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.isa" / { + $bound_method_count++; + } + elsif /^ \h* "}" / { + # do nothing + } + elsif /^ \h* "die " / { + # do nothing + } + else { + die "Unexpected line: `$_`"; + } + } + } + } +} + +for -> $file { + for $file.IO.lines { + if /^ \h* "return builtin(" / { + $runtime_builtin_method_count++; + } + } +} + +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 methods in Runtime.pm: $runtime_builtin_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/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; From a0b03b85d2e14d7290e685dfff644b10652af510 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 11:18:20 +0200 Subject: [PATCH 64/91] put back the type information in X::Type exceptions We create our own X::Type, in order to be able to specify type via TYPE and _007::Type. --- lib/_007/Builtins.pm | 64 +++++++++++----------- lib/_007/Object.pm | 25 +++++++-- lib/_007/Parser/Actions.pm | 2 +- lib/_007/Runtime.pm | 4 +- lib/_007/Type.pm | 2 +- t/code-style/do-not-use-str-in-typecheck.t | 4 +- t/features/builtins/operators.t | 8 +-- t/features/unquote.t | 8 +-- 8 files changed, 65 insertions(+), 52 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index a2e3efa3..ccc2312e 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -65,13 +65,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 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(_007::Object)); + :expected(TYPE)); } multi less-value(_007::Object $l, _007::Object $r) { - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) + die X::Type.new(:operation, :got($_), :expected(TYPE)) unless $l.type === $r.type; return $l.isa("Int") ?? $l.value < $r.value @@ -80,13 +80,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { !! die "Unknown type ", $l.type.Str; } multi more-value($, $) { - die X::TypeCheck.new( + die X::Type.new( :operation, :got($_), - :expected(_007::Object)); + :expected(TYPE)); } multi more-value(_007::Object $l, _007::Object $r) { - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)) + die X::Type.new(:operation, :got($_), :expected(TYPE)) unless $l.type === $r.type; return $l.isa("Int") ?? $l.value > $r.value @@ -197,8 +197,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:~~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(_007::Type)) - unless $rhs ~~ _007::Type; + die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) + unless $rhs.isa("Type"); return wrap(?$lhs.isa($rhs)); }, @@ -207,8 +207,8 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:!~~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~~>, :got($rhs), :expected(_007::Type)) - unless $rhs ~~ _007::Type; + die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) + unless $rhs.isa("Type"); return wrap(!$lhs.isa($rhs)); }, @@ -219,7 +219,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # cons precedence 'infix:::' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<::>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<::>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Array"); return wrap([$lhs, |$rhs.value]); }, @@ -230,9 +230,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # additive precedence 'infix:+' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<+>, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<+>, :got($lhs), :expected(TYPE)) unless $lhs.isa("Int"); - die X::TypeCheck.new(:operation<+>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<+>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); return wrap($lhs.value + $rhs.value); }, @@ -240,9 +240,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:~' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<~>, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<~>, :got($lhs), :expected(TYPE)) unless $lhs.isa("Str"); - die X::TypeCheck.new(:operation<~>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<~>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Str"); return wrap($lhs.value ~ $rhs.value); }, @@ -251,9 +251,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:-' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<->, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<->, :got($lhs), :expected(TYPE)) unless $lhs.isa("Int"); - die X::TypeCheck.new(:operation<->, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<->, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); return wrap($lhs.value - $rhs.value); }, @@ -263,9 +263,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # multiplicative precedence 'infix:*' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<*>, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<*>, :got($lhs), :expected(TYPE)) unless $lhs.isa("Int"); - die X::TypeCheck.new(:operation<*>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<*>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); return wrap($lhs.value * $rhs.value); }, @@ -273,9 +273,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:%' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<%>, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<%>, :got($lhs), :expected(TYPE)) unless $lhs.isa("Int"); - die X::TypeCheck.new(:operation<%>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<%>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; @@ -285,9 +285,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:%%' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation<%%>, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation<%%>, :got($lhs), :expected(TYPE)) unless $lhs.isa("Int"); - die X::TypeCheck.new(:operation<%%>, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation<%%>, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; @@ -297,9 +297,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:x' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation, :got($lhs), :expected(TYPE)) unless $lhs.isa("Str"); - die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); return wrap($lhs.value x $rhs.value); }, @@ -308,9 +308,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'infix:xx' => op( sub ($lhs, $rhs) { - die X::TypeCheck.new(:operation, :got($lhs), :expected(_007::Object)) + die X::Type.new(:operation, :got($lhs), :expected(TYPE)) unless $lhs.isa("Array"); - die X::TypeCheck.new(:operation, :got($rhs), :expected(_007::Object)) + die X::Type.new(:operation, :got($rhs), :expected(TYPE)) unless $rhs.isa("Int"); return wrap(| $lhs.value xx $rhs.value); }, @@ -332,10 +332,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $expr.isa("Int") { return $expr; } - die X::TypeCheck.new( + die X::Type.new( :operation("prefix:<+>"), :got($expr), - :expected(_007::Object)); + :expected(TYPE)); }, :qtype(TYPE), ), @@ -348,10 +348,10 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { elsif $expr.isa("Int") { return wrap(-$expr.value); } - die X::TypeCheck.new( + die X::Type.new( :operation("prefix:<->"), :got($expr), - :expected(_007::Object)); + :expected(TYPE)); }, :qtype(TYPE), ), @@ -369,7 +369,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:^' => op( sub ($n) { - die X::TypeCheck.new(:operation<^>, :got($n), :expected(_007::Object)) + die X::Type.new(:operation<^>, :got($n), :expected(TYPE)) unless $n.isa("Int"); return wrap([(^$n.value).map(&wrap)]); }, diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 9e216bdb..456b7609 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -62,6 +62,19 @@ class X::ParameterMismatch is Exception { } } +# 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 _007::Object { has $.type; has $.id = unique-id; @@ -271,7 +284,7 @@ sub bound-method($object, $name) is export { if $count > 1; my $array = bound-method($object.properties, "eval")($runtime); - die X::TypeCheck.new(:operation("for loop"), :got($array), :expected(_007::Object)) + die X::Type.new(:operation("for loop"), :got($array), :expected(TYPE)) unless $array.isa("Array"); for $array.value -> $arg { @@ -404,7 +417,7 @@ sub bound-method($object, $name) is export { my $key = $property.value; return .value{$key}; } - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); + die X::Type.new(:operation, :got($_), :expected(TYPE)); } }; } @@ -518,13 +531,13 @@ sub bound-method($object, $name) is export { if $thing.isa("Q::Unquote::Prefix") { my $prefix = bound-method($thing.properties, "eval")($runtime); - die X::TypeCheck.new(:operation("interpolating an unquote"), :got($prefix), :expected(_007::Object)) + die X::Type.new(:operation("interpolating an unquote"), :got($prefix), :expected(TYPE)) unless $prefix.isa("Q::Prefix"); return create($prefix.type, :identifier($prefix.properties), :operand($thing.properties)); } elsif $thing.isa("Q::Unquote::Infix") { my $infix = bound-method($thing.properties, "eval")($runtime); - die X::TypeCheck.new(:operation("interpolating an unquote"), :got($infix), :expected(_007::Object)) + die X::Type.new(:operation("interpolating an unquote"), :got($infix), :expected(TYPE)) unless $infix.isa("Q::Infix"); return create($infix.type, :identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); } @@ -572,7 +585,7 @@ sub bound-method($object, $name) is export { my $value = $object.properties === NONE ?? create(TYPE, :message(wrap("Died"))) !! bound-method($object.properties, "eval")($runtime); - die X::TypeCheck.new(:got($value), :expected(_007::Object)) + die X::Type.new(:got($value), :expected(TYPE)) unless $value.isa("Exception"); die X::_007::RuntimeException.new(:msg($value.properties.value)); @@ -601,7 +614,7 @@ sub bound-method($object, $name) is export { $runtime.put-property($_, $propname, $value); return; } - die X::TypeCheck.new(:operation, :got($_), :expected(_007::Object)); + die X::Type.new(:operation, :got($_), :expected(TYPE)); } }; } diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index c46435de..2a61b65f 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -766,7 +766,7 @@ class _007::Parser::Actions { method infix-unquote($/) { my $got = ~($ // "Q::Term"); - die X::TypeCheck.new(:operation, :$got, :expected(_007::Object)) + die X::Type.new(:operation, :$got, :expected(TYPE)) unless $got eq "Q::Infix"; make $.ast; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index dd670ec4..e50f6556 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -281,7 +281,7 @@ class _007::Runtime { } elsif $obj.isa("Array") && $propname eq "concat" { return builtin(sub concat($array) { - die X::TypeCheck.new(:operation, :got($array), :expected(_007::Object)) + die X::Type.new(:operation, :got($array), :expected(TYPE)) unless $array.isa("Array"); return wrap([|$obj.value, |$array.value]); }); @@ -316,7 +316,7 @@ class _007::Runtime { } elsif $obj.isa("Str") && $propname eq "contains" { return builtin(sub contains($substr) { - die X::TypeCheck.new(:operation, :got($substr), :expected(_007::Object)) + die X::Type.new(:operation, :got($substr), :expected(TYPE)) unless $substr.isa("Str"); return wrap($obj.value.contains($substr.value)); diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 61bdfc70..8e2d6366 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -133,7 +133,7 @@ BEGIN { ### ### say(!!None); # --> `False` ### say(~None); # --> `None` - ### say(+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: 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/builtins/operators.t b/t/features/builtins/operators.t index c6f7e499..1c8f825a 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -431,7 +431,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"; } { @@ -440,7 +440,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"; } { @@ -450,7 +450,7 @@ 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"; } { @@ -598,7 +598,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)"; } { 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"; } From 1b7566f0c1d4f64987b897547781e6fe6d85c36e Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 16:40:53 +0200 Subject: [PATCH 65/91] define Str and repr as built-in methods No more str-helper is needed. We now write `quoted-Str` as `repr`, following Python tradition. --- lib/_007/Backend/JavaScript.pm | 6 +- lib/_007/Builtins.pm | 16 ++- lib/_007/Linter.pm | 4 +- lib/_007/Object.pm | 182 +++++++++++++++++++++++++++------ lib/_007/Parser/Actions.pm | 7 +- lib/_007/Runtime.pm | 18 +++- lib/_007/Test.pm | 2 +- lib/_007/Type.pm | 62 ----------- t/features/quasi.t | 5 +- t/features/stringification.t | 2 +- 10 files changed, 194 insertions(+), 110 deletions(-) diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 6a246468..6ae3a6d9 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -39,7 +39,8 @@ class _007::Backend::JavaScript { my @arguments = $expr.properties.properties.value.map: { die "Cannot handle non-literal-Str arguments just yet!" unless .isa("Q::Literal::Str"); - .properties.quoted-Str; + # XXX: should really type-check the result of the .repr() call + bound-method(.properties, "repr")().value; }; @main.push("say({@arguments.join(", ")});"); } @@ -51,7 +52,8 @@ class _007::Backend::JavaScript { if $stmt.properties !=== NONE { die "Cannot handle non-literal-Int rhs just yet!" unless $stmt.properties.isa("Q::Literal::Int"); - my $expr = $stmt.properties.properties.Str; + # XXX: should really type-check the result of the .Str() call + my $expr = bound-method($stmt.properties.properties, "Str")().value; @main.push("let {$name} = {$expr};"); } else { diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index ccc2312e..0697dfd5 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -115,7 +115,12 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my @builtins = say => -> $arg { - $output.print($arg ~ "\n"); + my $str = bound-method($arg, "Str")(); + + die X::Type.new(:operation("printing"), :got(Str), :expected(TYPE)) + unless $str.isa("Str"); + + $output.print($str.value ~ "\n"); Nil; }, prompt => sub ($arg) { @@ -320,7 +325,14 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # prefixes 'prefix:~' => op( - sub prefix-str($expr) { wrap($expr.Str) }, + sub prefix-str($expr) { + my $str = bound-method($expr, "Str")(); + + die X::Type.new(:operation("stringification"), :got(Str), :expected(TYPE)) + unless $str.isa("Str"); + + return $str; + }, :qtype(TYPE), ), 'prefix:+' => op( diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index ed04b64a..22feebf9 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -74,7 +74,7 @@ class _007::Linter { } } elsif $node.isa("Q::Statement::Sub") -> $sub { - my $name = $sub.properties.properties; + my $name = $sub.properties.properties.value; %declared{"{@blocks[*-1].id}|$name"} = L::SubNotUsed; } elsif $node.isa("Q::Statement::Expr") -> $stexpr { @@ -105,7 +105,7 @@ class _007::Linter { traverse($for.properties); } elsif $node.isa("Q::Statement::My") -> $my { - my $name = $my.properties.properties; + my $name = $my.properties.properties.value; my $ref = "{@blocks[*-1].id}|$name"; %declared{$ref} = L::VariableNotUsed; if $my.properties !=== NONE { diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 456b7609..05925930 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -100,13 +100,6 @@ class _007::Object { method attributes { () } - method Str { - my %*stringification-seen; - str-helper(self); - } - - method quoted-Str { self.Str } - method truthy { truthy(self) } } @@ -161,30 +154,6 @@ class _007::Object::Wrapped is _007::Object { has $.value; method truthy { ?$.value } - - method quoted-Str { - if $.type === TYPE { - return q["] ~ $.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]; - } - if $.type === TYPE { - if %*stringification-seen{self.WHICH}++ { - return "[...]"; - } - return "[" ~ @($.value)».quoted-Str.join(', ') ~ "]"; - } - if $.type === TYPE { - if %*stringification-seen{self.WHICH}++ { - return "\{...\}"; - } - return '{' ~ %.value.map({ - my $key = .key ~~ /^ [\w+]+ % '::'$/ - ?? .key - !! wrap(.key).quoted-Str; - "{$key}: {.value.quoted-Str}" - }).sort.join(', ') ~ '}'; - } - return self.Str; - } } constant NONE is export = _007::Object::Enum.new(:type(TYPE), :name); @@ -195,6 +164,36 @@ TYPE.install-base(NONE); constant TRUE is export = _007::Object::Enum.new(:type(TYPE), :name); constant FALSE is export = _007::Object::Enum.new(:type(TYPE), :name); +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(", "); +} + +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) is export { @@ -662,9 +661,128 @@ sub bound-method($object, $name) is export { }; } + if $object.isa("Str") && $name eq "Str" { + return sub str-str() { + return $object; + } + } + + if $object.isa("Int") && $name eq "Str" { + return sub str-int() { + return wrap(~$object.value); + } + } + + if $object.isa("Bool") && $name eq "Str" { + return sub str-bool() { + return wrap($object.name); + } + } + + if $object.isa("NoneType") && $name eq "Str" { + return sub str-nonetype() { + return wrap($object.name); + } + } + + if $object.isa("Type") && $name eq "Str" { + return sub str-type() { + return wrap(""); + } + } + + if $object.isa("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({ + my $s = bound-method($_, "repr")(); + die X::Type.new(:operation("stringification"), :got($s), :expected(TYPE)) + unless $s.isa("Str"); + $s.value; + }).join(", ") ~ "]"); + }; + } + + if $object.isa("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 + !! bound-method(wrap(.key), "repr")().value; + "{$key}: {bound-method(.value, "repr")().value}"; + }).sort.join(', ') ~ '}'); + }; + } + + if $object.isa("Str") && $name eq "repr" { + return sub repr-str() { + return wrap(q["] ~ $object.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]); + } + } + + if $object.isa("Object") && $name eq "repr" { + return sub repr-object() { + return bound-method($object, "Str")(); + } + } + + if $object.isa("Macro") && $name eq "Str" { + return sub str-sub() { + return wrap( + sprintf "", + escaped($object.properties.value), + pretty($object.properties) + ); + }; + } + + if $object.isa("Sub") && $name eq "Str" { + return sub str-sub() { + return wrap( + sprintf "", + escaped($object.properties.value), + pretty($object.properties) + ); + }; + } + + if $object.isa("Q") && $name eq "Str" { + return sub str-q() { + my @props = $object.type.type-chain.reverse.map({ .fields }).flat; + # XXX: thuggish way to hide things that weren't listed in `attributes` before + @props.=grep: { + !($object.isa("Q::Identifier") && $_ eq "frame") && + !($object.isa("Q::Block") && $_ eq "static-lexpad") + }; + if @props == 1 { + return wrap("{$object.type.name} { bound-method($object.properties{@props[0]}, "repr")().value }"); + } + sub keyvalue($prop) { $prop ~ ": " ~ bound-method($object.properties{$prop}, "repr")().value } + my $contents = @props.map(&keyvalue).join(",\n").indent(4); + return wrap("{$object.type.name} \{\n$contents\n\}"); + }; + } + die "The invocant is undefined" if $object === Any; - die "Method '$name' does not exist on {$object.type.Str}"; + die "Method '$name' does not exist on {$object.type.name}"; } sub truthy($v) { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 2a61b65f..6bcd8a33 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -121,7 +121,7 @@ class _007::Parser::Actions { make create(TYPE, :block($.ast)); } - sub maybe-install-operator($identname, @trait) { + sub maybe-install-operator(Str $identname, @trait) { return unless $identname ~~ /^ (< prefix infix postfix >) ':' (.+) /; @@ -133,7 +133,7 @@ class _007::Parser::Actions { my @prec-traits = ; my $assoc; for @trait -> $trait { - my $name = $trait.ast.properties; + my $name = $trait.ast.properties.value; if $name eq any @prec-traits { my $identifier = $trait.ast; my $prep = $name eq "equal" ?? "to" !! "than"; @@ -202,7 +202,7 @@ class _007::Parser::Actions { bound-method($identifier, "put-value")($val, $*runtime); - maybe-install-operator($name, $); + maybe-install-operator($name.value, $); } method statement:return ($/) { @@ -799,7 +799,6 @@ class _007::Parser::Actions { make create(TYPE, property => $.ast, :$identifier, :operand(NONE)); } else { - say $; make create($*parser.opscope.ops{$op}.type, :$identifier, :operand(NONE)); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index e50f6556..20db7b8e 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -271,7 +271,14 @@ class _007::Runtime { } elsif $obj.isa("Array") && $propname eq "sort" { return builtin(sub sort() { - return wrap($obj.value.sort); + # 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($obj.value.map({ + die "Cannot sort a {.type.name}" + if $_ !~~ _007::Object::Wrapped; + .value; + }).sort().map(&wrap)); }); } elsif $obj.isa("Array") && $propname eq "shuffle" { @@ -288,7 +295,14 @@ class _007::Runtime { } elsif $obj.isa("Array") && $propname eq "join" { return builtin(sub join($sep) { - return wrap($obj.value.join($sep.value.Str)); + die X::Type.new(:operation, :got($sep), :expected(TYPE)) + unless $sep.isa("Str"); + return wrap($obj.value.map({ + my $s = bound-method($_, "Str")(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.isa("Str"); + $s.value; + }).join($sep.value)); }); } elsif $obj.isa("Dict") && $propname eq "size" { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index f7b20158..b80b6791 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -343,7 +343,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 bound-method($expected-ast, "Str")().value, bound-method($actual-ast, "Str")().value, $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 index 8e2d6366..4c93fdc7 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -35,12 +35,6 @@ class _007::Type { } method attributes { () } - - method quoted-Str { self.Str } - method Str { - my %*stringification-seen; - str-helper(self); - } } BEGIN { @@ -901,59 +895,3 @@ TYPE = _007::Type.new(:name, :base(TYPE), ### value is the value of the whole containing expression. ### TYPE = _007::Type.new(:name, :base(TYPE), :fields["statementlist"]); - -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 - }).join(", "); -} - -our sub str-helper($_) is export { - when _007::Type { "" } - when .type === TYPE | TYPE { .name } - when .type === TYPE { .quoted-Str } - when .type === TYPE { .quoted-Str } - when .type === TYPE { "Exception \{message: {.properties.quoted-Str}\}" } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - sprintf "", escaped(.properties.value), pretty(.properties) - } - when .type === TYPE { - "/" ~ .contents.quoted-Str ~ "/" - } - when .isa("Q") { - my $self = $_; - my @props = $self.type.type-chain.reverse.map({ .fields }).flat; - # XXX: thuggish way to hide things that weren't listed in `attributes` before - @props.=grep: { - !($self.isa("Q::Identifier") && $_ eq "frame") && - !($self.isa("Q::Block") && $_ eq "static-lexpad") - }; - if @props == 1 { - return "{$self.type.name} { $self.properties{@props[0]}.quoted-Str }"; - } - sub keyvalue($prop) { $prop ~ ": " ~ $self.properties{$prop}.quoted-Str } - my $contents = @props.map(&keyvalue).join(",\n").indent(4); - return "{$self.type.name} \{\n$contents\n\}"; - } - when .^name eq "_007::Object::Wrapped" { .value.Str } - default { die "Unexpected type ", .^name } -} diff --git a/t/features/quasi.t b/t/features/quasi.t index 3f5087b7..607018b6 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -1,5 +1,6 @@ use v6; use Test; +use _007::Object; use _007::Test; { @@ -7,9 +8,9 @@ use _007::Test; say(quasi { 1 + 1 }); . - my $expected = read( + my $expected = bound-method(read( "(statementlist (stexpr (infix:+ (int 1) (int 1))))" - ).properties.properties.properties.value[0].properties.Str; + ).properties.properties.properties.value[0].properties, "Str")().value; outputs $program, "$expected\n", "Basic quasi quoting"; } 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; From f5011347c96fb16aa5b42ef82594c268769b8969 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 16:47:51 +0200 Subject: [PATCH 66/91] remove obsolete method --- lib/_007/Object.pm | 2 -- lib/_007/Type.pm | 2 -- 2 files changed, 4 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 05925930..482f41b9 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -98,8 +98,6 @@ class _007::Object { return $type (elem) $.type.type-chain && self; } - method attributes { () } - method truthy { truthy(self) } } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 4c93fdc7..cbdf0dd4 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -33,8 +33,6 @@ class _007::Type { multi method isa(_007::Type $type) { ($type === TYPE || $type === TYPE) && self; } - - method attributes { () } } BEGIN { From 8864baa77155b97256efa187326337b2a1a8d1a6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 17:27:07 +0200 Subject: [PATCH 67/91] defined Bool as built-in method And avoid defining a `.truthy` method on _007::Object. This way, boolification is now a completely in-language affair. --- lib/_007/Builtins.pm | 16 +++++++++--- lib/_007/Object.pm | 62 +++++++++++++++++++++++++++++++++++--------- lib/_007/Runtime.pm | 2 +- 3 files changed, 63 insertions(+), 17 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 0697dfd5..870e8377 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -368,14 +368,22 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { :qtype(TYPE), ), 'prefix:?' => op( - sub ($a) { - return wrap(?$a.truthy) + sub ($arg) { + my $b = bound-method($arg, "Bool")(); + die X::Type.new(:operation, :got($b), :expected(TYPE)) + unless $b.isa("Bool"); + return $b; }, :qtype(TYPE), ), 'prefix:!' => op( - sub ($a) { - return wrap(!$a.truthy) + sub ($arg) { + my $b = bound-method($arg, "Bool")(); + die X::Type.new(:operation, :got($b), :expected(TYPE)) + unless $b.isa("Bool"); + return $b === TRUE + ?? FALSE + !! TRUE; }, :qtype(TYPE), ), diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 482f41b9..c83778ab 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -97,8 +97,6 @@ class _007::Object { return $type (elem) $.type.type-chain && self; } - - method truthy { truthy(self) } } sub create(_007::Type $type, *%properties) is export { @@ -150,8 +148,6 @@ class _007::Object::Enum is _007::Object { class _007::Object::Wrapped is _007::Object { has $.value; - - method truthy { ?$.value } } constant NONE is export = _007::Object::Enum.new(:type(TYPE), :name); @@ -300,7 +296,8 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Statement::While") && $name eq "run" { return sub run-q-statement-while($runtime) { - while (my $expr = bound-method($object.properties, "eval")($runtime)).truthy { + # XXX: need to typecheck the result coming back from .Bool + while bound-method((my $expr = bound-method($object.properties, "eval")($runtime)), "Bool")() === TRUE { my $paramcount = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new( :type("While loop"), :$paramcount, :argcount("0 or 1")) @@ -345,7 +342,8 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Infix::And") && $name eq "eval" { return sub eval-q-infix-and($runtime) { my $l = bound-method($object.properties, "eval")($runtime); - return $l.truthy + # XXX: need to typecheck result of .Bool + return bound-method($l, "Bool")() === TRUE ?? bound-method($object.properties, "eval")($runtime) !! $l; }; @@ -354,7 +352,8 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Infix::Or") && $name eq "eval" { return sub eval-q-infix-or($runtime) { my $l = bound-method($object.properties, "eval")($runtime); - return $l.truthy + # XXX: need to typecheck result of .Bool + return bound-method($l, "Bool")() === TRUE ?? $l !! bound-method($object.properties, "eval")($runtime); }; @@ -460,7 +459,8 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Statement::If") && $name eq "run" { return sub run-q-statement-if($runtime) { my $expr = bound-method($object.properties, "eval")($runtime); - if $expr.truthy { + # XXX: need to typecheck return value from .Bool + if bound-method($expr, "Bool")() === TRUE { my $paramcount = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new(:type("If statement"), :$paramcount, :argcount("0 or 1")) if $paramcount > 1; @@ -778,15 +778,53 @@ sub bound-method($object, $name) is export { }; } + if $object.isa("Bool") && $name eq "Bool" { + return sub bool-bool() { + return $object; + }; + } + + if $object.isa("NoneType") && $name eq "Bool" { + return sub bool-nonetype() { + return FALSE; + }; + } + + if $object.isa("Int") && $name eq "Bool" { + return sub bool-int() { + return wrap($object.value != 0); + }; + } + + if $object.isa("Str") && $name eq "Bool" { + return sub bool-str() { + return wrap($object.value ne ""); + }; + } + + if $object.isa("Array") && $name eq "Bool" { + return sub bool-array() { + return wrap($object.value.elems > 0); + }; + } + + if $object.isa("Dict") && $name eq "Bool" { + return sub bool-dict() { + return wrap($object.value.keys > 0); + }; + } + + if $object.isa("Object") && $name eq "Bool" { + return sub bool-object() { + return TRUE; + }; + } + die "The invocant is undefined" if $object === Any; die "Method '$name' does not exist on {$object.type.name}"; } -sub truthy($v) { - $v !=== NONE && $v !=== FALSE -} - sub wrap($value) is export { if $value ~~ Bool { return $value ?? TRUE !! FALSE; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 20db7b8e..8fd0a641 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -382,7 +382,7 @@ class _007::Runtime { elsif $obj.isa("Array") && $propname eq "filter" { return builtin(sub filter($fn) { # XXX: Need to typecheck here if $fn is callable - my @elements = $obj.value.grep({ internal-call($fn, self, [$_]).truthy }); + my @elements = $obj.value.grep({ bound-method(internal-call($fn, self, [$_]), "Bool")() === TRUE }); return wrap(@elements); }); } From 636903ed39b41d4d99be248b310e896791a0c415 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 18 Sep 2017 17:54:56 +0200 Subject: [PATCH 68/91] Revert "quarantine t/features/expr.t for now" This reverts commit 22f6c2462c0773f90fae768390b834b37ae5a285. --- t/features/{expr.t_quarantine => expr.t} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename t/features/{expr.t_quarantine => expr.t} (100%) diff --git a/t/features/expr.t_quarantine b/t/features/expr.t similarity index 100% rename from t/features/expr.t_quarantine rename to t/features/expr.t From bca5a8da45b8642ef1ab812a7b2dae00b480e8ed Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 07:46:41 +0200 Subject: [PATCH 69/91] abstract &stringify --- lib/_007/Backend/JavaScript.pm | 3 +-- lib/_007/Builtins.pm | 14 ++------------ lib/_007/Object.pm | 9 ++++++++- lib/_007/Runtime.pm | 7 +------ lib/_007/Test.pm | 2 +- 5 files changed, 13 insertions(+), 22 deletions(-) diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 6ae3a6d9..3c15b594 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -52,8 +52,7 @@ class _007::Backend::JavaScript { if $stmt.properties !=== NONE { die "Cannot handle non-literal-Int rhs just yet!" unless $stmt.properties.isa("Q::Literal::Int"); - # XXX: should really type-check the result of the .Str() call - my $expr = bound-method($stmt.properties.properties, "Str")().value; + my $expr = stringify($stmt.properties.properties); @main.push("let {$name} = {$expr};"); } else { diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 870e8377..149285ae 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -115,12 +115,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my @builtins = say => -> $arg { - my $str = bound-method($arg, "Str")(); - - die X::Type.new(:operation("printing"), :got(Str), :expected(TYPE)) - unless $str.isa("Str"); - - $output.print($str.value ~ "\n"); + $output.print(stringify($arg) ~ "\n"); Nil; }, prompt => sub ($arg) { @@ -326,12 +321,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # prefixes 'prefix:~' => op( sub prefix-str($expr) { - my $str = bound-method($expr, "Str")(); - - die X::Type.new(:operation("stringification"), :got(Str), :expected(TYPE)) - unless $str.isa("Str"); - - return $str; + return wrap(stringify($expr)); }, :qtype(TYPE), ), diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index c83778ab..afde8f37 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -180,6 +180,13 @@ sub pretty($parameterlist) { }).join(", "); } +sub stringify($object) is export { + my $s = bound-method($object, "Str")(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.isa("Str"); + return $s.value; +} + my $str-array-depth = 0; my $str-array-seen; @@ -737,7 +744,7 @@ sub bound-method($object, $name) is export { if $object.isa("Object") && $name eq "repr" { return sub repr-object() { - return bound-method($object, "Str")(); + return wrap(stringify($object)); } } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 8fd0a641..d7ea4d73 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -297,12 +297,7 @@ class _007::Runtime { return builtin(sub join($sep) { die X::Type.new(:operation, :got($sep), :expected(TYPE)) unless $sep.isa("Str"); - return wrap($obj.value.map({ - my $s = bound-method($_, "Str")(); - die X::Type.new(:operation, :got($s), :expected(TYPE)) - unless $s.isa("Str"); - $s.value; - }).join($sep.value)); + return wrap($obj.value.map(&stringify).join($sep.value)); }); } elsif $obj.isa("Dict") && $propname eq "size" { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index b80b6791..46358993 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -343,7 +343,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 bound-method($expected-ast, "Str")().value, bound-method($actual-ast, "Str")().value, $desc; + empty-diff stringify($expected-ast), stringify($actual-ast), $desc; } sub parse-error($program, $expected-error, $desc = $expected-error.^name) is export { From 71e6b62d2323c48ead76b2a79a98ba8123818134 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 07:54:56 +0200 Subject: [PATCH 70/91] abstract &reprify --- lib/_007/Backend/JavaScript.pm | 3 +-- lib/_007/Object.pm | 22 ++++++++++++---------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 3c15b594..527c2d3b 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -39,8 +39,7 @@ class _007::Backend::JavaScript { my @arguments = $expr.properties.properties.value.map: { die "Cannot handle non-literal-Str arguments just yet!" unless .isa("Q::Literal::Str"); - # XXX: should really type-check the result of the .repr() call - bound-method(.properties, "repr")().value; + reprify(.properties); }; @main.push("say({@arguments.join(", ")});"); } diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index afde8f37..fa1affda 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -187,6 +187,13 @@ sub stringify($object) is export { return $s.value; } +sub reprify($object) is export { + my $s = bound-method($object, "repr")(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.isa("Str"); + return $s.value; +} + my $str-array-depth = 0; my $str-array-seen; @@ -707,12 +714,7 @@ sub bound-method($object, $name) is export { return wrap("[...]"); } - return wrap("[" ~ $object.value.map({ - my $s = bound-method($_, "repr")(); - die X::Type.new(:operation("stringification"), :got($s), :expected(TYPE)) - unless $s.isa("Str"); - $s.value; - }).join(", ") ~ "]"); + return wrap("[" ~ $object.value.map(&reprify).join(", ") ~ "]"); }; } @@ -730,8 +732,8 @@ sub bound-method($object, $name) is export { return wrap('{' ~ $object.value.map({ my $key = .key ~~ /^ [\w+]+ % '::'$/ ?? .key - !! bound-method(wrap(.key), "repr")().value; - "{$key}: {bound-method(.value, "repr")().value}"; + !! reprify(wrap(.key)); + "{$key}: {reprify(.value)}"; }).sort.join(', ') ~ '}'); }; } @@ -777,9 +779,9 @@ sub bound-method($object, $name) is export { !($object.isa("Q::Block") && $_ eq "static-lexpad") }; if @props == 1 { - return wrap("{$object.type.name} { bound-method($object.properties{@props[0]}, "repr")().value }"); + return wrap("{$object.type.name} { reprify($object.properties{@props[0]}) }"); } - sub keyvalue($prop) { $prop ~ ": " ~ bound-method($object.properties{$prop}, "repr")().value } + sub keyvalue($prop) { $prop ~ ": " ~ reprify($object.properties{$prop}) } my $contents = @props.map(&keyvalue).join(",\n").indent(4); return wrap("{$object.type.name} \{\n$contents\n\}"); }; From 7d0b4f250374288a4f6cd6a1b2392af357cf56d5 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 08:08:25 +0200 Subject: [PATCH 71/91] abstract &boolify --- lib/_007/Builtins.pm | 12 ++---------- lib/_007/Object.pm | 19 +++++++++++-------- lib/_007/Runtime.pm | 2 +- 3 files changed, 14 insertions(+), 19 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 149285ae..2c4baca3 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -359,21 +359,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:?' => op( sub ($arg) { - my $b = bound-method($arg, "Bool")(); - die X::Type.new(:operation, :got($b), :expected(TYPE)) - unless $b.isa("Bool"); - return $b; + return wrap(boolify($arg)); }, :qtype(TYPE), ), 'prefix:!' => op( sub ($arg) { - my $b = bound-method($arg, "Bool")(); - die X::Type.new(:operation, :got($b), :expected(TYPE)) - unless $b.isa("Bool"); - return $b === TRUE - ?? FALSE - !! TRUE; + return wrap(!boolify($arg)); }, :qtype(TYPE), ), diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index fa1affda..5f50185b 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -194,6 +194,13 @@ sub reprify($object) is export { return $s.value; } +sub boolify($object) is export { + my $s = bound-method($object, "Bool")(); + die X::Type.new(:operation, :got($s), :expected(TYPE)) + unless $s.isa("Bool"); + return $s === TRUE; +} + my $str-array-depth = 0; my $str-array-seen; @@ -310,8 +317,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Statement::While") && $name eq "run" { return sub run-q-statement-while($runtime) { - # XXX: need to typecheck the result coming back from .Bool - while bound-method((my $expr = bound-method($object.properties, "eval")($runtime)), "Bool")() === TRUE { + while boolify(my $expr = bound-method($object.properties, "eval")($runtime)) { my $paramcount = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new( :type("While loop"), :$paramcount, :argcount("0 or 1")) @@ -356,8 +362,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Infix::And") && $name eq "eval" { return sub eval-q-infix-and($runtime) { my $l = bound-method($object.properties, "eval")($runtime); - # XXX: need to typecheck result of .Bool - return bound-method($l, "Bool")() === TRUE + return boolify($l) ?? bound-method($object.properties, "eval")($runtime) !! $l; }; @@ -366,8 +371,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Infix::Or") && $name eq "eval" { return sub eval-q-infix-or($runtime) { my $l = bound-method($object.properties, "eval")($runtime); - # XXX: need to typecheck result of .Bool - return bound-method($l, "Bool")() === TRUE + return boolify($l) ?? $l !! bound-method($object.properties, "eval")($runtime); }; @@ -473,8 +477,7 @@ sub bound-method($object, $name) is export { if $object.isa("Q::Statement::If") && $name eq "run" { return sub run-q-statement-if($runtime) { my $expr = bound-method($object.properties, "eval")($runtime); - # XXX: need to typecheck return value from .Bool - if bound-method($expr, "Bool")() === TRUE { + if boolify($expr) { my $paramcount = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new(:type("If statement"), :$paramcount, :argcount("0 or 1")) if $paramcount > 1; diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index d7ea4d73..5757fe40 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -377,7 +377,7 @@ class _007::Runtime { elsif $obj.isa("Array") && $propname eq "filter" { return builtin(sub filter($fn) { # XXX: Need to typecheck here if $fn is callable - my @elements = $obj.value.grep({ bound-method(internal-call($fn, self, [$_]), "Bool")() === TRUE }); + my @elements = $obj.value.grep({ boolify(internal-call($fn, self, [$_])) }); return wrap(@elements); }); } From 36d3e867f57147e23393120a6733c29c4aa2c6f6 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 08:44:33 +0200 Subject: [PATCH 72/91] Use .is-a, not .isa Turns out Perl 6 is already using the latter, and I don't want to accidentally end up in Rakudo code paths. Sure enough, needed to fix a few such bugs after the change. --- bin/count-builtins | 2 +- lib/_007/Backend/JavaScript.pm | 12 +-- lib/_007/Builtins.pm | 76 ++++++------- lib/_007/Linter.pm | 36 +++---- lib/_007/Object.pm | 192 ++++++++++++++++----------------- lib/_007/Parser/Actions.pm | 43 ++++---- lib/_007/Runtime.pm | 82 +++++++------- lib/_007/Test.pm | 30 +++--- lib/_007/Type.pm | 6 +- 9 files changed, 241 insertions(+), 238 deletions(-) diff --git a/bin/count-builtins b/bin/count-builtins index b4c5c3c3..afc14be0 100755 --- a/bin/count-builtins +++ b/bin/count-builtins @@ -23,7 +23,7 @@ for -> $file { for $file.IO.lines { if /^ "sub bound-method(" / ff /^ "}" / { if /^ " " ** 4 \S / { - if /^ \h* "if \$object.isa" / { + if /^ \h* "if \$object.is-a" / { $bound_method_count++; } elsif /^ \h* "}" / { diff --git a/lib/_007/Backend/JavaScript.pm b/lib/_007/Backend/JavaScript.pm index 527c2d3b..26d8c581 100644 --- a/lib/_007/Backend/JavaScript.pm +++ b/lib/_007/Backend/JavaScript.pm @@ -29,16 +29,16 @@ class _007::Backend::JavaScript { PROGRAM sub emit-stmt(_007::Object $stmt) { - if $stmt.isa("Q::Statement::Expr") { + if $stmt.is-a("Q::Statement::Expr") { my $expr = $stmt.properties; - when $expr.isa("Q::Postfix::Call") - && $expr.properties.isa("Q::Identifier") + when $expr.is-a("Q::Postfix::Call") + && $expr.properties.is-a("Q::Identifier") && $expr.properties.properties.value eq "say" { @builtins.push(%builtins); my @arguments = $expr.properties.properties.value.map: { die "Cannot handle non-literal-Str arguments just yet!" - unless .isa("Q::Literal::Str"); + unless .is-a("Q::Literal::Str"); reprify(.properties); }; @main.push("say({@arguments.join(", ")});"); @@ -46,11 +46,11 @@ class _007::Backend::JavaScript { die "Cannot handle this type of Q::Statement::Expr yet!"; } - elsif $stmt.isa("Q::Statement::My") { + 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.isa("Q::Literal::Int"); + unless $stmt.properties.is-a("Q::Literal::Int"); my $expr = stringify($stmt.properties.properties); @main.push("let {$name} = {$expr};"); } diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 2c4baca3..e62b13a4 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -7,13 +7,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi equal-value(_007::Object $l, _007::Object $r) { return False unless $l.type === $r.type; - if $l.isa("Int") { + if $l.is-a("Int") { return $l.value == $r.value; } - elsif $l.isa("Str") { + elsif $l.is-a("Str") { return $l.value eq $r.value; } - elsif $l.isa("Array") { + elsif $l.is-a("Array") { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { return $l === $r; } @@ -26,7 +26,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return [&&] $l.value == $r.value, |(^$l.value).map(&equal-at-index); } - elsif $l.isa("Dict") { + elsif $l.is-a("Dict") { if %*equality-seen{$l.WHICH} && %*equality-seen{$r.WHICH} { return $l === $r; } @@ -39,18 +39,18 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { return [&&] $l.value.keys.sort.perl eq $r.value.keys.sort.perl, |($l.value.keys).map(&equal-at-key); } - elsif $l.isa("NoneType") { + elsif $l.is-a("NoneType") { return True; } - elsif $l.isa("Bool") { + elsif $l.is-a("Bool") { return $l === $r; } - elsif $l.isa("Sub") { + 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.isa("Q") { + elsif $l.is-a("Q") { sub same-propvalue($prop) { equal-value($l.properties{$prop}, $r.properties{$prop}); } @@ -73,9 +73,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi less-value(_007::Object $l, _007::Object $r) { die X::Type.new(:operation, :got($_), :expected(TYPE)) unless $l.type === $r.type; - return $l.isa("Int") + return $l.is-a("Int") ?? $l.value < $r.value - !! $l.isa("Str") + !! $l.is-a("Str") ?? $l.value lt $r.value !! die "Unknown type ", $l.type.Str; } @@ -88,9 +88,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { multi more-value(_007::Object $l, _007::Object $r) { die X::Type.new(:operation, :got($_), :expected(TYPE)) unless $l.type === $r.type; - return $l.isa("Int") + return $l.is-a("Int") ?? $l.value > $r.value - !! $l.isa("Str") + !! $l.is-a("Str") ?? $l.value gt $r.value !! die "Unknown type ", $l.type.Str; } @@ -198,9 +198,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~~' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Type"); + unless $rhs.is-a("Type"); - return wrap(?$lhs.isa($rhs)); + return wrap(?$lhs.is-a($rhs)); }, :qtype(TYPE), :precedence{ equal => "infix:==" }, @@ -208,9 +208,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:!~~' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<~~>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Type"); + unless $rhs.is-a("Type"); - return wrap(!$lhs.isa($rhs)); + return wrap(!$lhs.is-a($rhs)); }, :qtype(TYPE), :precedence{ equal => "infix:==" }, @@ -220,7 +220,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:::' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<::>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Array"); + unless $rhs.is-a("Array"); return wrap([$lhs, |$rhs.value]); }, :qtype(TYPE), @@ -231,9 +231,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:+' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<+>, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Int"); + unless $lhs.is-a("Int"); die X::Type.new(:operation<+>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); return wrap($lhs.value + $rhs.value); }, :qtype(TYPE), @@ -241,9 +241,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:~' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<~>, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Str"); + unless $lhs.is-a("Str"); die X::Type.new(:operation<~>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Str"); + unless $rhs.is-a("Str"); return wrap($lhs.value ~ $rhs.value); }, :qtype(TYPE), @@ -252,9 +252,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:-' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<->, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Int"); + unless $lhs.is-a("Int"); die X::Type.new(:operation<->, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); return wrap($lhs.value - $rhs.value); }, :qtype(TYPE), @@ -264,9 +264,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:*' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<*>, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Int"); + unless $lhs.is-a("Int"); die X::Type.new(:operation<*>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); return wrap($lhs.value * $rhs.value); }, :qtype(TYPE), @@ -274,9 +274,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<%>, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Int"); + unless $lhs.is-a("Int"); die X::Type.new(:operation<%>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); die X::Numeric::DivideByZero.new(:using<%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value % $rhs.value); @@ -286,9 +286,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:%%' => op( sub ($lhs, $rhs) { die X::Type.new(:operation<%%>, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Int"); + unless $lhs.is-a("Int"); die X::Type.new(:operation<%%>, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); die X::Numeric::DivideByZero.new(:using<%%>, :numerator($lhs.value)) if $rhs.value == 0; return wrap($lhs.value %% $rhs.value); @@ -298,9 +298,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:x' => op( sub ($lhs, $rhs) { die X::Type.new(:operation, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Str"); + unless $lhs.is-a("Str"); die X::Type.new(:operation, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); return wrap($lhs.value x $rhs.value); }, :qtype(TYPE), @@ -309,9 +309,9 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'infix:xx' => op( sub ($lhs, $rhs) { die X::Type.new(:operation, :got($lhs), :expected(TYPE)) - unless $lhs.isa("Array"); + unless $lhs.is-a("Array"); die X::Type.new(:operation, :got($rhs), :expected(TYPE)) - unless $rhs.isa("Int"); + unless $rhs.is-a("Int"); return wrap(| $lhs.value xx $rhs.value); }, :qtype(TYPE), @@ -327,11 +327,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:+' => op( sub prefix-plus($expr) { - if $expr.isa("Str") { + if $expr.is-a("Str") { return wrap($expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } - elsif $expr.isa("Int") { + elsif $expr.is-a("Int") { return $expr; } die X::Type.new( @@ -343,11 +343,11 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:-' => op( sub prefix-minus($expr) { - if $expr.isa("Str") { + if $expr.is-a("Str") { return wrap(-$expr.value.Int) if $expr.value ~~ /^ '-'? \d+ $/; } - elsif $expr.isa("Int") { + elsif $expr.is-a("Int") { return wrap(-$expr.value); } die X::Type.new( @@ -372,7 +372,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { 'prefix:^' => op( sub ($n) { die X::Type.new(:operation<^>, :got($n), :expected(TYPE)) - unless $n.isa("Int"); + unless $n.is-a("Int"); return wrap([(^$n.value).map(&wrap)]); }, :qtype(TYPE), diff --git a/lib/_007/Linter.pm b/lib/_007/Linter.pm index 22feebf9..0dda1102 100644 --- a/lib/_007/Linter.pm +++ b/lib/_007/Linter.pm @@ -59,32 +59,32 @@ class _007::Linter { } sub traverse(_007::Object $node) { - if $node.isa("Q::Statement::Block") -> $stblock { + if $node.is-a("Q::Statement::Block") -> $stblock { traverse($stblock.properties); } - elsif $node.isa("Q::Block") -> $block { + elsif $node.is-a("Q::Block") -> $block { @blocks.push: $block; traverse($block.properties); traverse($block.properties); @blocks.pop; } - elsif $node.isa("Q::StatementList") -> $statementlist { + elsif $node.is-a("Q::StatementList") -> $statementlist { for $statementlist.properties.value -> $stmt { traverse($stmt); } } - elsif $node.isa("Q::Statement::Sub") -> $sub { + elsif $node.is-a("Q::Statement::Sub") -> $sub { my $name = $sub.properties.properties.value; %declared{"{@blocks[*-1].id}|$name"} = L::SubNotUsed; } - elsif $node.isa("Q::Statement::Expr") -> $stexpr { + elsif $node.is-a("Q::Statement::Expr") -> $stexpr { traverse($stexpr.properties); } - elsif $node.isa("Q::Postfix::Call") -> $call { + elsif $node.is-a("Q::Postfix::Call") -> $call { traverse($call.properties); traverse($call.properties); } - elsif $node.isa("Q::Identifier") -> $identifier { + 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"; @@ -95,49 +95,49 @@ class _007::Linter { %readbeforeassigned{$ref} = True; } } - elsif $node.isa("Q::ArgumentList") -> $argumentlist { + elsif $node.is-a("Q::ArgumentList") -> $argumentlist { for $argumentlist.properties.value -> $expr { traverse($expr); } } - elsif $node.isa("Q::Statement::For") -> $for { + elsif $node.is-a("Q::Statement::For") -> $for { traverse($for.properties); traverse($for.properties); } - elsif $node.isa("Q::Statement::My") -> $my { + 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.isa("Q::Identifier") && $my.properties.properties.value eq $name { + if $my.properties.is-a("Q::Identifier") && $my.properties.properties.value eq $name { @complaints.push: L::RedundantAssignment.new(:$name); %readbeforeassigned{$ref} :delete; } } } - elsif $node.isa("Q::Infix::Assignment") -> $infix { + elsif $node.is-a("Q::Infix::Assignment") -> $infix { traverse($infix.properties); die "LHS was not an identifier" - unless $infix.properties.isa("Q::Identifier"); + unless $infix.properties.is-a("Q::Identifier"); my $name = $infix.properties.properties.value; - if $infix.properties.isa("Q::Identifier") && $infix.properties.properties.value eq $name { + if $infix.properties.is-a("Q::Identifier") && $infix.properties.properties.value eq $name { @complaints.push: L::RedundantAssignment.new(:$name); } %assigned{ref $name} = True; } - elsif $node.isa("Q::Infix::Addition") -> $infix { + elsif $node.is-a("Q::Infix::Addition") -> $infix { traverse($infix.properties); traverse($infix.properties); } - elsif $node.isa("Q::ParameterList") -> $parameterlist { + elsif $node.is-a("Q::ParameterList") -> $parameterlist { # nothing } - elsif $node.isa("Q::Literal") -> $literal { + elsif $node.is-a("Q::Literal") -> $literal { # nothing } - elsif $node.isa("Q::Term") -> $term { + elsif $node.is-a("Q::Term") -> $term { # nothing } else { diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 5f50185b..c6506055 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -80,18 +80,18 @@ class _007::Object { has $.id = unique-id; has %.properties; - multi method isa(Str $typename) { + multi method is-a(Str $typename) { die "Asked to typecheck against $typename but no such type is declared" unless TYPE{$typename} :exists; - return self.isa(TYPE{$typename}); + return self.is-a(TYPE{$typename}); } - multi method isa(_007::Type $type) { + 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.isa("Q::StatementList") -> $statementlist { + # if $ast.is-a("Q::StatementList") -> $statementlist { # # ... # } @@ -183,21 +183,21 @@ sub pretty($parameterlist) { sub stringify($object) is export { my $s = bound-method($object, "Str")(); die X::Type.new(:operation, :got($s), :expected(TYPE)) - unless $s.isa("Str"); + unless $s.is-a("Str"); return $s.value; } sub reprify($object) is export { my $s = bound-method($object, "repr")(); die X::Type.new(:operation, :got($s), :expected(TYPE)) - unless $s.isa("Str"); + unless $s.is-a("Str"); return $s.value; } sub boolify($object) is export { my $s = bound-method($object, "Bool")(); die X::Type.new(:operation, :got($s), :expected(TYPE)) - unless $s.isa("Bool"); + unless $s.is-a("Bool"); return $s === TRUE; } @@ -212,7 +212,7 @@ my $str-dict-seen; # 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) is export { - if $object.isa("Q::Statement::Block") && $name eq "run" { + if $object.is-a("Q::Statement::Block") && $name eq "run" { return sub run-q-statement-block($runtime) { $runtime.enter( $runtime.current-frame, @@ -223,42 +223,42 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::StatementList") && $name eq "run" { + if $object.is-a("Q::StatementList") && $name eq "run" { return sub run-q-statementlist($runtime) { for $object.properties.value -> $statement { my $value = bound-method($statement, "run")($runtime); - LAST if $statement.isa("Q::Statement::Expr") { + LAST if $statement.is-a("Q::Statement::Expr") { return $value; } } }; } - if $object.isa("Q::Statement::Expr") && $name eq "run" { + if $object.is-a("Q::Statement::Expr") && $name eq "run" { return sub run-q-statement-expr($runtime) { return bound-method($object.properties, "eval")($runtime); }; } - if $object.isa("Q::Identifier") && $name eq "eval" { + if $object.is-a("Q::Identifier") && $name eq "eval" { return sub eval-q-identifier($runtime) { return $runtime.get-var($object.properties.value, $object.properties); }; } - if $object.isa("Q::Literal::Int") && $name eq "eval" { + if $object.is-a("Q::Literal::Int") && $name eq "eval" { return sub eval-q-literal-int($runtime) { return $object.properties; }; } - if $object.isa("Q::Literal::Str") && $name eq "eval" { + if $object.is-a("Q::Literal::Str") && $name eq "eval" { return sub eval-q-literal-str($runtime) { return $object.properties; }; } - if $object.isa("Q::Term::Dict") && $name eq "eval" { + if $object.is-a("Q::Term::Dict") && $name eq "eval" { return sub eval-q-term-dict($runtime) { return wrap(hash($object.properties.properties.value.map({ .properties.value => bound-method(.properties, "eval")($runtime); @@ -266,31 +266,31 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Identifier") && $name eq "put-value" { + if $object.is-a("Q::Identifier") && $name eq "put-value" { return sub put-value-q-identifier($value, $runtime) { $runtime.put-var($object, $value); }; } - if $object.isa("Q::Statement::Class") && $name eq "run" { + if $object.is-a("Q::Statement::Class") && $name eq "run" { return sub run-q-statement-class($runtime) { # a class block does not run at runtime }; } - if $object.isa("Q::Statement::Sub") && $name eq "run" { + if $object.is-a("Q::Statement::Sub") && $name eq "run" { return sub run-q-statement-sub($runtime) { # a sub declaration does not run at runtime }; } - if $object.isa("Q::Statement::Macro") && $name eq "run" { + if $object.is-a("Q::Statement::Macro") && $name eq "run" { return sub run-q-statement-macro($runtime) { # a macro declaration does not run at runtime }; } - if $object.isa("Q::Statement::For") && $name eq "run" { + if $object.is-a("Q::Statement::For") && $name eq "run" { return sub run-q-statement-for($runtime) { my $count = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new( @@ -299,7 +299,7 @@ sub bound-method($object, $name) is export { my $array = bound-method($object.properties, "eval")($runtime); die X::Type.new(:operation("for loop"), :got($array), :expected(TYPE)) - unless $array.isa("Array"); + unless $array.is-a("Array"); for $array.value -> $arg { $runtime.enter( @@ -315,7 +315,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Statement::While") && $name eq "run" { + if $object.is-a("Q::Statement::While") && $name eq "run" { return sub run-q-statement-while($runtime) { while boolify(my $expr = bound-method($object.properties, "eval")($runtime)) { my $paramcount = $object.properties.properties.properties.value.elems; @@ -335,7 +335,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Term::Object") && $name eq "eval" { + if $object.is-a("Q::Term::Object") && $name eq "eval" { return sub eval-q-term-object($runtime) { my $type = $runtime.get-var( $object.properties.properties.value, @@ -351,7 +351,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Infix::Assignment") && $name eq "eval" { + if $object.is-a("Q::Infix::Assignment") && $name eq "eval" { return sub eval-q-infix-assignment($runtime) { my $value = bound-method($object.properties, "eval")($runtime); bound-method($object.properties, "put-value")($value, $runtime); @@ -359,7 +359,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Infix::And") && $name eq "eval" { + if $object.is-a("Q::Infix::And") && $name eq "eval" { return sub eval-q-infix-and($runtime) { my $l = bound-method($object.properties, "eval")($runtime); return boolify($l) @@ -368,7 +368,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Infix::Or") && $name eq "eval" { + if $object.is-a("Q::Infix::Or") && $name eq "eval" { return sub eval-q-infix-or($runtime) { my $l = bound-method($object.properties, "eval")($runtime); return boolify($l) @@ -377,7 +377,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Infix::DefinedOr") && $name eq "eval" { + if $object.is-a("Q::Infix::DefinedOr") && $name eq "eval" { return sub eval-q-infix-definedor($runtime) { my $l = bound-method($object.properties, "eval")($runtime); return $l !=== NONE @@ -386,7 +386,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Infix") && $name eq "eval" { + if $object.is-a("Q::Infix") && $name eq "eval" { return sub eval-q-infix($runtime) { my $l = bound-method($object.properties, "eval")($runtime); my $r = bound-method($object.properties, "eval")($runtime); @@ -395,7 +395,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Prefix") && $name eq "eval" { + if $object.is-a("Q::Prefix") && $name eq "eval" { return sub eval-q-prefix($runtime) { my $e = bound-method($object.properties, "eval")($runtime); my $c = bound-method($object.properties, "eval")($runtime); @@ -403,7 +403,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Postfix::Property") && $name eq "eval" { + if $object.is-a("Q::Postfix::Property") && $name eq "eval" { return sub eval-q-postfix-property($runtime) { my $obj = bound-method($object.properties, "eval")($runtime); my $propname = $object.properties.properties.value; @@ -411,23 +411,23 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Postfix::Index") && $name eq "eval" { + if $object.is-a("Q::Postfix::Index") && $name eq "eval" { return sub eval-q-postfix-index($runtime) { given bound-method($object.properties, "eval")($runtime) { - if .isa("Array") { + if .is-a("Array") { my $index = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonInteger.new - unless $index.isa("Int"); + 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 .isa("Dict") { + if .is-a("Dict") { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new - unless $property.isa("Str"); + unless $property.is-a("Str"); my $key = $property.value; return .value{$key}; } @@ -436,13 +436,13 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Postfix::Call") && $name eq "eval" { + if $object.is-a("Q::Postfix::Call") && $name eq "eval" { return sub eval-q-postfix-call($runtime) { my $c = bound-method($object.properties, "eval")($runtime); die "macro is called at runtime" - if $c.isa("Macro"); + if $c.is-a("Macro"); die "Trying to invoke a {$c.type.name}" # XXX: make this into an X:: - unless $c.isa("Sub"); + unless $c.is-a("Sub"); my @arguments = $object.properties.properties.value.map({ bound-method($_, "eval")($runtime) }); @@ -450,7 +450,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Postfix") && $name eq "eval" { + if $object.is-a("Q::Postfix") && $name eq "eval" { return sub eval-q-postfix($runtime) { my $e = bound-method($object.properties, "eval")($runtime); my $c = bound-method($object.properties, "eval")($runtime); @@ -458,7 +458,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Statement::My") && $name eq "run" { + if $object.is-a("Q::Statement::My") && $name eq "run" { return sub run-q-statement-my($runtime) { return if $object.properties === NONE; @@ -468,13 +468,13 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Statement::Constant") && $name eq "run" { + if $object.is-a("Q::Statement::Constant") && $name eq "run" { return sub run-q-statement-constant($runtime) { # value has already been assigned }; } - if $object.isa("Q::Statement::If") && $name eq "run" { + if $object.is-a("Q::Statement::If") && $name eq "run" { return sub run-q-statement-if($runtime) { my $expr = bound-method($object.properties, "eval")($runtime); if boolify($expr) { @@ -495,10 +495,10 @@ sub bound-method($object, $name) is export { } else { given $object.properties { - when .isa("Q::Statement::If") { + when .is-a("Q::Statement::If") { bound-method($object.properties, "run")($runtime) } - when .isa("Q::Block") { + when .is-a("Q::Block") { $runtime.enter( $runtime.current-frame, $object.properties.properties, @@ -511,7 +511,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Statement::Return") && $name eq "run" { + if $object.is-a("Q::Statement::Return") && $name eq "run" { return sub run-q-statement-return($runtime) { my $value = $object.properties === NONE ?? $object.properties @@ -521,45 +521,45 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Term::Quasi") && $name eq "eval" { + if $object.is-a("Q::Term::Quasi") && $name eq "eval" { return sub eval-q-term-quasi($runtime) { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing.isa("Array"); + if $thing.is-a("Array"); sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing.isa("Dict"); + if $thing.is-a("Dict"); return $thing if $thing ~~ _007::Type; return $thing - if $thing.isa("Int") || $thing.isa("Str"); + if $thing.is-a("Int") || $thing.is-a("Str"); return $thing - if $thing.isa("Sub"); + if $thing.is-a("Sub"); return create($thing.type, :name($thing.properties), :frame($runtime.current-frame)) - if $thing.isa("Q::Identifier"); + if $thing.is-a("Q::Identifier"); - if $thing.isa("Q::Unquote::Prefix") { + 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.isa("Q::Prefix"); + unless $prefix.is-a("Q::Prefix"); return create($prefix.type, :identifier($prefix.properties), :operand($thing.properties)); } - elsif $thing.isa("Q::Unquote::Infix") { + 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.isa("Q::Infix"); + unless $infix.is-a("Q::Infix"); return create($infix.type, :identifier($infix.properties), :lhs($thing.properties), :rhs($thing.properties)); } - if $thing.isa("Q::Unquote") { + 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.isa("Q"); + unless $ast.is-a("Q"); return $ast; } @@ -568,14 +568,14 @@ sub bound-method($object, $name) is export { create($thing.type, |%properties); } - if $object.properties.value eq "Q::Unquote" && $object.properties.isa("Q::Unquote") { + if $object.properties.value eq "Q::Unquote" && $object.properties.is-a("Q::Unquote") { return $object.properties; } return interpolate($object.properties); }; } - if $object.isa("Q::Term::Sub") && $name eq "eval" { + if $object.is-a("Q::Term::Sub") && $name eq "eval" { return sub eval-q-term-sub($runtime) { my $name = $object.properties === NONE ?? wrap("") @@ -588,31 +588,31 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Term::Array") && $name eq "eval" { + if $object.is-a("Q::Term::Array") && $name eq "eval" { return sub eval-q-term-array($runtime) { return wrap($object.properties.value.map({ bound-method($_, "eval")($runtime) })); }; } - if $object.isa("Q::Statement::Throw") && $name eq "run" { + if $object.is-a("Q::Statement::Throw") && $name eq "run" { return sub eval-q-statement-throw($runtime) { 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.isa("Exception"); + unless $value.is-a("Exception"); die X::_007::RuntimeException.new(:msg($value.properties.value)); }; } - if $object.isa("Q::Postfix::Index") && $name eq "put-value" { + if $object.is-a("Q::Postfix::Index") && $name eq "put-value" { return sub put-value-q-postfix-index($value, $runtime) { given bound-method($object.properties, "eval")($runtime) { - if .isa("Array") { + if .is-a("Array") { my $index = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonInteger.new - unless $index.isa("Int"); + 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([])) @@ -620,10 +620,10 @@ sub bound-method($object, $name) is export { .value[$index.value] = $value; return; } - if .isa("Dict") || .isa("Q") { + if .is-a("Dict") || .is-a("Q") { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new - unless $property.isa("Str"); + unless $property.is-a("Str"); my $propname = $property.value; $runtime.put-property($_, $propname, $value); return; @@ -633,10 +633,10 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Postfix::Property") && $name eq "put-value" { + if $object.is-a("Q::Postfix::Property") && $name eq "put-value" { return sub put-value-q-postfix-property($value, $runtime) { given bound-method($object.properties, "eval")($runtime) { - if .isa("Dict") || .isa("Q") { + if .is-a("Dict") || .is-a("Q") { my $propname = $object.properties.properties.value; $runtime.put-property($_, $propname, $value); return; @@ -646,67 +646,67 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q::Statement::BEGIN") && $name eq "run" { + if $object.is-a("Q::Statement::BEGIN") && $name eq "run" { return sub run-q-statement-begin($runtime) { # a BEGIN block does not run at runtime }; } - if $object.isa("Q::Term::Regex") && $name eq "eval" { + if $object.is-a("Q::Term::Regex") && $name eq "eval" { return sub eval-q-term-regex($runtime) { create(TYPE, :contents($object.properties)); }; } - if $object.isa("Q::Literal::None") && $name eq "eval" { + if $object.is-a("Q::Literal::None") && $name eq "eval" { return sub eval-q-literal-none($runtime) { NONE; }; } - if $object.isa("Q::Literal::Bool") && $name eq "eval" { + if $object.is-a("Q::Literal::Bool") && $name eq "eval" { return sub eval-q-literal-bool($runtime) { $object.properties; }; } - if $object.isa("Q::Expr::StatementListAdapter") && $name eq "eval" { + if $object.is-a("Q::Expr::StatementListAdapter") && $name eq "eval" { return sub eval-q-expr-statementlistadapter($runtime) { return bound-method($object.properties, "run")($runtime); }; } - if $object.isa("Str") && $name eq "Str" { + if $object.is-a("Str") && $name eq "Str" { return sub str-str() { return $object; } } - if $object.isa("Int") && $name eq "Str" { + if $object.is-a("Int") && $name eq "Str" { return sub str-int() { return wrap(~$object.value); } } - if $object.isa("Bool") && $name eq "Str" { + if $object.is-a("Bool") && $name eq "Str" { return sub str-bool() { return wrap($object.name); } } - if $object.isa("NoneType") && $name eq "Str" { + if $object.is-a("NoneType") && $name eq "Str" { return sub str-nonetype() { return wrap($object.name); } } - if $object.isa("Type") && $name eq "Str" { + if $object.is-a("Type") && $name eq "Str" { return sub str-type() { return wrap(""); } } - if $object.isa("Array") && $name eq "Str" { + if $object.is-a("Array") && $name eq "Str" { return sub str-array() { if $str-array-depth++ == 0 { $str-array-seen = {}; @@ -721,7 +721,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Dict") && $name eq "Str" { + if $object.is-a("Dict") && $name eq "Str" { return sub str-dict() { if $str-dict-depth++ == 0 { $str-dict-seen = {}; @@ -741,19 +741,19 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Str") && $name eq "repr" { + 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.isa("Object") && $name eq "repr" { + if $object.is-a("Object") && $name eq "repr" { return sub repr-object() { return wrap(stringify($object)); } } - if $object.isa("Macro") && $name eq "Str" { + if $object.is-a("Macro") && $name eq "Str" { return sub str-sub() { return wrap( sprintf "", @@ -763,7 +763,7 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Sub") && $name eq "Str" { + if $object.is-a("Sub") && $name eq "Str" { return sub str-sub() { return wrap( sprintf "", @@ -773,13 +773,13 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Q") && $name eq "Str" { + if $object.is-a("Q") && $name eq "Str" { return sub str-q() { my @props = $object.type.type-chain.reverse.map({ .fields }).flat; # XXX: thuggish way to hide things that weren't listed in `attributes` before @props.=grep: { - !($object.isa("Q::Identifier") && $_ eq "frame") && - !($object.isa("Q::Block") && $_ eq "static-lexpad") + !($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]}) }"); @@ -790,43 +790,43 @@ sub bound-method($object, $name) is export { }; } - if $object.isa("Bool") && $name eq "Bool" { + if $object.is-a("Bool") && $name eq "Bool" { return sub bool-bool() { return $object; }; } - if $object.isa("NoneType") && $name eq "Bool" { + if $object.is-a("NoneType") && $name eq "Bool" { return sub bool-nonetype() { return FALSE; }; } - if $object.isa("Int") && $name eq "Bool" { + if $object.is-a("Int") && $name eq "Bool" { return sub bool-int() { return wrap($object.value != 0); }; } - if $object.isa("Str") && $name eq "Bool" { + if $object.is-a("Str") && $name eq "Bool" { return sub bool-str() { return wrap($object.value ne ""); }; } - if $object.isa("Array") && $name eq "Bool" { + if $object.is-a("Array") && $name eq "Bool" { return sub bool-array() { return wrap($object.value.elems > 0); }; } - if $object.isa("Dict") && $name eq "Bool" { + if $object.is-a("Dict") && $name eq "Bool" { return sub bool-dict() { return wrap($object.value.keys > 0); }; } - if $object.isa("Object") && $name eq "Bool" { + if $object.is-a("Object") && $name eq "Bool" { return sub bool-object() { return TRUE; }; @@ -872,7 +872,7 @@ sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { sub internal-call(_007::Object $sub, $runtime, @arguments) is export { die "Tried to call a {$sub.^name}, expected a Sub" - unless $sub.isa("Sub"); # XXX: should do subtyping check + 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"; diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 6bcd8a33..602b9e4a 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -103,7 +103,7 @@ class _007::Parser::Actions { # 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.isa("Q::Block") { + 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))), @@ -138,7 +138,7 @@ class _007::Parser::Actions { 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.isa("Q::Identifier"); + unless $identifier.is-a("Q::Identifier"); sub check-if-op(Str $s) { die "Unknown thing in '$name' trait" unless $s ~~ /^ < pre in post > 'fix:' /; @@ -151,7 +151,7 @@ class _007::Parser::Actions { elsif $name eq "assoc" { my $string = $trait.ast; die "The associativity must be a string" - unless $string.isa("Q::Literal::Str"); + 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"; @@ -293,15 +293,16 @@ class _007::Parser::Actions { } sub is-macro($q, $qtype, $identifier) { - $q.isa($qtype) - && $identifier.isa("Q::Identifier") - && $*runtime.maybe-get-var($identifier.properties.value).isa("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 = internal-call($macro, $*runtime, @arguments); - if $expansion.isa("Q::Statement::My") { + if $expansion.is-a("Q::Statement::My") { _007::Parser::Syntax::declare(TYPE, $expansion.properties.properties.value); } @@ -309,7 +310,7 @@ class _007::Parser::Actions { return &unexpanded-callback(); } else { - if $expansion.isa("Q::Statement") { + if $expansion.is-a("Q::Statement") { my $statements = wrap([$expansion]); $expansion = create(TYPE, :$statements); } @@ -318,11 +319,11 @@ class _007::Parser::Actions { $expansion = create(TYPE, :$statements); } - if $expansion.isa("Q::StatementList") { + if $expansion.is-a("Q::StatementList") { $expansion = create(TYPE, :statementlist($expansion)); } - if $expansion.isa("Q::Block") { + if $expansion.is-a("Q::Block") { $expansion = create(TYPE, :statementlist($expansion.properties)); } @@ -363,7 +364,7 @@ class _007::Parser::Actions { my $infix = @opstack.pop; my $t1 = @termstack.pop; - if $infix.isa("Q::Unquote") { + if $infix.is-a("Q::Unquote") { @termstack.push(create(TYPE, :qtype($infix.properties), :expr($infix.properties), @@ -380,7 +381,7 @@ class _007::Parser::Actions { else { @termstack.push(create($infix.type, :lhs($t1), :rhs($t2), :identifier($infix.properties))); - if $infix.isa("Q::Infix::Assignment") && $t1.isa("Q::Identifier") { + if $infix.is-a("Q::Infix::Assignment") && $t1.is-a("Q::Identifier") { my $frame = $*runtime.current-frame; my $symbol = $t1.properties.value; die X::Undeclared.new(:$symbol) @@ -442,7 +443,7 @@ class _007::Parser::Actions { sub handle-prefix($/) { my $prefix = @prefixes.shift.ast; - if $prefix.isa("Q::Unquote") { + if $prefix.is-a("Q::Unquote") { make create(TYPE, :qtype($prefix.properties), :expr($prefix.properties), @@ -468,13 +469,13 @@ class _007::Parser::Actions { create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); }); } - elsif $postfix.isa("Q::Postfix::Index") { + elsif $postfix.is-a("Q::Postfix::Index") { make create($postfix.type, :$identifier, :operand($/.ast), :index($postfix.properties)); } - elsif $postfix.isa("Q::Postfix::Call") { + elsif $postfix.is-a("Q::Postfix::Call") { make create($postfix.type, :$identifier, :operand($/.ast), :argumentlist($postfix.properties)); } - elsif $postfix.isa("Q::Postfix::Property") { + elsif $postfix.is-a("Q::Postfix::Property") { make create($postfix.type, :$identifier, :operand($/.ast), :property($postfix.properties)); } else { @@ -575,10 +576,12 @@ class _007::Parser::Actions { 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.isa("Macro"); + if $value.is-a("Macro"); die X::Undeclared.new(:symbol($name)) - unless $value.isa("Sub"); + unless $value.is-a("Sub"); }; } } @@ -613,9 +616,9 @@ class _007::Parser::Actions { return; } elsif $qtype.value ne "Q::Block" - && $block.ast.isa("Q::Block") + && $block.ast.is-a("Q::Block") && $block.ast.properties.properties.value.elems == 1 - && $block.ast.properties.properties.value[0].isa("Q::Statement::Expr") { + && $block.ast.properties.properties.value[0].is-a("Q::Statement::Expr") { my $contents = $block.ast.properties.properties.value[0].properties; make create(TYPE, :$contents, :$qtype); diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index 5757fe40..b780b9eb 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -59,7 +59,7 @@ class _007::Runtime { self.declare-var($identifier, $value); } for $statementlist.properties.value.kv -> $i, $_ { - if .isa("Q::Statement::Sub") { + if .is-a("Q::Statement::Sub") { my $name = .properties.properties; my $parameterlist = .properties.properties; my $statementlist = .properties.properties; @@ -183,21 +183,21 @@ class _007::Runtime { return wrap-fn(&fn, $name, $parameterlist, $statementlist); } - if $obj.isa("Q") { + if $obj.is-a("Q") { if $propname eq "detach" { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) - if $thing.isa("Array"); + if $thing.is-a("Array"); sub interpolate-entry($_) { .key => interpolate(.value) } return wrap(hash($thing.value.map(&interpolate-entry))) - if $thing.isa("Dict"); + if $thing.is-a("Dict"); return create($thing.type, :name($thing.properties), :frame(NONE)) - if $thing.isa("Q::Identifier"); + if $thing.is-a("Q::Identifier"); return $thing - if $thing.isa("Q::Unquote"); + if $thing.is-a("Q::Unquote"); my %properties = $thing.type.type-chain.reverse.map({ .fields }).flat.map: -> $fieldname { $fieldname => interpolate($thing.properties{$fieldname}) @@ -224,52 +224,52 @@ class _007::Runtime { return $obj.properties{$propname}; } - elsif $obj.isa("Int") && $propname eq "abs" { + elsif $obj.is-a("Int") && $propname eq "abs" { return builtin(sub abs() { return wrap($obj.value.abs); }); } - elsif $obj.isa("Int") && $propname eq "chr" { + elsif $obj.is-a("Int") && $propname eq "chr" { return builtin(sub chr() { return wrap($obj.value.chr); }); } - elsif $obj.isa("Str") && $propname eq "ord" { + elsif $obj.is-a("Str") && $propname eq "ord" { return builtin(sub ord() { return wrap($obj.value.ord); }); } - elsif $obj.isa("Str") && $propname eq "chars" { + elsif $obj.is-a("Str") && $propname eq "chars" { return builtin(sub chars() { return wrap($obj.value.chars); }); } - elsif $obj.isa("Str") && $propname eq "uc" { + elsif $obj.is-a("Str") && $propname eq "uc" { return builtin(sub uc() { return wrap($obj.value.uc); }); } - elsif $obj.isa("Str") && $propname eq "lc" { + elsif $obj.is-a("Str") && $propname eq "lc" { return builtin(sub lc() { return wrap($obj.value.lc); }); } - elsif $obj.isa("Str") && $propname eq "trim" { + elsif $obj.is-a("Str") && $propname eq "trim" { return builtin(sub trim() { return wrap($obj.value.trim); }); } - elsif $obj.isa("Array") && $propname eq "size" { + elsif $obj.is-a("Array") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj.isa("Array") && $propname eq "reverse" { + elsif $obj.is-a("Array") && $propname eq "reverse" { return builtin(sub reverse() { return wrap($obj.value.reverse); }); } - elsif $obj.isa("Array") && $propname eq "sort" { + elsif $obj.is-a("Array") && $propname eq "sort" { return builtin(sub sort() { # XXX: this method needs to be seriously reconsidered once comparison methods can be defined on # custom objects @@ -281,70 +281,70 @@ class _007::Runtime { }).sort().map(&wrap)); }); } - elsif $obj.isa("Array") && $propname eq "shuffle" { + elsif $obj.is-a("Array") && $propname eq "shuffle" { return builtin(sub shuffle() { return wrap($obj.value.pick(*)); }); } - elsif $obj.isa("Array") && $propname eq "concat" { + elsif $obj.is-a("Array") && $propname eq "concat" { return builtin(sub concat($array) { die X::Type.new(:operation, :got($array), :expected(TYPE)) - unless $array.isa("Array"); + unless $array.is-a("Array"); return wrap([|$obj.value, |$array.value]); }); } - elsif $obj.isa("Array") && $propname eq "join" { + elsif $obj.is-a("Array") && $propname eq "join" { return builtin(sub join($sep) { die X::Type.new(:operation, :got($sep), :expected(TYPE)) - unless $sep.isa("Str"); + unless $sep.is-a("Str"); return wrap($obj.value.map(&stringify).join($sep.value)); }); } - elsif $obj.isa("Dict") && $propname eq "size" { + elsif $obj.is-a("Dict") && $propname eq "size" { return builtin(sub size() { return wrap($obj.value.elems); }); } - elsif $obj.isa("Str") && $propname eq "split" { + elsif $obj.is-a("Str") && $propname eq "split" { return builtin(sub split($sep) { my @elements = $obj.value.split($sep.value).map(&wrap); return wrap(@elements); }); } - elsif $obj.isa("Str") && $propname eq "index" { + elsif $obj.is-a("Str") && $propname eq "index" { return builtin(sub index($substr) { return wrap($obj.value.index($substr.value) // -1); }); } - elsif $obj.isa("Str") && $propname eq "substr" { + elsif $obj.is-a("Str") && $propname eq "substr" { return builtin(sub substr($pos, $chars) { return wrap($obj.value.substr( $pos.value, $chars.value)); }); } - elsif $obj.isa("Str") && $propname eq "contains" { + elsif $obj.is-a("Str") && $propname eq "contains" { return builtin(sub contains($substr) { die X::Type.new(:operation, :got($substr), :expected(TYPE)) - unless $substr.isa("Str"); + unless $substr.is-a("Str"); return wrap($obj.value.contains($substr.value)); }); } - elsif $obj.isa("Str") && $propname eq "prefix" { + elsif $obj.is-a("Str") && $propname eq "prefix" { return builtin(sub prefix($pos) { return wrap($obj.value.substr( 0, $pos.value)); }); } - elsif $obj.isa("Str") && $propname eq "suffix" { + elsif $obj.is-a("Str") && $propname eq "suffix" { return builtin(sub suffix($pos) { return wrap($obj.value.substr( $pos.value)); }); } - elsif $obj.isa("Str") && $propname eq "charat" { + elsif $obj.is-a("Str") && $propname eq "charat" { return builtin(sub charat($pos) { my $s = $obj.value; @@ -354,61 +354,61 @@ class _007::Runtime { return wrap($s.substr($pos.value, 1)); }); } - elsif $obj.isa("Regex") && $propname eq "fullmatch" { + elsif $obj.is-a("Regex") && $propname eq "fullmatch" { return builtin(sub fullmatch($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str.isa("Str"); + unless $str.is-a("Str"); return wrap($regex-string eq $str.value); }); } - elsif $obj.isa("Regex") && $propname eq "search" { + elsif $obj.is-a("Regex") && $propname eq "search" { return builtin(sub search($str) { my $regex-string = $obj.properties.value; die X::Regex::InvalidMatchType.new - unless $str.isa("Str"); + unless $str.is-a("Str"); return wrap($str.value.contains($regex-string)); }); } - elsif $obj.isa("Array") && $propname eq "filter" { + elsif $obj.is-a("Array") && $propname eq "filter" { return builtin(sub filter($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.grep({ boolify(internal-call($fn, self, [$_])) }); return wrap(@elements); }); } - elsif $obj.isa("Array") && $propname eq "map" { + elsif $obj.is-a("Array") && $propname eq "map" { return builtin(sub map($fn) { # XXX: Need to typecheck here if $fn is callable my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); return wrap(@elements); }); } - elsif $obj.isa("Array") && $propname eq "push" { + elsif $obj.is-a("Array") && $propname eq "push" { return builtin(sub push($newelem) { $obj.value.push($newelem); return NONE; }); } - elsif $obj.isa("Array") && $propname eq "pop" { + elsif $obj.is-a("Array") && $propname eq "pop" { return builtin(sub pop() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.pop(); }); } - elsif $obj.isa("Array") && $propname eq "shift" { + elsif $obj.is-a("Array") && $propname eq "shift" { return builtin(sub shift() { die X::Cannot::Empty.new(:action, :what($obj.^name)) if $obj.value.elems == 0; return $obj.value.shift(); }); } - elsif $obj.isa("Array") && $propname eq "unshift" { + elsif $obj.is-a("Array") && $propname eq "unshift" { return builtin(sub unshift($newelem) { $obj.value.unshift($newelem); return NONE; @@ -479,7 +479,7 @@ class _007::Runtime { } method put-property($obj, Str $propname, $newvalue) { - if !$obj.isa("Dict") { + if !$obj.is-a("Dict") { die "We don't handle assigning to non-Dict types yet"; } else { diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 46358993..6c4769d5 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -190,12 +190,12 @@ sub check(_007::Object $ast, $runtime) is export { my %*assigned; sub handle($ast) { - if $ast.isa("Q::StatementList") -> $statementlist { + if $ast.is-a("Q::StatementList") -> $statementlist { for $statementlist.properties.value -> $statement { handle($statement); } } - elsif $ast.isa("Q::Statement::My") -> $my { + elsif $ast.is-a("Q::Statement::My") -> $my { my $symbol = $my.properties.properties.value; my $block = $runtime.current-frame(); die X::Redeclaration.new(:$symbol) @@ -208,7 +208,7 @@ sub check(_007::Object $ast, $runtime) is export { handle($my.properties); } } - elsif $ast.isa("Q::Statement::Constant") -> $constant { + elsif $ast.is-a("Q::Statement::Constant") -> $constant { my $symbol = $constant.properties.properties.value; my $block = $runtime.current-frame(); die X::Redeclaration.new(:$symbol) @@ -219,7 +219,7 @@ sub check(_007::Object $ast, $runtime) is export { handle($constant.expr); } - elsif $ast.isa("Q::Statement::Block") -> $block { + elsif $ast.is-a("Q::Statement::Block") -> $block { $runtime.enter( $runtime.current-frame, $block.properties.properties, @@ -228,12 +228,12 @@ sub check(_007::Object $ast, $runtime) is export { $block.properties.properties = $runtime.current-frame.value; $runtime.leave(); } - elsif $ast.isa("Q::ParameterList") || $ast.isa("Q::Statement::Return") || $ast.isa("Q::Statement::Expr") - || $ast.isa("Q::Statement::BEGIN") || $ast.isa("Q::Literal") || $ast.isa("Q::Term") - || $ast.isa("Q::Postfix") { + 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 } - elsif $ast.isa("Q::Statement::Sub") -> $sub { + elsif $ast.is-a("Q::Statement::Sub") -> $sub { my $outer-frame = $runtime.current-frame; my $name = $sub.properties.properties; my $val = create(TYPE, @@ -249,7 +249,7 @@ sub check(_007::Object $ast, $runtime) is export { $runtime.declare-var($sub.properties, $val); } - elsif $ast.isa("Q::Statement::Macro") -> $macro { + elsif $ast.is-a("Q::Statement::Macro") -> $macro { my $outer-frame = $runtime.current-frame; my $name = $macro.properties.properties; my $val = create(TYPE, @@ -265,16 +265,16 @@ sub check(_007::Object $ast, $runtime) is export { $runtime.declare-var($macro.properties, $val); } - elsif $ast.isa("Q::Statement::If") -> $if { + elsif $ast.is-a("Q::Statement::If") -> $if { handle($if.properties); } - elsif $ast.isa("Q::Statement::For") -> $for { + elsif $ast.is-a("Q::Statement::For") -> $for { handle($for.properties); } - elsif $ast.isa("Q::Statement::While") -> $while { + elsif $ast.is-a("Q::Statement::While") -> $while { handle($while.properties); } - elsif $ast.isa("Q::Block") -> $block { + elsif $ast.is-a("Q::Block") -> $block { $runtime.enter($runtime.current-frame, wrap({}), create(TYPE, :statements(wrap([])), )); @@ -283,10 +283,10 @@ sub check(_007::Object $ast, $runtime) is export { $block.properties = $runtime.current-frame.value; $runtime.leave(); } - elsif $ast.isa("Q::Term::Object") -> $object { + elsif $ast.is-a("Q::Term::Object") -> $object { handle($object.properties); } - elsif $ast.isa("Q::PropertyList") -> $propertylist { + elsif $ast.is-a("Q::PropertyList") -> $propertylist { my %seen; for $propertylist.properties.value -> _007::Object $p { my Str $property = $p.properties.value; diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index cbdf0dd4..08091bbd 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -27,10 +27,10 @@ class _007::Type { TYPE; } - multi method isa(Str $typename) { - ($typename eq "Object" || $typename eq "Type") && self; + multi method is-a(Str $typename) { + self.is-a(TYPE{$typename}); } - multi method isa(_007::Type $type) { + multi method is-a(_007::Type $type) { ($type === TYPE || $type === TYPE) && self; } } From ceaa02908d5d0b85547f681641883099df78c2f5 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 09:33:19 +0200 Subject: [PATCH 73/91] re-introduce parts of object.t as dict.t --- lib/_007/Object.pm | 17 +++++++-- lib/_007/Runtime.pm | 13 +------ lib/_007/Test.pm | 15 +++++--- t/features/dict.t | 90 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 115 insertions(+), 20 deletions(-) create mode 100644 t/features/dict.t diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index c6506055..1a7aba23 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -75,6 +75,15 @@ class X::Type is Exception { } } +class X::Property::NotFound is Exception { + has $.propname; + has $.type; + + method message { + "Property '$.propname' not found on object of type $.type" + } +} + class _007::Object { has $.type; has $.id = unique-id; @@ -424,12 +433,14 @@ sub bound-method($object, $name) is export { if $index.value < 0; return .value[$index.value]; } - if .is-a("Dict") { + if .is-a("Dict") -> $dict { my $property = bound-method($object.properties, "eval")($runtime); die X::Subscript::NonString.new unless $property.is-a("Str"); - my $key = $property.value; - return .value{$key}; + 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)); } diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index b780b9eb..b351d4b6 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -3,15 +3,6 @@ use _007::Object; use _007::Builtins; use _007::OpScope; -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" } } @@ -218,7 +209,7 @@ class _007::Runtime { my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); - my $type = $obj.type; + my $type = $obj.type.name; die X::Property::NotFound.new(:$propname, :$type) unless %known-properties{$propname}; @@ -473,7 +464,7 @@ class _007::Runtime { return wrap($obj.id); } else { - my $type = $obj.type; + my $type = $obj.type.name; die X::Property::NotFound.new(:$propname, :$type); } } diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 6c4769d5..7a2e51e5 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -142,7 +142,7 @@ sub read(Str $ast) is export { if $qtype === TYPE { %arguments //= wrap({}); } - if $qtype === TYPE | TYPE { + if $qtype === TYPE | TYPE | TYPE { %arguments //= create(TYPE, :traits(wrap([])), ); @@ -228,11 +228,6 @@ sub check(_007::Object $ast, $runtime) is export { $block.properties.properties = $runtime.current-frame.value; $runtime.leave(); } - 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 - } elsif $ast.is-a("Q::Statement::Sub") -> $sub { my $outer-frame = $runtime.current-frame; my $name = $sub.properties.properties; @@ -286,6 +281,9 @@ sub check(_007::Object $ast, $runtime) is export { 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 { @@ -294,6 +292,11 @@ sub check(_007::Object $ast, $runtime) is export { 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}"; } 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; From 6df9fdbeabb9ccfab1992b6438877a0ccdc1cb4f Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 15:35:47 +0200 Subject: [PATCH 74/91] re-introduce the rest of objects.t as objects.t --- lib/_007/Parser/Actions.pm | 45 ++++++++++------------ self-host/runtime.007 | 14 +++++-- t/features/objects.t | 78 ++++++++++++++++++++++++++++++++++++++ t/features/quasi.t | 14 +++++-- 4 files changed, 118 insertions(+), 33 deletions(-) create mode 100644 t/features/objects.t diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 602b9e4a..b5f55e66 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -671,34 +671,27 @@ class _007::Parser::Actions { method term:new-object ($/) { my $type = $.ast.properties.value; - my $type-var = $*runtime.get-var($type); - my $type-obj = $type-var ~~ _007::Type - ?? $type-var - !! $type-var.type; - - if $type-obj ~~ _007::Type { - # XXX: need to figure out how to do the corresponding error handling here - # something with .fields, most likely? - } - - # XXX: Need some way to detect undeclared or required properties with _007::Type -# sub aname($attr) { $attr.name.substr(2) } -# my %known-properties = $type-obj.attributes.map({ aname($_) => 1 }); -# for $.ast.value.value -> $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.value.value».key».value); -# } + my $type-obj = $*runtime.get-var($type); + + my $known-properties = set($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; + $seen-properties (|)= $property; + } + for $known-properties.keys -> $property { + # XXX: once we handle optional properties, we will `next` here + + 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)), :frame(NONE), diff --git a/self-host/runtime.007 b/self-host/runtime.007 index 8c0e7ffc..00e95e85 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": {}, } }; } @@ -20,7 +23,10 @@ my Runtime = { frames.push(frame); for static_lexpad.keys() -> name { my value = static_lexpad[name]; - my identifier = new Q::Identifier { name }; + my identifier = new Q::Identifier { + name, + frame: None, + }; declare_var(identifier, value); } } diff --git a/t/features/objects.t b/t/features/objects.t new file mode 100644 index 00000000..f0564387 --- /dev/null +++ b/t/features/objects.t @@ -0,0 +1,78 @@ +use v6; +use Test; +use _007::Test; + +{ + my $program = q:to/./; + my q = new Q::Identifier { + name: "foo", + # XXX: can remove this later + frame: None, + }; + + say(q.name); + . + + outputs + $program, + qq[foo\n], + "object literal syntax prefixed by type"; +} + +{ + my $program = q:to/./; + my q = new Q::Identifier { dunnexist: "foo" }; + . + + parse-error + $program, + X::Property::NotDeclared, + "the object property doesn't exist on that type"; +} + +{ + my $program = q:to/./; + my q = new Q::Identifier { + name: "foo", + # XXX: can remove this later + frame: None, + }; + + say(type(q)); + . + + outputs + $program, + qq[\n], + "an object literal is of the declared type"; +} + +{ + my $program = q:to/./; + my i = new Int { value: 7 }; + my s = new Str { value: "Bond" }; + my a = new Array { value: [0, 0, 7] }; + + say(i == 7); + say(s == "Bond"); + say(a == [0, 0, 7]); + . + + outputs + $program, + qq[True\nTrue\nTrue\n], + "can create normal objects using typed object literals"; +} + +{ + my $program = q:to/./; + my q = new Q::Identifier {}; + . + + parse-error + $program, + X::Property::Required, + "need to specify required properties on objects (#87)"; +} + +done-testing; diff --git a/t/features/quasi.t b/t/features/quasi.t index 607018b6..b6818099 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -209,14 +209,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"; @@ -232,12 +232,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!") } })); From 2f525da753a2c5506035d09997384d57f6b05a76 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Tue, 19 Sep 2017 18:48:34 +0200 Subject: [PATCH 75/91] No more .property in Runtime; hello bound-method Took on a little bit of technical debt with this one: - Because of .map and .filter, bound-method now actually needs to take a $runtime parameter. A number of other things did as well. - We're passing in $runtime everywhere now. As the Q .eval and .run methods are now entirely defined in bound-method (which now has a $runtime), those methods don't actually need a `runtime` parameter anymore. - In the long run, I think we're better off with a `BoundMethod` type, instead of the kind of primitive wrapping we're doing now. - Needless to say, we should method-dispatch a bit more cleverly in bound-method. That's up next. --- bin/count-builtins | 10 - lib/_007/Backend/JavaScript.pm | 4 +- lib/_007/Builtins.pm | 10 +- lib/_007/Object.pm | 443 ++++++++++++++++++++++++++++----- lib/_007/Parser/Actions.pm | 10 +- lib/_007/Runtime.pm | 322 +----------------------- lib/_007/Test.pm | 2 +- lib/_007/Type.pm | 2 +- t/features/quasi.t | 4 +- 9 files changed, 393 insertions(+), 414 deletions(-) diff --git a/bin/count-builtins b/bin/count-builtins index afc14be0..1c462c92 100755 --- a/bin/count-builtins +++ b/bin/count-builtins @@ -3,7 +3,6 @@ use v6; my $type_count = 0; my $bound_method_count = 0; -my $runtime_builtin_method_count = 0; my $built_in_subs = 0; my $exception_types_in_007 = 0; my $exception_types_in_perl6 = 0; @@ -40,14 +39,6 @@ for -> $file { } } -for -> $file { - for $file.IO.lines { - if /^ \h* "return builtin(" / { - $runtime_builtin_method_count++; - } - } -} - for -> $file { for $file.IO.lines { if /^ \h* "my @builtins ="/ ff /^ \h* ";" \h* $/ { @@ -68,7 +59,6 @@ for .properties.value.map: { die "Cannot handle non-literal-Str arguments just yet!" unless .is-a("Q::Literal::Str"); - reprify(.properties); + q["] ~ .properties.value.subst("\\", "\\\\", :g).subst(q["], q[\\"], :g) ~ q["]; }; @main.push("say({@arguments.join(", ")});"); } @@ -51,7 +51,7 @@ class _007::Backend::JavaScript { if $stmt.properties !=== NONE { die "Cannot handle non-literal-Int rhs just yet!" unless $stmt.properties.is-a("Q::Literal::Int"); - my $expr = stringify($stmt.properties.properties); + my $expr = ~$stmt.properties.properties.value; @main.push("let {$name} = {$expr};"); } else { diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index e62b13a4..ffa79483 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -1,7 +1,7 @@ use _007::Type; use _007::Object; -sub builtins(:$input!, :$output!, :$opscope!) is export { +sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { # These multis are used below by infix:<==> and infix: multi equal-value($, $) { False } multi equal-value(_007::Object $l, _007::Object $r) { @@ -115,7 +115,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { my @builtins = say => -> $arg { - $output.print(stringify($arg) ~ "\n"); + $output.print(stringify($arg, $runtime) ~ "\n"); Nil; }, prompt => sub ($arg) { @@ -321,7 +321,7 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { # prefixes 'prefix:~' => op( sub prefix-str($expr) { - return wrap(stringify($expr)); + return wrap(stringify($expr, $runtime)); }, :qtype(TYPE), ), @@ -359,13 +359,13 @@ sub builtins(:$input!, :$output!, :$opscope!) is export { ), 'prefix:?' => op( sub ($arg) { - return wrap(boolify($arg)); + return wrap(boolify($arg, $runtime)); }, :qtype(TYPE), ), 'prefix:!' => op( sub ($arg) { - return wrap(!boolify($arg)); + return wrap(!boolify($arg, $runtime)); }, :qtype(TYPE), ), diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 1a7aba23..366da2e5 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -84,6 +84,10 @@ class X::Property::NotFound is Exception { } } +class X::Regex::InvalidMatchType is Exception { + method message { "A regex can only match strings" } +} + class _007::Object { has $.type; has $.id = unique-id; @@ -189,22 +193,22 @@ sub pretty($parameterlist) { }).join(", "); } -sub stringify($object) is export { - my $s = bound-method($object, "Str")(); +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) is export { - my $s = bound-method($object, "repr")(); +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) is export { - my $s = bound-method($object, "Bool")(); +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; @@ -220,14 +224,17 @@ my $str-dict-seen; # 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) is export { +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) { $runtime.enter( $runtime.current-frame, $object.properties.properties, $object.properties.properties); - bound-method($object.properties.properties, "run")($runtime); + bound-method($object.properties.properties, "run", $runtime)($runtime); $runtime.leave; }; } @@ -235,7 +242,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::StatementList") && $name eq "run" { return sub run-q-statementlist($runtime) { for $object.properties.value -> $statement { - my $value = bound-method($statement, "run")($runtime); + my $value = bound-method($statement, "run", $runtime)($runtime); LAST if $statement.is-a("Q::Statement::Expr") { return $value; } @@ -245,7 +252,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Statement::Expr") && $name eq "run" { return sub run-q-statement-expr($runtime) { - return bound-method($object.properties, "eval")($runtime); + return bound-method($object.properties, "eval", $runtime)($runtime); }; } @@ -270,7 +277,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Term::Dict") && $name eq "eval" { return sub eval-q-term-dict($runtime) { return wrap(hash($object.properties.properties.value.map({ - .properties.value => bound-method(.properties, "eval")($runtime); + .properties.value => bound-method(.properties, "eval", $runtime)($runtime); }))); }; } @@ -306,7 +313,7 @@ sub bound-method($object, $name) is export { :type("For loop"), :paramcount($count), :argcount("0 or 1")) if $count > 1; - my $array = bound-method($object.properties, "eval")($runtime); + my $array = bound-method($object.properties, "eval", $runtime)($runtime); die X::Type.new(:operation("for loop"), :got($array), :expected(TYPE)) unless $array.is-a("Array"); @@ -318,7 +325,7 @@ sub bound-method($object, $name) is export { if $count == 1 { $runtime.declare-var($object.properties.properties.properties.value[0].properties, $arg.list[0]); } - bound-method($object.properties.properties, "run")($runtime); + bound-method($object.properties.properties, "run", $runtime)($runtime); $runtime.leave; } }; @@ -326,7 +333,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Statement::While") && $name eq "run" { return sub run-q-statement-while($runtime) { - while boolify(my $expr = bound-method($object.properties, "eval")($runtime)) { + while boolify(my $expr = bound-method($object.properties, "eval", $runtime)($runtime), $runtime) { my $paramcount = $object.properties.properties.properties.value.elems; die X::ParameterMismatch.new( :type("While loop"), :$paramcount, :argcount("0 or 1")) @@ -338,7 +345,7 @@ sub bound-method($object, $name) is export { for @($object.properties.properties.properties.value) Z $expr -> ($param, $arg) { $runtime.declare-var($param.properties, $arg); } - bound-method($object.properties.properties, "run")($runtime); + bound-method($object.properties.properties, "run", $runtime)($runtime); $runtime.leave; } }; @@ -351,80 +358,106 @@ sub bound-method($object, $name) is export { $object.properties.properties); if $type ~~ _007::Type { return create($type, |hash($object.properties.properties.value.map({ - .properties.value => bound-method(.properties, "eval")($runtime) + .properties.value => bound-method(.properties, "eval", $runtime)($runtime) }))); } return create($type, $object.properties.properties.value.map({ - .properties.value => bound-method(.properties, "eval")($runtime) + .properties.value => bound-method(.properties, "eval", $runtime)($runtime) })); }; } if $object.is-a("Q::Infix::Assignment") && $name eq "eval" { return sub eval-q-infix-assignment($runtime) { - my $value = bound-method($object.properties, "eval")($runtime); - bound-method($object.properties, "put-value")($value, $runtime); + my $value = bound-method($object.properties, "eval", $runtime)($runtime); + bound-method($object.properties, "put-value", $runtime)($value, $runtime); return $value; }; } if $object.is-a("Q::Infix::And") && $name eq "eval" { return sub eval-q-infix-and($runtime) { - my $l = bound-method($object.properties, "eval")($runtime); - return boolify($l) - ?? bound-method($object.properties, "eval")($runtime) + my $l = bound-method($object.properties, "eval", $runtime)($runtime); + return boolify($l, $runtime) + ?? bound-method($object.properties, "eval", $runtime)($runtime) !! $l; }; } if $object.is-a("Q::Infix::Or") && $name eq "eval" { return sub eval-q-infix-or($runtime) { - my $l = bound-method($object.properties, "eval")($runtime); - return boolify($l) + my $l = bound-method($object.properties, "eval", $runtime)($runtime); + return boolify($l, $runtime) ?? $l - !! bound-method($object.properties, "eval")($runtime); + !! bound-method($object.properties, "eval", $runtime)($runtime); }; } if $object.is-a("Q::Infix::DefinedOr") && $name eq "eval" { return sub eval-q-infix-definedor($runtime) { - my $l = bound-method($object.properties, "eval")($runtime); + my $l = bound-method($object.properties, "eval", $runtime)($runtime); return $l !=== NONE ?? $l - !! bound-method($object.properties, "eval")($runtime); + !! bound-method($object.properties, "eval", $runtime)($runtime); }; } if $object.is-a("Q::Infix") && $name eq "eval" { return sub eval-q-infix($runtime) { - my $l = bound-method($object.properties, "eval")($runtime); - my $r = bound-method($object.properties, "eval")($runtime); - my $c = bound-method($object.properties, "eval")($runtime); + my $l = bound-method($object.properties, "eval", $runtime)($runtime); + my $r = bound-method($object.properties, "eval", $runtime)($runtime); + my $c = bound-method($object.properties, "eval", $runtime)($runtime); return internal-call($c, $runtime, [$l, $r]); }; } if $object.is-a("Q::Prefix") && $name eq "eval" { return sub eval-q-prefix($runtime) { - my $e = bound-method($object.properties, "eval")($runtime); - my $c = bound-method($object.properties, "eval")($runtime); + my $e = bound-method($object.properties, "eval", $runtime)($runtime); + my $c = bound-method($object.properties, "eval", $runtime)($runtime); return internal-call($c, $runtime, [$e]); }; } if $object.is-a("Q::Postfix::Property") && $name eq "eval" { return sub eval-q-postfix-property($runtime) { - my $obj = bound-method($object.properties, "eval")($runtime); + my $obj = bound-method($object.properties, "eval", $runtime)($runtime); my $propname = $object.properties.properties.value; - $runtime.property($obj, $propname); + my @props = $obj.type.type-chain.map({ .fields }).flat; + 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); + my $name = &fn.name; + my &ditch-sigil = { $^str.substr(1) }; + my ¶meter = { + create(TYPE, + :identifier(create(TYPE, + :name(wrap($^value)) + :frame(NONE)) + ) + ) + }; + my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; + my $parameters = wrap(@elements); + my $parameterlist = create(TYPE, :$parameters); + my $statementlist = create(TYPE, :statements(wrap([]))); + return wrap-fn(&fn, $name, $parameterlist, $statementlist); + } }; } if $object.is-a("Q::Postfix::Index") && $name eq "eval" { return sub eval-q-postfix-index($runtime) { - given bound-method($object.properties, "eval")($runtime) { + given bound-method($object.properties, "eval", $runtime)($runtime) { if .is-a("Array") { - my $index = bound-method($object.properties, "eval")($runtime); + my $index = bound-method($object.properties, "eval", $runtime)($runtime); die X::Subscript::NonInteger.new unless $index.is-a("Int"); die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) @@ -434,7 +467,7 @@ sub bound-method($object, $name) is export { return .value[$index.value]; } if .is-a("Dict") -> $dict { - my $property = bound-method($object.properties, "eval")($runtime); + my $property = bound-method($object.properties, "eval", $runtime)($runtime); die X::Subscript::NonString.new unless $property.is-a("Str"); my $propname = $property.value; @@ -449,13 +482,13 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Postfix::Call") && $name eq "eval" { return sub eval-q-postfix-call($runtime) { - my $c = bound-method($object.properties, "eval")($runtime); + my $c = bound-method($object.properties, "eval", $runtime)($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) + bound-method($_, "eval", $runtime)($runtime) }); return internal-call($c, $runtime, @arguments); }; @@ -463,8 +496,8 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Postfix") && $name eq "eval" { return sub eval-q-postfix($runtime) { - my $e = bound-method($object.properties, "eval")($runtime); - my $c = bound-method($object.properties, "eval")($runtime); + my $e = bound-method($object.properties, "eval", $runtime)($runtime); + my $c = bound-method($object.properties, "eval", $runtime)($runtime); return internal-call($c, $runtime, [$e]); }; } @@ -474,8 +507,8 @@ sub bound-method($object, $name) is export { return if $object.properties === NONE; - my $value = bound-method($object.properties, "eval")($runtime); - bound-method($object.properties, "put-value")($value, $runtime); + my $value = bound-method($object.properties, "eval", $runtime)($runtime); + bound-method($object.properties, "put-value", $runtime)($value, $runtime); }; } @@ -487,8 +520,8 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Statement::If") && $name eq "run" { return sub run-q-statement-if($runtime) { - my $expr = bound-method($object.properties, "eval")($runtime); - if boolify($expr) { + my $expr = bound-method($object.properties, "eval", $runtime)($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; @@ -501,20 +534,20 @@ sub bound-method($object, $name) is export { $object.properties.properties.properties.value[0].properties, $expr); } - bound-method($object.properties.properties, "run")($runtime); + bound-method($object.properties.properties, "run", $runtime)($runtime); $runtime.leave; } else { given $object.properties { when .is-a("Q::Statement::If") { - bound-method($object.properties, "run")($runtime) + bound-method($object.properties, "run", $runtime)($runtime) } when .is-a("Q::Block") { $runtime.enter( $runtime.current-frame, $object.properties.properties, $object.properties.properties); - bound-method($object.properties.properties, "run")($runtime); + bound-method($object.properties.properties, "run", $runtime)($runtime); $runtime.leave; } } @@ -526,7 +559,7 @@ sub bound-method($object, $name) is export { return sub run-q-statement-return($runtime) { my $value = $object.properties === NONE ?? $object.properties - !! bound-method($object.properties, "eval")($runtime); + !! bound-method($object.properties, "eval", $runtime)($runtime); my $frame = $runtime.get-var("--RETURN-TO--"); die X::Control::Return.new(:$value, :$frame); }; @@ -555,20 +588,20 @@ sub bound-method($object, $name) is export { if $thing.is-a("Q::Identifier"); if $thing.is-a("Q::Unquote::Prefix") { - my $prefix = bound-method($thing.properties, "eval")($runtime); + my $prefix = bound-method($thing.properties, "eval", $runtime)($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); + my $infix = bound-method($thing.properties, "eval", $runtime)($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); + my $ast = bound-method($thing.properties, "eval", $runtime)($runtime); die "Expression inside unquote did not evaluate to a Q" # XXX: turn into X:: unless $ast.is-a("Q"); return $ast; @@ -601,7 +634,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Term::Array") && $name eq "eval" { return sub eval-q-term-array($runtime) { - return wrap($object.properties.value.map({ bound-method($_, "eval")($runtime) })); + return wrap($object.properties.value.map({ bound-method($_, "eval", $runtime)($runtime) })); }; } @@ -609,7 +642,7 @@ sub bound-method($object, $name) is export { return sub eval-q-statement-throw($runtime) { my $value = $object.properties === NONE ?? create(TYPE, :message(wrap("Died"))) - !! bound-method($object.properties, "eval")($runtime); + !! bound-method($object.properties, "eval", $runtime)($runtime); die X::Type.new(:got($value), :expected(TYPE)) unless $value.is-a("Exception"); @@ -619,9 +652,9 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Postfix::Index") && $name eq "put-value" { return sub put-value-q-postfix-index($value, $runtime) { - given bound-method($object.properties, "eval")($runtime) { + given bound-method($object.properties, "eval", $runtime)($runtime) { if .is-a("Array") { - my $index = bound-method($object.properties, "eval")($runtime); + my $index = bound-method($object.properties, "eval", $runtime)($runtime); die X::Subscript::NonInteger.new unless $index.is-a("Int"); die X::Subscript::TooLarge.new(:value($index.value), :length(+.value)) @@ -632,7 +665,7 @@ sub bound-method($object, $name) is export { return; } if .is-a("Dict") || .is-a("Q") { - my $property = bound-method($object.properties, "eval")($runtime); + my $property = bound-method($object.properties, "eval", $runtime)($runtime); die X::Subscript::NonString.new unless $property.is-a("Str"); my $propname = $property.value; @@ -646,7 +679,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Postfix::Property") && $name eq "put-value" { return sub put-value-q-postfix-property($value, $runtime) { - given bound-method($object.properties, "eval")($runtime) { + given bound-method($object.properties, "eval", $runtime)($runtime) { if .is-a("Dict") || .is-a("Q") { my $propname = $object.properties.properties.value; $runtime.put-property($_, $propname, $value); @@ -683,7 +716,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Q::Expr::StatementListAdapter") && $name eq "eval" { return sub eval-q-expr-statementlistadapter($runtime) { - return bound-method($object.properties, "run")($runtime); + return bound-method($object.properties, "run", $runtime)($runtime); }; } @@ -728,7 +761,7 @@ sub bound-method($object, $name) is export { return wrap("[...]"); } - return wrap("[" ~ $object.value.map(&reprify).join(", ") ~ "]"); + return wrap("[" ~ $object.value.map({ reprify($_, $runtime) }).join(", ") ~ "]"); }; } @@ -746,8 +779,8 @@ sub bound-method($object, $name) is export { return wrap('{' ~ $object.value.map({ my $key = .key ~~ /^ [\w+]+ % '::'$/ ?? .key - !! reprify(wrap(.key)); - "{$key}: {reprify(.value)}"; + !! reprify(wrap(.key), $runtime); + "{$key}: {reprify(.value, $runtime)}"; }).sort.join(', ') ~ '}'); }; } @@ -760,7 +793,7 @@ sub bound-method($object, $name) is export { if $object.is-a("Object") && $name eq "repr" { return sub repr-object() { - return wrap(stringify($object)); + return wrap(stringify($object, $runtime)); } } @@ -793,9 +826,9 @@ sub bound-method($object, $name) is export { !($object.is-a("Q::Block") && $_ eq "static-lexpad") }; if @props == 1 { - return wrap("{$object.type.name} { reprify($object.properties{@props[0]}) }"); + return wrap("{$object.type.name} { reprify($object.properties{@props[0]}, $runtime) }"); } - sub keyvalue($prop) { $prop ~ ": " ~ reprify($object.properties{$prop}) } + 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\}"); }; @@ -843,9 +876,281 @@ sub bound-method($object, $name) is export { }; } - die "The invocant is undefined" - if $object === Any; - die "Method '$name' does not exist on {$object.type.name}"; + 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), :frame(NONE)) + 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: -> $fieldname { + $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($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)); } sub wrap($value) is export { @@ -903,7 +1208,7 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { } $runtime.register-subhandler; my $frame = $runtime.current-frame; - my $value = bound-method($sub.properties, "run")($runtime); + my $value = bound-method($sub.properties, "run", $runtime)($runtime); $runtime.leave; CATCH { when X::Control::Return { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index b5f55e66..d81fdf4e 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -95,8 +95,8 @@ class _007::Parser::Actions { :identifier($.ast), :expr($.ast)); - my $value = bound-method($.ast, "eval")($*runtime); - bound-method($.ast, "put-value")($value, $*runtime); + my $value = bound-method($.ast, "eval", $*runtime)($*runtime); + bound-method($.ast, "put-value", $*runtime)($value, $*runtime); } method statement:expr ($/) { @@ -200,7 +200,7 @@ class _007::Parser::Actions { die "Unknown routine type $"; # XXX: Turn this into an X:: exception } - bound-method($identifier, "put-value")($val, $*runtime); + bound-method($identifier, "put-value", $*runtime)($val, $*runtime); maybe-install-operator($name.value, $); } @@ -244,7 +244,7 @@ class _007::Parser::Actions { make create(TYPE, :$block); my $name = $identifier.properties.value; my $val = _007::Type.new(:$name); - bound-method($identifier, "put-value")($val, $*runtime); + bound-method($identifier, "put-value", $*runtime)($val, $*runtime); } method traitlist($/) { @@ -651,7 +651,7 @@ class _007::Parser::Actions { 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")($val, $*runtime); + bound-method($.ast, "put-value", $*runtime)($val, $*runtime); } self.finish-block($block); diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index b351d4b6..db8c1e7e 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -3,10 +3,6 @@ use _007::Object; use _007::Builtins; use _007::OpScope; -class X::Regex::InvalidMatchType is Exception { - method message { "A regex can only match strings" } -} - constant NO_OUTER = wrap({}); constant RETURN_TO = create(TYPE, :name(wrap("--RETURN-TO--")), @@ -29,7 +25,7 @@ class _007::Runtime { } method run(_007::Object $compunit) { - bound-method($compunit, "run")(self); + bound-method($compunit, "run", self)(self); CATCH { when X::Control::Return { die X::ControlFlow::Return.new; @@ -147,7 +143,7 @@ class _007::Runtime { method load-builtins { my $opscope = $!builtin-opscope; - for builtins(:$.input, :$.output, :$opscope) -> Pair (:key($name), :$value) { + for builtins(:$.input, :$.output, :$opscope, :runtime(self)) -> Pair (:key($name), :$value) { my $identifier = create(TYPE, :name(wrap($name)), :frame(NONE)); @@ -155,320 +151,6 @@ class _007::Runtime { } } - method property($obj, Str $propname) { - sub builtin(&fn) { - my $name = &fn.name; - my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { - create(TYPE, - :identifier(create(TYPE, - :name(wrap($^value)) - :frame(NONE)) - ) - ) - }; - my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameters = wrap(@elements); - my $parameterlist = create(TYPE, :$parameters); - my $statementlist = create(TYPE, :statements(wrap([]))); - return wrap-fn(&fn, $name, $parameterlist, $statementlist); - } - - if $obj.is-a("Q") { - if $propname 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), :frame(NONE)) - 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: -> $fieldname { - $fieldname => interpolate($thing.properties{$fieldname}) - }; - - create($thing.type, |%properties); - } - - return builtin(sub detach() { - return interpolate($obj); - }); - } - elsif $propname eq "get" { - return builtin(sub get($prop) { - return self.property($obj, $prop.value); - }); - } - - my %known-properties = $obj.type.type-chain.reverse.map({ .fields }).flat.map({ $_ => 1 }); - - my $type = $obj.type.name; - die X::Property::NotFound.new(:$propname, :$type) - unless %known-properties{$propname}; - - return $obj.properties{$propname}; - } - elsif $obj.is-a("Int") && $propname eq "abs" { - return builtin(sub abs() { - return wrap($obj.value.abs); - }); - } - elsif $obj.is-a("Int") && $propname eq "chr" { - return builtin(sub chr() { - return wrap($obj.value.chr); - }); - } - elsif $obj.is-a("Str") && $propname eq "ord" { - return builtin(sub ord() { - return wrap($obj.value.ord); - }); - } - elsif $obj.is-a("Str") && $propname eq "chars" { - return builtin(sub chars() { - return wrap($obj.value.chars); - }); - } - elsif $obj.is-a("Str") && $propname eq "uc" { - return builtin(sub uc() { - return wrap($obj.value.uc); - }); - } - elsif $obj.is-a("Str") && $propname eq "lc" { - return builtin(sub lc() { - return wrap($obj.value.lc); - }); - } - elsif $obj.is-a("Str") && $propname eq "trim" { - return builtin(sub trim() { - return wrap($obj.value.trim); - }); - } - elsif $obj.is-a("Array") && $propname eq "size" { - return builtin(sub size() { - return wrap($obj.value.elems); - }); - } - elsif $obj.is-a("Array") && $propname eq "reverse" { - return builtin(sub reverse() { - return wrap($obj.value.reverse); - }); - } - elsif $obj.is-a("Array") && $propname eq "sort" { - return builtin(sub sort() { - # 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($obj.value.map({ - die "Cannot sort a {.type.name}" - if $_ !~~ _007::Object::Wrapped; - .value; - }).sort().map(&wrap)); - }); - } - elsif $obj.is-a("Array") && $propname eq "shuffle" { - return builtin(sub shuffle() { - return wrap($obj.value.pick(*)); - }); - } - elsif $obj.is-a("Array") && $propname eq "concat" { - return builtin(sub concat($array) { - die X::Type.new(:operation, :got($array), :expected(TYPE)) - unless $array.is-a("Array"); - return wrap([|$obj.value, |$array.value]); - }); - } - elsif $obj.is-a("Array") && $propname eq "join" { - return builtin(sub join($sep) { - die X::Type.new(:operation, :got($sep), :expected(TYPE)) - unless $sep.is-a("Str"); - return wrap($obj.value.map(&stringify).join($sep.value)); - }); - } - elsif $obj.is-a("Dict") && $propname eq "size" { - return builtin(sub size() { - return wrap($obj.value.elems); - }); - } - elsif $obj.is-a("Str") && $propname eq "split" { - return builtin(sub split($sep) { - my @elements = $obj.value.split($sep.value).map(&wrap); - return wrap(@elements); - }); - } - elsif $obj.is-a("Str") && $propname eq "index" { - return builtin(sub index($substr) { - return wrap($obj.value.index($substr.value) // -1); - }); - } - elsif $obj.is-a("Str") && $propname eq "substr" { - return builtin(sub substr($pos, $chars) { - return wrap($obj.value.substr( - $pos.value, - $chars.value)); - }); - } - elsif $obj.is-a("Str") && $propname eq "contains" { - return builtin(sub contains($substr) { - die X::Type.new(:operation, :got($substr), :expected(TYPE)) - unless $substr.is-a("Str"); - - return wrap($obj.value.contains($substr.value)); - }); - } - elsif $obj.is-a("Str") && $propname eq "prefix" { - return builtin(sub prefix($pos) { - return wrap($obj.value.substr( - 0, - $pos.value)); - }); - } - elsif $obj.is-a("Str") && $propname eq "suffix" { - return builtin(sub suffix($pos) { - return wrap($obj.value.substr( - $pos.value)); - }); - } - elsif $obj.is-a("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 wrap($s.substr($pos.value, 1)); - }); - } - elsif $obj.is-a("Regex") && $propname eq "fullmatch" { - return builtin(sub fullmatch($str) { - my $regex-string = $obj.properties.value; - - die X::Regex::InvalidMatchType.new - unless $str.is-a("Str"); - - return wrap($regex-string eq $str.value); - }); - } - elsif $obj.is-a("Regex") && $propname eq "search" { - return builtin(sub search($str) { - my $regex-string = $obj.properties.value; - - die X::Regex::InvalidMatchType.new - unless $str.is-a("Str"); - - return wrap($str.value.contains($regex-string)); - }); - } - elsif $obj.is-a("Array") && $propname eq "filter" { - return builtin(sub filter($fn) { - # XXX: Need to typecheck here if $fn is callable - my @elements = $obj.value.grep({ boolify(internal-call($fn, self, [$_])) }); - return wrap(@elements); - }); - } - elsif $obj.is-a("Array") && $propname eq "map" { - return builtin(sub map($fn) { - # XXX: Need to typecheck here if $fn is callable - my @elements = $obj.value.map({ internal-call($fn, self, [$_]) }); - return wrap(@elements); - }); - } - elsif $obj.is-a("Array") && $propname eq "push" { - return builtin(sub push($newelem) { - $obj.value.push($newelem); - return NONE; - }); - } - elsif $obj.is-a("Array") && $propname eq "pop" { - return builtin(sub pop() { - die X::Cannot::Empty.new(:action, :what($obj.^name)) - if $obj.value.elems == 0; - return $obj.value.pop(); - }); - } - elsif $obj.is-a("Array") && $propname eq "shift" { - return builtin(sub shift() { - die X::Cannot::Empty.new(:action, :what($obj.^name)) - if $obj.value.elems == 0; - return $obj.value.shift(); - }); - } - elsif $obj.is-a("Array") && $propname eq "unshift" { - return builtin(sub unshift($newelem) { - $obj.value.unshift($newelem); - return NONE; - }); - } - elsif $obj ~~ _007::Type && $propname eq "name" { - return wrap($obj.name); - } - elsif $obj ~~ _007::Type && $propname eq "name" { - return wrap($obj.name); - } - elsif $obj ~~ _007::Type && $propname eq "create" { - return builtin(sub create($properties) { - # XXX: check that $properties is an array of [k, v] arrays - create($obj, |hash($properties.value.map(-> $p { - my ($k, $v) = @($p.value); - $k.value => $v; - }))); - }); - } - elsif $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 wrap($obj.value.keys.map(&wrap)); - }); - } - 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.value{$prop.value} :exists; - return wrap($value); - }); - } - elsif $propname eq "update" { - return builtin(sub update($newprops) { - for $obj.value.keys { - $obj.value{$_} = $newprops.value{$_} // $obj.value{$_}; - } - return $obj; - }); - } - elsif $propname eq "extend" { - return builtin(sub extend($newprops) { - for $newprops.value.keys { - $obj.value{$_} = $newprops.value{$_}; - } - return $obj; - }); - } - elsif $propname eq "id" { - # XXX: Make this work for Q-type objects, too. - return wrap($obj.id); - } - else { - my $type = $obj.type.name; - die X::Property::NotFound.new(:$propname, :$type); - } - } - method put-property($obj, Str $propname, $newvalue) { if !$obj.is-a("Dict") { die "We don't handle assigning to non-Dict types yet"; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 7a2e51e5..6c2c8d89 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -346,7 +346,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 stringify($expected-ast), stringify($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 index 08091bbd..fa005b1c 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -93,7 +93,7 @@ BEGIN { ### say(type(q) == Q::Literal::Str); # --> `True` ### say(type(q) == Q::Literal); # --> `False` ### - TYPE = _007::Type.new(:name); + TYPE = _007::Type.new(:name, :fields["name"]); ### ### NoneType ### diff --git a/t/features/quasi.t b/t/features/quasi.t index b6818099..148af652 100644 --- a/t/features/quasi.t +++ b/t/features/quasi.t @@ -1,5 +1,6 @@ use v6; use Test; +use _007; use _007::Object; use _007::Test; @@ -8,9 +9,10 @@ use _007::Test; say(quasi { 1 + 1 }); . + # XXX: surely there's a better way to do this? my $expected = bound-method(read( "(statementlist (stexpr (infix:+ (int 1) (int 1))))" - ).properties.properties.properties.value[0].properties, "Str")().value; + ).properties.properties.properties.value[0].properties, "Str", _007.runtime)().value; outputs $program, "$expected\n", "Basic quasi quoting"; } From 379b8e604b1f4b27d98df75597d1cd51ab4300b9 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 07:38:06 +0200 Subject: [PATCH 76/91] remove 'runtime' parameter on all Qtypes Now that it's ambient in all of bound-method. --- lib/_007/Object.pm | 176 ++++++++++++++++++------------------- lib/_007/Parser/Actions.pm | 10 +-- lib/_007/Runtime.pm | 2 +- 3 files changed, 94 insertions(+), 94 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 366da2e5..69a9e19b 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -229,20 +229,20 @@ sub bound-method($object, $name, $runtime) is export { if $object === Any; if $object.is-a("Q::Statement::Block") && $name eq "run" { - return sub run-q-statement-block($runtime) { + 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); + bound-method($object.properties.properties, "run", $runtime)(); $runtime.leave; }; } if $object.is-a("Q::StatementList") && $name eq "run" { - return sub run-q-statementlist($runtime) { + return sub run-q-statementlist() { for $object.properties.value -> $statement { - my $value = bound-method($statement, "run", $runtime)($runtime); + my $value = bound-method($statement, "run", $runtime)(); LAST if $statement.is-a("Q::Statement::Expr") { return $value; } @@ -251,69 +251,69 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Statement::Expr") && $name eq "run" { - return sub run-q-statement-expr($runtime) { - return bound-method($object.properties, "eval", $runtime)($runtime); + 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($runtime) { + 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($runtime) { + 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($runtime) { + 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($runtime) { + return sub eval-q-term-dict() { return wrap(hash($object.properties.properties.value.map({ - .properties.value => bound-method(.properties, "eval", $runtime)($runtime); + .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) { + 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($runtime) { + 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($runtime) { + 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($runtime) { + 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($runtime) { + 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)($runtime); + my $array = bound-method($object.properties, "eval", $runtime)(); die X::Type.new(:operation("for loop"), :got($array), :expected(TYPE)) unless $array.is-a("Array"); @@ -325,15 +325,15 @@ sub bound-method($object, $name, $runtime) is export { if $count == 1 { $runtime.declare-var($object.properties.properties.properties.value[0].properties, $arg.list[0]); } - bound-method($object.properties.properties, "run", $runtime)($runtime); + 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($runtime) { - while boolify(my $expr = bound-method($object.properties, "eval", $runtime)($runtime), $runtime) { + 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")) @@ -345,83 +345,83 @@ sub bound-method($object, $name, $runtime) is export { for @($object.properties.properties.properties.value) Z $expr -> ($param, $arg) { $runtime.declare-var($param.properties, $arg); } - bound-method($object.properties.properties, "run", $runtime)($runtime); + 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($runtime) { + 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)($runtime) + .properties.value => bound-method(.properties, "eval", $runtime)() }))); } return create($type, $object.properties.properties.value.map({ - .properties.value => bound-method(.properties, "eval", $runtime)($runtime) + .properties.value => bound-method(.properties, "eval", $runtime)() })); }; } if $object.is-a("Q::Infix::Assignment") && $name eq "eval" { - return sub eval-q-infix-assignment($runtime) { - my $value = bound-method($object.properties, "eval", $runtime)($runtime); - bound-method($object.properties, "put-value", $runtime)($value, $runtime); + 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($runtime) { - my $l = bound-method($object.properties, "eval", $runtime)($runtime); + return sub eval-q-infix-and() { + my $l = bound-method($object.properties, "eval", $runtime)(); return boolify($l, $runtime) - ?? bound-method($object.properties, "eval", $runtime)($runtime) + ?? bound-method($object.properties, "eval", $runtime)() !! $l; }; } if $object.is-a("Q::Infix::Or") && $name eq "eval" { - return sub eval-q-infix-or($runtime) { - my $l = bound-method($object.properties, "eval", $runtime)($runtime); + 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)($runtime); + !! bound-method($object.properties, "eval", $runtime)(); }; } if $object.is-a("Q::Infix::DefinedOr") && $name eq "eval" { - return sub eval-q-infix-definedor($runtime) { - my $l = bound-method($object.properties, "eval", $runtime)($runtime); + return sub eval-q-infix-definedor() { + my $l = bound-method($object.properties, "eval", $runtime)(); return $l !=== NONE ?? $l - !! bound-method($object.properties, "eval", $runtime)($runtime); + !! bound-method($object.properties, "eval", $runtime)(); }; } if $object.is-a("Q::Infix") && $name eq "eval" { - return sub eval-q-infix($runtime) { - my $l = bound-method($object.properties, "eval", $runtime)($runtime); - my $r = bound-method($object.properties, "eval", $runtime)($runtime); - my $c = bound-method($object.properties, "eval", $runtime)($runtime); + 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($runtime) { - my $e = bound-method($object.properties, "eval", $runtime)($runtime); - my $c = bound-method($object.properties, "eval", $runtime)($runtime); + 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($runtime) { - my $obj = bound-method($object.properties, "eval", $runtime)($runtime); + 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; if $propname (elem) @props { @@ -454,10 +454,10 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Postfix::Index") && $name eq "eval" { - return sub eval-q-postfix-index($runtime) { - given bound-method($object.properties, "eval", $runtime)($runtime) { + 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)($runtime); + 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)) @@ -467,7 +467,7 @@ sub bound-method($object, $name, $runtime) is export { return .value[$index.value]; } if .is-a("Dict") -> $dict { - my $property = bound-method($object.properties, "eval", $runtime)($runtime); + my $property = bound-method($object.properties, "eval", $runtime)(); die X::Subscript::NonString.new unless $property.is-a("Str"); my $propname = $property.value; @@ -481,46 +481,46 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Postfix::Call") && $name eq "eval" { - return sub eval-q-postfix-call($runtime) { - my $c = bound-method($object.properties, "eval", $runtime)($runtime); + 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)($runtime) + bound-method($_, "eval", $runtime)() }); return internal-call($c, $runtime, @arguments); }; } if $object.is-a("Q::Postfix") && $name eq "eval" { - return sub eval-q-postfix($runtime) { - my $e = bound-method($object.properties, "eval", $runtime)($runtime); - my $c = bound-method($object.properties, "eval", $runtime)($runtime); + 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($runtime) { + return sub run-q-statement-my() { return if $object.properties === NONE; - my $value = bound-method($object.properties, "eval", $runtime)($runtime); - bound-method($object.properties, "put-value", $runtime)($value, $runtime); + 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($runtime) { + 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($runtime) { - my $expr = bound-method($object.properties, "eval", $runtime)($runtime); + 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")) @@ -534,20 +534,20 @@ sub bound-method($object, $name, $runtime) is export { $object.properties.properties.properties.value[0].properties, $expr); } - bound-method($object.properties.properties, "run", $runtime)($runtime); + 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)($runtime) + 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); + bound-method($object.properties.properties, "run", $runtime)(); $runtime.leave; } } @@ -556,17 +556,17 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Statement::Return") && $name eq "run" { - return sub run-q-statement-return($runtime) { + return sub run-q-statement-return() { my $value = $object.properties === NONE ?? $object.properties - !! bound-method($object.properties, "eval", $runtime)($runtime); + !! 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($runtime) { + return sub eval-q-term-quasi() { sub interpolate($thing) { return wrap($thing.value.map(&interpolate)) if $thing.is-a("Array"); @@ -588,20 +588,20 @@ sub bound-method($object, $name, $runtime) is export { if $thing.is-a("Q::Identifier"); if $thing.is-a("Q::Unquote::Prefix") { - my $prefix = bound-method($thing.properties, "eval", $runtime)($runtime); + 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)($runtime); + 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)($runtime); + 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; @@ -620,7 +620,7 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Term::Sub") && $name eq "eval" { - return sub eval-q-term-sub($runtime) { + return sub eval-q-term-sub() { my $name = $object.properties === NONE ?? wrap("") !! $object.properties.properties; @@ -633,16 +633,16 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Term::Array") && $name eq "eval" { - return sub eval-q-term-array($runtime) { - return wrap($object.properties.value.map({ bound-method($_, "eval", $runtime)($runtime) })); + 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($runtime) { + return sub eval-q-statement-throw() { my $value = $object.properties === NONE ?? create(TYPE, :message(wrap("Died"))) - !! bound-method($object.properties, "eval", $runtime)($runtime); + !! bound-method($object.properties, "eval", $runtime)(); die X::Type.new(:got($value), :expected(TYPE)) unless $value.is-a("Exception"); @@ -651,10 +651,10 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Postfix::Index") && $name eq "put-value" { - return sub put-value-q-postfix-index($value, $runtime) { - given bound-method($object.properties, "eval", $runtime)($runtime) { + 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)($runtime); + 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)) @@ -665,7 +665,7 @@ sub bound-method($object, $name, $runtime) is export { return; } if .is-a("Dict") || .is-a("Q") { - my $property = bound-method($object.properties, "eval", $runtime)($runtime); + my $property = bound-method($object.properties, "eval", $runtime)(); die X::Subscript::NonString.new unless $property.is-a("Str"); my $propname = $property.value; @@ -678,8 +678,8 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Postfix::Property") && $name eq "put-value" { - return sub put-value-q-postfix-property($value, $runtime) { - given bound-method($object.properties, "eval", $runtime)($runtime) { + 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); @@ -691,32 +691,32 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Q::Statement::BEGIN") && $name eq "run" { - return sub run-q-statement-begin($runtime) { + 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($runtime) { + 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($runtime) { + return sub eval-q-literal-none() { NONE; }; } if $object.is-a("Q::Literal::Bool") && $name eq "eval" { - return sub eval-q-literal-bool($runtime) { + return sub eval-q-literal-bool() { $object.properties; }; } if $object.is-a("Q::Expr::StatementListAdapter") && $name eq "eval" { - return sub eval-q-expr-statementlistadapter($runtime) { - return bound-method($object.properties, "run", $runtime)($runtime); + return sub eval-q-expr-statementlistadapter() { + return bound-method($object.properties, "run", $runtime)(); }; } @@ -1208,7 +1208,7 @@ sub internal-call(_007::Object $sub, $runtime, @arguments) is export { } $runtime.register-subhandler; my $frame = $runtime.current-frame; - my $value = bound-method($sub.properties, "run", $runtime)($runtime); + my $value = bound-method($sub.properties, "run", $runtime)(); $runtime.leave; CATCH { when X::Control::Return { diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index d81fdf4e..b21d8f44 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -95,8 +95,8 @@ class _007::Parser::Actions { :identifier($.ast), :expr($.ast)); - my $value = bound-method($.ast, "eval", $*runtime)($*runtime); - bound-method($.ast, "put-value", $*runtime)($value, $*runtime); + my $value = bound-method($.ast, "eval", $*runtime)(); + bound-method($.ast, "put-value", $*runtime)($value); } method statement:expr ($/) { @@ -200,7 +200,7 @@ class _007::Parser::Actions { die "Unknown routine type $"; # XXX: Turn this into an X:: exception } - bound-method($identifier, "put-value", $*runtime)($val, $*runtime); + bound-method($identifier, "put-value", $*runtime)($val); maybe-install-operator($name.value, $); } @@ -244,7 +244,7 @@ class _007::Parser::Actions { make create(TYPE, :$block); my $name = $identifier.properties.value; my $val = _007::Type.new(:$name); - bound-method($identifier, "put-value", $*runtime)($val, $*runtime); + bound-method($identifier, "put-value", $*runtime)($val); } method traitlist($/) { @@ -651,7 +651,7 @@ class _007::Parser::Actions { 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, $*runtime); + bound-method($.ast, "put-value", $*runtime)($val); } self.finish-block($block); diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index db8c1e7e..df3b81f9 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -25,7 +25,7 @@ class _007::Runtime { } method run(_007::Object $compunit) { - bound-method($compunit, "run", self)(self); + bound-method($compunit, "run", self)(); CATCH { when X::Control::Return { die X::ControlFlow::Return.new; From 7d53b564af65f69ee86f9487a75c640568e521ff Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 09:04:37 +0200 Subject: [PATCH 77/91] Document .size() and .keys() on Dict --- lib/_007/Type.pm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index fa005b1c..aa8182e7 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -317,6 +317,12 @@ TYPE = _007::Type.new(:name); ### ### 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 From 8bee671dd39d24d7c16e3cdcadd7361d2dbf990d Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 09:26:25 +0200 Subject: [PATCH 78/91] get rid of _007::Object::Enum --- lib/_007/Object.pm | 14 +++++--------- lib/_007/Type.pm | 4 ++-- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 69a9e19b..77875e98 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -155,21 +155,17 @@ sub create(_007::Type $type, *%properties) is export { return _007::Object.new(:$type, :%properties); } -class _007::Object::Enum is _007::Object { - has Str $.name; -} - class _007::Object::Wrapped is _007::Object { has $.value; } -constant NONE is export = _007::Object::Enum.new(:type(TYPE), :name); +constant NONE is export = create(TYPE, :name(_007::Object::Wrapped.new(:type(TYPE), :value("None")))); # Now we can install NONE into TYPE.base TYPE.install-base(NONE); -constant TRUE is export = _007::Object::Enum.new(:type(TYPE), :name); -constant FALSE is export = _007::Object::Enum.new(:type(TYPE), :name); +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) } @@ -734,13 +730,13 @@ sub bound-method($object, $name, $runtime) is export { if $object.is-a("Bool") && $name eq "Str" { return sub str-bool() { - return wrap($object.name); + return $object.properties; } } if $object.is-a("NoneType") && $name eq "Str" { return sub str-nonetype() { - return wrap($object.name); + return $object.properties; } } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index aa8182e7..9ee9452d 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -133,7 +133,7 @@ BEGIN { ### say(None // "default"); # --> `default` ### say("value" // "default"); # --> `value` ### - TYPE = _007::Type.new(:name); + TYPE = _007::Type.new(:name, :fields["name"]); ### ### Bool ### @@ -178,7 +178,7 @@ BEGIN { ### say(None && "!"); # --> `None` ### say(None || "!"); # --> `!` ### - TYPE = _007::Type.new(:name); + TYPE = _007::Type.new(:name, :fields["name"]); } ### ### Int From b69ad140ae777ae01235ae20c9cdff5ebf486d7a Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 15:45:56 +0200 Subject: [PATCH 79/91] Make fields hashes, not just strings So we can fill them with name, type, and (later) whether they're optional, or have an initializer. All this is going to feed back into class declarations later, and make them a lot simpler to set up. --- lib/_007/Builtins.pm | 6 +- lib/_007/Object.pm | 13 +- lib/_007/Parser/Actions.pm | 2 +- lib/_007/Test.pm | 2 +- lib/_007/Type.pm | 407 ++++++++++++++++++++++++++++++++----- 5 files changed, 371 insertions(+), 59 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index ffa79483..54992fcb 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -56,7 +56,7 @@ sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { } [&&] $l.type === $r.type, - |$l.type.type-chain.reverse.map({ .fields }).flat.grep({ $_ ne "frame" }).map(&same-propvalue); + |$l.type.type-chain.reverse.map({ .fields }).flat.map({ . }).grep({ $_ ne "frame" }).map(&same-propvalue); } else { die "Unknown type ", $l.type.^name; @@ -399,7 +399,7 @@ sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { or die "This shouldn't be an op"; my $type = ~$0; my $opname = ~$1; - my %properties = hash($placeholder.qtype.type-chain.reverse.map({ .fields }).flat.map({ $_ => NONE })); + 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; @@ -428,7 +428,7 @@ sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { when .value ~~ Placeholder::MacroOp { my $name = .key; install-op($name, .value); - my @elements = .value.qtype.fields.grep({ $_ ne "identifier" })».¶meter; + my @elements = .value.qtype.fields.map({ . }).grep({ $_ ne "identifier" })».¶meter; my $parameters = wrap(@elements); my $parameterlist = create(TYPE, :$parameters); my $statementlist = create(TYPE, :statements(wrap([]))); diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 77875e98..a0ad91ff 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -130,7 +130,7 @@ sub create(_007::Type $type, *%properties) is export { ); } - my $fields = set($type.type-chain.map({ .fields })); + my $fields = set($type.type-chain.map({ .fields }).flat.map({ . })); my $seen = set(); for %properties.keys.sort -> $property { die X::Property::NotDeclared.new(:type($type.name), :$property) @@ -419,7 +419,7 @@ sub bound-method($object, $name, $runtime) is export { 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; + 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); @@ -815,7 +815,7 @@ sub bound-method($object, $name, $runtime) is export { if $object.is-a("Q") && $name eq "Str" { return sub str-q() { - my @props = $object.type.type-chain.reverse.map({ .fields }).flat; + 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") && @@ -1109,8 +1109,9 @@ sub bound-method($object, $name, $runtime) is export { return $thing if $thing.is-a("Q::Unquote"); - my %properties = $thing.type.type-chain.reverse.map({ .fields }).flat.map: -> $fieldname { - $fieldname => interpolate($thing.properties{$fieldname}) + my %properties = $thing.type.type-chain.reverse.map({ .fields }).flat.map: -> $field { + my $fieldname = $field; + $fieldname => interpolate($thing.properties{$fieldname}); }; create($thing.type, |%properties); @@ -1122,7 +1123,7 @@ sub bound-method($object, $name, $runtime) is export { } if $object.is-a("Type") && $name eq "create" { - return sub create($properties) { + 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); diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index b21d8f44..69b04613 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -673,7 +673,7 @@ class _007::Parser::Actions { my $type = $.ast.properties.value; my $type-obj = $*runtime.get-var($type); - my $known-properties = set($type-obj.type-chain.reverse.map({ .fields }).flat); + my $known-properties = set($type-obj.type-chain.reverse.map({ .fields }).flat.map({ . })); my $seen-properties = set(); for $.ast.properties.value -> $p { my $property = $p.properties.value; diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 6c2c8d89..295d704c 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -105,7 +105,7 @@ sub read(Str $ast) is export { my @rest = $».ast[1..*]; my $qtype = %q_lookup{$qname}; my %arguments; - my @attributes = $qtype.type-chain.reverse.map({ .fields }).flat; + 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 diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 9ee9452d..15597c1a 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -93,7 +93,12 @@ BEGIN { ### say(type(q) == Q::Literal::Str); # --> `True` ### say(type(q) == Q::Literal); # --> `False` ### - TYPE = _007::Type.new(:name, :fields["name"]); + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); ### ### NoneType ### @@ -133,7 +138,12 @@ BEGIN { ### say(None // "default"); # --> `default` ### say("value" // "default"); # --> `value` ### - TYPE = _007::Type.new(:name, :fields["name"]); + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); ### ### Bool ### @@ -178,7 +188,12 @@ BEGIN { ### say(None && "!"); # --> `None` ### say(None || "!"); # --> `!` ### - TYPE = _007::Type.new(:name, :fields["name"]); + TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], + ); } ### ### Int @@ -330,7 +345,12 @@ TYPE = _007::Type.new(:name); ### An exception. Represents an error condition, or some other way control ### flow couldn't continue normally. ### -TYPE = _007::Type.new(:name, :fields["message"]); +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], +); ### ### Sub ### @@ -350,7 +370,16 @@ TYPE = _007::Type.new(:name, :fields["message"]); ### } ### say(add(2, 5)); # --> `7` ### -TYPE = _007::Type.new(:name, :fields["name", "parameterlist", "statementlist", "static-lexpad", "outer-frame"]); +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + { :name, :type }, # XXX: add an initializer + { :name, :type }, # XXX: make optional + ], +); ### ### Macro ### @@ -379,7 +408,12 @@ TYPE = _007::Type.new(:name, :base(TYPE)); ### say(/"Bond"/.fullmatch("J. Bond")); # --> `False` ### say(/"Bond"/.search("J. Bond")); # --> `True` ### -TYPE = _007::Type.new(:name, :fields["contents"]); +TYPE = _007::Type.new( + :name, + :fields[ + { :name, :type }, + ], +); ### ### Q ### @@ -421,7 +455,13 @@ TYPE = _007::Type.new(:name, :base(TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Literal::Int ### @@ -430,13 +470,25 @@ TYPE = _007::Type.new(:name, :base(TYPE` containing a literal `5`. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Literal::Str ### ### A string literal. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["value"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Identifier ### @@ -445,40 +497,79 @@ TYPE = _007::Type.new(:name, :base(TYPE = _007::Type.new(:name, :base(TYPE), :fields["name", "frame"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, # XXX: make optional + ], +); ### ### Q::Term::Regex ### ### A regular expression (*regex*). ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["contents"]); +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["elements"]); +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["propertylist"]); +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["type", "propertylist"]); +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["key", "value"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::PropertyList ### @@ -486,26 +577,53 @@ TYPE = _007::Type.new(:name, :base(TYPE), :fields[" ### 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["properties"]); +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["identifier", "expr"]); +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["traits"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Term::Sub ### ### A subroutine. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "traitlist", "block"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, # XXX: give initializer + { :name, :type }, + ], +); ### ### Q::Block ### @@ -517,14 +635,29 @@ TYPE = _007::Type.new(:name, :base(TYPE), : ### A block has a parameter list and a statement list, each of which can ### be empty. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["parameterlist", "statementlist", "static-lexpad"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, # XXX: give initializer + ], +); ### ### Q::Prefix ### ### A prefix operator; an operator that occurs before a term, like the ### `-` in `-5`. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::Prefix::Str ### @@ -568,7 +701,15 @@ TYPE = _007::Type.new(:name, :base(TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "lhs", "rhs"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::Infix::Addition ### @@ -713,44 +854,89 @@ TYPE = _007::Type.new(:name, :ba ### A postfix operator; something like the `[0]` in `agents[0]` that occurs ### after a term. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "operand"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); ### ### 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["index"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Postfix::Call ### ### An invocation operator; calls a routine. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["argumentlist"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Postfix::Property ### ### An object property operator; fetches a property out of an object. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["property"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Unquote ### ### An unquote; allows Qtree fragments to be inserted into places in a quasi. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "expr"]); +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["operand"]); +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["lhs", "rhs"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::Term::Quasi ### @@ -763,26 +949,51 @@ TYPE = _007::Type.new(:name, :base(TYPE = _007::Type.new(:name, :base(TYPE), :fields["qtype", "contents"]); +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["identifier"]); +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["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["arguments"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Statement ### @@ -794,31 +1005,65 @@ TYPE = _007::Type.new(:name, :base(TYPE), :is-abs ### ### A `my` variable declaration statement. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::Statement::Constant ### ### A `constant` declaration statement. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["identifier", "expr"]); +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["expr"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Statement::If ### ### An `if` statement. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block", "else"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + { :name, :type }, + { :name, :type }, + ], +); ### ### Q::Statement::Block ### ### A block statement. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["block"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::CompUnit ### @@ -831,49 +1076,103 @@ TYPE = _007::Type.new(:name, :base(TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr", "block"]); +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["expr", "block"]); +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["expr"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, # XXX: make optional + ], +); ### ### Q::Statement::Throw ### ### A `throw` statement. ### -TYPE = _007::Type.new(:name, :base(TYPE), :fields["expr"]); +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["identifier", "traitlist", "block"]); +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["identifier", "traitlist", "block"]); +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["block"]); +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["block"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::StatementList ### @@ -882,7 +1181,13 @@ TYPE = _007::Type.new(:name, :base(TYP ### 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["statements"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); ### ### Q::Expr::StatementListAdapter ### @@ -898,4 +1203,10 @@ TYPE = _007::Type.new(:name, :base(TYPE), ### 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["statementlist"]); +TYPE = _007::Type.new( + :name, + :base(TYPE), + :fields[ + { :name, :type }, + ], +); From 5dc3031f54c73219241f92a942efe56eefd87e4c Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 15:59:31 +0200 Subject: [PATCH 80/91] Give Type a $.type Since it's supposed to be a subtype of Object, it needs to have a $.type. This will only ever start to matter once someone starts subtyping the Type hierarchy... but then it'll matter big time. --- lib/_007/Type.pm | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 15597c1a..b13c4a69 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -5,6 +5,7 @@ constant TYPE = hash(); class _007::Type { has Str $.name; has $.base = TYPE; + has $.type = TYPE; has @.fields; has Bool $.is-abstract = False; # XXX: $.id @@ -13,6 +14,10 @@ class _007::Type { $!base = $none; } + method install-type($type) { + $!type = $type; + } + method type-chain() { my @chain; my $t = self; @@ -23,15 +28,11 @@ class _007::Type { return @chain; } - method type { - TYPE; - } - multi method is-a(Str $typename) { self.is-a(TYPE{$typename}); } multi method is-a(_007::Type $type) { - ($type === TYPE || $type === TYPE) && self; + $type (elem) $.type.type-chain && self; } } @@ -99,6 +100,7 @@ BEGIN { { :name, :type }, ], ); + TYPE.install-type(TYPE); ### ### NoneType ### From 7184e0854114a6d9ff628c218dab8f53a5256ba7 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 16:08:33 +0200 Subject: [PATCH 81/91] Extract common role --- lib/_007/Object.pm | 21 +-------------------- lib/_007/Type.pm | 42 +++++++++++++++++++++++++++++------------- 2 files changed, 30 insertions(+), 33 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index a0ad91ff..1d3ad44f 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -88,28 +88,9 @@ class X::Regex::InvalidMatchType is Exception { method message { "A regex can only match strings" } } -class _007::Object { - has $.type; +class _007::Object does Typable { has $.id = unique-id; has %.properties; - - 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; - } } sub create(_007::Type $type, *%properties) is export { diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index b13c4a69..5ebad870 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -2,10 +2,37 @@ sub unique-id is export { ++$ } constant TYPE = hash(); -class _007::Type { +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 $.type = TYPE; has @.fields; has Bool $.is-abstract = False; # XXX: $.id @@ -14,10 +41,6 @@ class _007::Type { $!base = $none; } - method install-type($type) { - $!type = $type; - } - method type-chain() { my @chain; my $t = self; @@ -27,13 +50,6 @@ class _007::Type { } return @chain; } - - multi method is-a(Str $typename) { - self.is-a(TYPE{$typename}); - } - multi method is-a(_007::Type $type) { - $type (elem) $.type.type-chain && self; - } } BEGIN { From c6fb067d53d25ce2dc06f543afe591ca6b780694 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 17:09:49 +0200 Subject: [PATCH 82/91] Typecheck during object creation --- lib/_007/Object.pm | 12 +++++++++--- lib/_007/Type.pm | 44 ++++++++++++++++++++++---------------------- 2 files changed, 31 insertions(+), 25 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 1d3ad44f..20ab825e 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -111,22 +111,28 @@ sub create(_007::Type $type, *%properties) is export { ); } - my $fields = set($type.type-chain.map({ .fields }).flat.map({ . })); + my %fields = $type.type-chain.map({ .fields }).flat.map({ . => $_ }); my $seen = set(); for %properties.keys.sort -> $property { die X::Property::NotDeclared.new(:type($type.name), :$property) - unless $property (elem) $fields; + unless %fields{$property}; die X::Property::Duplicate.new(:type($type.name), :$property) if $property (elem) $seen; $seen (|)= $property; + + my $value = %properties{$property}; + my $fieldtype = TYPE{%fields{$property}} + or die "No such type {%fields{$property}}"; + die X::Type.new(:operation("instantiation of {$type.name} with property $property"), :got($value), :expected($fieldtype)) + unless $value.is-a($fieldtype); } # XXX: need to screen for required properties by traversing @.fields, but we don't have the # infrastructure in terms of a way to mark up a field as required # XXX: for now, let's pretend all properties are required. not pleasant, but we can live with it for a short time - for $fields.keys -> $field { + for %fields.keys -> $field { die "Need to pass property '$field' when creating a {$type.name}" unless $field (elem) $seen; } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 5ebad870..7c8ccfd0 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -451,7 +451,7 @@ TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); ### 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); +TYPE = _007::Type.new(:name, :base(TYPE), :is-abstract); ### ### Q::Literal ### @@ -477,7 +477,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, ], ); @@ -517,10 +517,10 @@ TYPE = _007::Type.new( ### TYPE = _007::Type.new( :name, - :base(TYPE), + :base(TYPE), :fields[ { :name, :type }, - { :name, :type }, # XXX: make optional + { :name, :type }, # XXX: make optional ], ); @@ -571,7 +571,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, { :name, :type }, ], ); @@ -625,7 +625,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, ], ); @@ -637,7 +637,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, # XXX: make optional { :name, :type }, # XXX: give initializer { :name, :type }, ], @@ -659,7 +659,7 @@ TYPE = _007::Type.new( :fields[ { :name, :type }, { :name, :type }, - { :name, :type }, # XXX: give initializer + { :name, :type }, # XXX: make optional ], ); @@ -672,8 +672,8 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, + { :name, :type }, + { :name, :type }, ], ); @@ -723,9 +723,9 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, - { :name, :type }, + { :name, :type }, + { :name, :type }, + { :name, :type }, ], ); @@ -876,8 +876,8 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, + { :name, :type }, + { :name, :type }, ], ); @@ -890,7 +890,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, ], ); @@ -902,7 +902,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, ], ); @@ -914,7 +914,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, ], ); @@ -926,7 +926,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, { :name, :type }, ], ); @@ -971,7 +971,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type }, { :name, :type }, ], ); @@ -1028,7 +1028,7 @@ TYPE = _007::Type.new( :base(TYPE), :fields[ { :name, :type }, - { :name, :type }, + { :name, :type }, # XXX: make optional ], ); @@ -1124,7 +1124,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, # XXX: make optional + { :name, :type }, # XXX: make optional ], ); From da446641ab1ac85fe3c2fd87264497bea9a2dc18 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 20 Sep 2017 17:47:54 +0200 Subject: [PATCH 83/91] Allow checking of type unions An interesting thing with Q::Unquote showed up on the way. Will think about that a bit and handle it more properly later. --- lib/_007/Object.pm | 17 +++++++++++++---- lib/_007/Type.pm | 32 ++++++++++++++++---------------- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 20ab825e..2d58cd28 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -113,6 +113,7 @@ sub create(_007::Type $type, *%properties) is export { 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}; @@ -123,10 +124,18 @@ sub create(_007::Type $type, *%properties) is export { $seen (|)= $property; my $value = %properties{$property}; - my $fieldtype = TYPE{%fields{$property}} - or die "No such type {%fields{$property}}"; - die X::Type.new(:operation("instantiation of {$type.name} with property $property"), :got($value), :expected($fieldtype)) - unless $value.is-a($fieldtype); + my $type-union = %fields{$property}; + for $type-union.split(/ \h* "|" \h* /) -> $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))), + ); } # XXX: need to screen for required properties by traversing @.fields, but we don't have the # infrastructure in terms of a way to mark up a field as required diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 7c8ccfd0..d1480ca4 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -520,7 +520,7 @@ TYPE = _007::Type.new( :base(TYPE), :fields[ { :name, :type }, - { :name, :type }, # XXX: make optional + { :name, :type("Dict | NoneType") }, # XXX: make optional ], ); @@ -637,7 +637,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, # XXX: make optional + { :name, :type("Q::Identifier | NoneType") }, # XXX: make optional { :name, :type }, # XXX: give initializer { :name, :type }, ], @@ -659,7 +659,7 @@ TYPE = _007::Type.new( :fields[ { :name, :type }, { :name, :type }, - { :name, :type }, # XXX: make optional + { :name, :type("Dict | NoneType") }, # XXX: make optional ], ); @@ -672,8 +672,8 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, ], ); @@ -723,9 +723,9 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, - { :name, :type }, + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, + { :name, :type("Q::Expr | NoneType") }, ], ); @@ -876,8 +876,8 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, - { :name, :type }, + { :name, :type("Q::Identifier | NoneType") }, + { :name, :type("Q::Expr | Q::Unquote | NoneType") }, # XXX: Q::Unquote needs mulling over ], ); @@ -890,7 +890,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type("Q::Expr | NoneType") }, ], ); @@ -902,7 +902,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type("Q::ArgumentList | Q::Unquote | NoneType") }, # XXX: Q::Unquote needs mulling over ], ); @@ -914,7 +914,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, + { :name, :type("Q::Expr | NoneType") }, ], ); @@ -1028,7 +1028,7 @@ TYPE = _007::Type.new( :base(TYPE), :fields[ { :name, :type }, - { :name, :type }, # XXX: make optional + { :name, :type("Q::Expr | NoneType") }, # XXX: make optional ], ); @@ -1067,7 +1067,7 @@ TYPE = _007::Type.new( :fields[ { :name, :type }, { :name, :type }, - { :name, :type }, + { :name, :type("Q::Block | Q::Statement::If | NoneType") }, ], ); @@ -1124,7 +1124,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type }, # XXX: make optional + { :name, :type("Q::Expr | NoneType") }, # XXX: make optional ], ); From d37597f5220c043524fb888b8ab022dd815868a8 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 21 Sep 2017 16:13:42 +0200 Subject: [PATCH 84/91] Lift some common code into wrap-fn --- lib/_007/Builtins.pm | 18 +++--------------- lib/_007/Object.pm | 30 ++++++++++++++---------------- 2 files changed, 17 insertions(+), 31 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 54992fcb..618d615a 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -419,30 +419,18 @@ sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { .key => .value; } when .value ~~ Block { - my @elements = .value.signature.params».name».&ditch-sigil».¶meter; - my $parameters = wrap(@elements); - my $parameterlist = create(TYPE, :$parameters); - my $statementlist = create(TYPE, :statements(wrap([]))); - .key => wrap-fn(.value, .key, $parameterlist, $statementlist); + .key => wrap-fn(.value, .key); } when .value ~~ Placeholder::MacroOp { my $name = .key; install-op($name, .value); - my @elements = .value.qtype.fields.map({ . }).grep({ $_ ne "identifier" })».¶meter; - my $parameters = wrap(@elements); - my $parameterlist = create(TYPE, :$parameters); - my $statementlist = create(TYPE, :statements(wrap([]))); - .key => wrap-fn(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 $parameters = wrap(@elements); - my $parameterlist = create(TYPE, :$parameters); - my $statementlist = create(TYPE, :statements(wrap([]))); - .key => wrap-fn(&fn, $name, $parameterlist, $statementlist); + .key => wrap-fn(&fn, $name); } default { die "Unknown type {.value.^name}" } }; diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 2d58cd28..4ee3a3a5 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -426,21 +426,7 @@ sub bound-method($object, $name, $runtime) is export { # XXX: don't want to do it like this # think I want a BoundMethod type instead my &fn = bound-method($obj, $propname, $runtime); - my $name = &fn.name; - my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { - create(TYPE, - :identifier(create(TYPE, - :name(wrap($^value)) - :frame(NONE)) - ) - ) - }; - my @elements = &fn.signature.params».name».&ditch-sigil».¶meter; - my $parameters = wrap(@elements); - my $parameterlist = create(TYPE, :$parameters); - my $statementlist = create(TYPE, :statements(wrap([]))); - return wrap-fn(&fn, $name, $parameterlist, $statementlist); + return wrap-fn(&fn); } }; } @@ -1170,7 +1156,19 @@ sub wrap($value) is export { } } -sub wrap-fn(&value, Str $name, $parameterlist, $statementlist) is export { +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)) + :frame(NONE)) + ) + ) + }; + 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, From 819aaaafc72ff66a9c5fbff82474130868a0f79d Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Thu, 21 Sep 2017 16:29:00 +0200 Subject: [PATCH 85/91] Comment &wrap, internally documenting it --- lib/_007/Object.pm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 4ee3a3a5..968e8941 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -1132,6 +1132,12 @@ sub bound-method($object, $name, $runtime) is export { 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; From a2b153a8d443782767acd80d2ce1f040b8780c45 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Mon, 2 Oct 2017 10:04:03 +0200 Subject: [PATCH 86/91] Allow fields to be optional --- lib/_007/Object.pm | 19 +++++++++++-------- lib/_007/Parser/Actions.pm | 9 +++++---- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 968e8941..3c8556b7 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -125,7 +125,11 @@ sub create(_007::Type $type, *%properties) is export { my $value = %properties{$property}; my $type-union = %fields{$property}; - for $type-union.split(/ \h* "|" \h* /) -> $fieldtypename { + 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 @@ -134,16 +138,15 @@ sub create(_007::Type $type, *%properties) is export { die X::Type.new( :operation("instantiation of {$type.name} with property $property"), :got($value), - :expected(_007::Type.new(:name($type-union))), + :expected(_007::Type.new(:name(@type-union.join(" | ")))), ); } - # XXX: need to screen for required properties by traversing @.fields, but we don't have the - # infrastructure in terms of a way to mark up a field as required - # XXX: for now, let's pretend all properties are required. not pleasant, but we can live with it for a short time - for %fields.keys -> $field { - die "Need to pass property '$field' when creating a {$type.name}" - unless $field (elem) $seen; + for %fields.kv -> $name, $field { + next if $field; + + die "Need to pass property '$name' when creating a {$type.name}" + unless $name (elem) $seen; } # XXX: ditto for property default values diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 69b04613..2f3cd5c9 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -673,19 +673,20 @@ class _007::Parser::Actions { my $type = $.ast.properties.value; my $type-obj = $*runtime.get-var($type); - my $known-properties = set($type-obj.type-chain.reverse.map({ .fields }).flat.map({ . })); + 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; + unless $property (elem) @known-properties.map({ . }); $seen-properties (|)= $property; } - for $known-properties.keys -> $property { - # XXX: once we handle optional properties, we will `next` here + for @known-properties -> $p { + next if $p; + my $property = $p; die X::Property::Required.new(:$type, :$property) unless $property (elem) $seen-properties; } From 311cff92eb47644db9684677e3761816e61f052c Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 7 Oct 2017 21:59:23 +0200 Subject: [PATCH 87/91] Make Q::Identifier's .frame field optional --- lib/_007/Builtins.pm | 7 +------ lib/_007/Object.pm | 22 ++++++++++------------ lib/_007/OpScope.pm | 5 +---- lib/_007/Parser/Actions.pm | 11 ++++------- lib/_007/Runtime.pm | 12 +++--------- lib/_007/Test.pm | 7 ++----- lib/_007/Type.pm | 2 +- self-host/runtime.007 | 5 +---- t/features/builtins/methods.t | 3 +-- t/features/builtins/operators.t | 8 +++----- t/features/macros.t | 6 ++---- t/features/objects.t | 12 ++---------- t/features/q.t | 9 +++------ t/features/unhygienic-declarations.t | 5 +---- 14 files changed, 35 insertions(+), 79 deletions(-) diff --git a/lib/_007/Builtins.pm b/lib/_007/Builtins.pm index 618d615a..dad4d3e7 100644 --- a/lib/_007/Builtins.pm +++ b/lib/_007/Builtins.pm @@ -407,12 +407,7 @@ sub builtins(:$input!, :$output!, :$opscope!, :$runtime) is export { } my &ditch-sigil = { $^str.substr(1) }; - my ¶meter = { - create(TYPE, :identifier(create(TYPE, - :name(wrap($^value)), - :frame(NONE), - ))) - }; + my ¶meter = { create(TYPE, :identifier(create(TYPE, :name(wrap($^value))))) }; return @builtins.map: { when .value ~~ _007::Type { diff --git a/lib/_007/Object.pm b/lib/_007/Object.pm index 3c8556b7..e87fd8a5 100644 --- a/lib/_007/Object.pm +++ b/lib/_007/Object.pm @@ -143,10 +143,14 @@ sub create(_007::Type $type, *%properties) is export { } for %fields.kv -> $name, $field { - next if $field; + next if $name (elem) $seen; - die "Need to pass property '$name' when creating a {$type.name}" - unless $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 @@ -159,6 +163,7 @@ class _007::Object::Wrapped is _007::Object { } 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); @@ -1088,7 +1093,7 @@ sub bound-method($object, $name, $runtime) is export { return wrap(hash($thing.value.map(&interpolate-entry))) if $thing.is-a("Dict"); - return create($thing.type, :name($thing.properties), :frame(NONE)) + return create($thing.type, :name($thing.properties)) if $thing.is-a("Q::Identifier"); return $thing @@ -1167,14 +1172,7 @@ sub wrap($value) is export { 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)) - :frame(NONE)) - ) - ) - }; + 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([]))); diff --git a/lib/_007/OpScope.pm b/lib/_007/OpScope.pm index 4ebcafdb..3bef5af5 100644 --- a/lib/_007/OpScope.pm +++ b/lib/_007/OpScope.pm @@ -19,10 +19,7 @@ class _007::OpScope { method install($type, $op, $q?, :%precedence, :$assoc) { my $name = "$type:$op"; - my $identifier = create(TYPE, - :name(wrap($name)), - :frame(NONE), - ); + my $identifier = create(TYPE, :name(wrap($name))); %!ops{$type}{$op} = $q !=== Any ?? $q !! { prefix => create(TYPE, :$identifier, :operand(NONE)), diff --git a/lib/_007/Parser/Actions.pm b/lib/_007/Parser/Actions.pm index 2f3cd5c9..3234f74d 100644 --- a/lib/_007/Parser/Actions.pm +++ b/lib/_007/Parser/Actions.pm @@ -657,7 +657,7 @@ class _007::Parser::Actions { my $name = $ && $.ast.properties; my $identifier = $ - ?? create(TYPE, :$name, :frame(NONE)) + ?? create(TYPE, :$name) !! NONE; make create(TYPE, :$identifier, :$traitlist, :$block); } @@ -693,10 +693,7 @@ class _007::Parser::Actions { make create(TYPE, # XXX: couldn't we just pass $type here? - :type(create(TYPE, - :name(wrap($type)), - :frame(NONE), - )), + :type(create(TYPE, :name(wrap($type)))), :propertylist($.ast)); } @@ -738,7 +735,7 @@ class _007::Parser::Actions { :static-lexpad(wrap({})), ); my $name = $.ast.properties; - my $identifier = create(TYPE, :$name, :frame(NONE)); + my $identifier = create(TYPE, :$name); make create(TYPE, :key($name), :value(create(TYPE, @@ -810,7 +807,7 @@ class _007::Parser::Actions { $value ~~ s:g['\\\\'] = '\\'; }(); my $name = wrap($value); - make create(TYPE, :$name, :frame(NONE)); + make create(TYPE, :$name); } method argumentlist($/) { diff --git a/lib/_007/Runtime.pm b/lib/_007/Runtime.pm index df3b81f9..b73a75bf 100644 --- a/lib/_007/Runtime.pm +++ b/lib/_007/Runtime.pm @@ -4,9 +4,7 @@ use _007::Builtins; use _007::OpScope; constant NO_OUTER = wrap({}); -constant RETURN_TO = create(TYPE, - :name(wrap("--RETURN-TO--")), - :frame(NONE)); +constant RETURN_TO = create(TYPE, :name(wrap("--RETURN-TO--"))); class _007::Runtime { has $.input; @@ -40,9 +38,7 @@ class _007::Runtime { }); @!frames.push($frame); for $static-lexpad.value.kv -> $name, $value { - my $identifier = create(TYPE, - :name(wrap($name)), - :frame(NONE)); + my $identifier = create(TYPE, :name(wrap($name))); self.declare-var($identifier, $value); } for $statementlist.properties.value.kv -> $i, $_ { @@ -144,9 +140,7 @@ class _007::Runtime { method load-builtins { my $opscope = $!builtin-opscope; for builtins(:$.input, :$.output, :$opscope, :runtime(self)) -> Pair (:key($name), :$value) { - my $identifier = create(TYPE, - :name(wrap($name)), - :frame(NONE)); + my $identifier = create(TYPE, :name(wrap($name))); self.declare-var($identifier, $value); } } diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 295d704c..7e876248 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -9,7 +9,7 @@ use Test; sub read(Str $ast) is export { sub n($type, $op) { my $name = wrap($type ~ ":<$op>"); - return create(TYPE, :$name, :frame(NONE)); + return create(TYPE, :$name); } my %q_lookup = @@ -110,7 +110,7 @@ sub read(Str $ast) is export { if $qname ~~ /^ [prefix | infix | postfix] ":"/ { # XXX: it stinks that we have to do this my $name = wrap($qname); - %arguments = create(TYPE, :$name, :frame(NONE)); + %arguments = create(TYPE, :$name); shift @attributes; # $.identifier } }(); @@ -136,9 +136,6 @@ sub read(Str $ast) is export { } } # XXX: these exceptions can go away once we support initializers - if $qtype === TYPE { - %arguments //= NONE; - } if $qtype === TYPE { %arguments //= wrap({}); } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index d1480ca4..97124f7e 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -520,7 +520,7 @@ TYPE = _007::Type.new( :base(TYPE), :fields[ { :name, :type }, - { :name, :type("Dict | NoneType") }, # XXX: make optional + { :name, :type("Dict"), :optional }, ], ); diff --git a/self-host/runtime.007 b/self-host/runtime.007 index 00e95e85..de2d588e 100644 --- a/self-host/runtime.007 +++ b/self-host/runtime.007 @@ -23,10 +23,7 @@ my Runtime = { frames.push(frame); for static_lexpad.keys() -> name { my value = static_lexpad[name]; - my identifier = new Q::Identifier { - name, - frame: None, - }; + my identifier = new Q::Identifier { name }; declare_var(identifier, value); } } diff --git a/t/features/builtins/methods.t b/t/features/builtins/methods.t index c5bcb6ef..0db74a87 100644 --- a/t/features/builtins/methods.t +++ b/t/features/builtins/methods.t @@ -402,8 +402,7 @@ use _007::Test; { my $program = q:to/./; - # XXX: can remove this "frame" prop once we have property initializers - say(Q::Identifier.create([["name", "Steve"], ["frame", None]])); + say(Q::Identifier.create([["name", "Steve"]])); . outputs $program, qq[Q::Identifier "Steve"\n], "Type.create() method to create a Q::Identifier"; diff --git a/t/features/builtins/operators.t b/t/features/builtins/operators.t index 1c8f825a..27181e01 100644 --- a/t/features/builtins/operators.t +++ b/t/features/builtins/operators.t @@ -348,8 +348,7 @@ use _007::Test; outputs 'macro foo() {}; say(foo == foo)', "True\n", "a macro is equal to itself"; outputs 'say(say == say)', "True\n", "a built-in sub is equal to itself"; outputs 'say(infix:<+> == infix:<+>)', "True\n", "a built-in operator is equal to itself"; - # XXX: can skip `frame` prop once initializers exist - outputs 'say(new Q::Identifier { name: "foo", frame: None } == new Q::Identifier { name: "foo", frame: None })', "True\n", + outputs 'say(new Q::Identifier { name: "foo" } == new Q::Identifier { name: "foo" })', "True\n", "two Qtrees with equal content are equal"; outputs 'my a = []; for [1, 2] { sub fn() {}; a = [fn, a] }; say(a[1][0] == a[0])', "True\n", "the same sub from two different frames compares favorably to itself"; @@ -369,8 +368,7 @@ use _007::Test; "subs with different parameters are unequal"; outputs 'sub foo() {}; my x = foo; { sub foo() { say("OH HAI") }; say(x == foo) }', "False\n", "subs with different bodies are unequal"; - # XXX: can skip `frame` prop once initializers exist - outputs 'say(new Q::Identifier { name: "foo", frame: None } == new Q::Identifier { name: "bar", frame: None })', "False\n", + outputs 'say(new Q::Identifier { name: "foo" } == new Q::Identifier { name: "bar" })', "False\n", "two Qtrees with distinct content are unequal"; } @@ -458,7 +456,7 @@ use _007::Test; my a = [1, 2, 3]; my d = { foo: 12 }; sub f() { return 7 }; - my o = new Q::Identifier { name: "19", frame: None }; + my o = new Q::Identifier { name: "19" }; say(-a[1]); say(-d["foo"]); diff --git a/t/features/macros.t b/t/features/macros.t index c0c849b1..f2b890c9 100644 --- a/t/features/macros.t +++ b/t/features/macros.t @@ -28,10 +28,8 @@ use _007::Test; my $program = q:to/./; macro foo() { return new Q::Postfix::Call { - # XXX: can remove `frame: None` once we have property initializers - identifier: new Q::Identifier { name: "postfix:()", frame: None }, - # XXX: and here - operand: new Q::Identifier { name: "say", frame: None }, + identifier: new Q::Identifier { name: "postfix:()" }, + operand: new Q::Identifier { name: "say" }, argumentlist: new Q::ArgumentList { arguments: [new Q::Literal::Str { value: "OH HAI" }] } diff --git a/t/features/objects.t b/t/features/objects.t index f0564387..2106c8dd 100644 --- a/t/features/objects.t +++ b/t/features/objects.t @@ -4,11 +4,7 @@ use _007::Test; { my $program = q:to/./; - my q = new Q::Identifier { - name: "foo", - # XXX: can remove this later - frame: None, - }; + my q = new Q::Identifier { name: "foo" }; say(q.name); . @@ -32,11 +28,7 @@ use _007::Test; { my $program = q:to/./; - my q = new Q::Identifier { - name: "foo", - # XXX: can remove this later - frame: None, - }; + my q = new Q::Identifier { name: "foo" }; say(type(q)); . diff --git a/t/features/q.t b/t/features/q.t index 3a82c6c5..cef4c58c 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -4,9 +4,8 @@ use _007::Test; { my $program = q:to/./; - # XXX: can remove `frame: None` once we have proper initializers my q = new Q::Statement::My { - identifier: new Q::Identifier { name: "foo", frame: None }, + identifier: new Q::Identifier { name: "foo" }, # XXX: and `expr: None` too expr: None, }; @@ -61,8 +60,7 @@ use _007::Test; { my $program = q:to/./; my q = new Q::Statement::Sub { - # XXX: can remove `frame: None` once we have proper initializers - identifier: new Q::Identifier { name: "foo", frame: None }, + identifier: new Q::Identifier { name: "foo" }, block: new Q::Block { parameterlist: new Q::ParameterList { parameters: [] }, statementlist: new Q::StatementList { statements: [] }, @@ -84,8 +82,7 @@ use _007::Test; { my $program = q:to/./; my q = new Q::Statement::Macro { - # XXX: can remove `frame: None` once we have proper initializers - identifier: new Q::Identifier { name: "moo", frame: None }, + identifier: new Q::Identifier { name: "moo" }, block: new Q::Block { parameterlist: new Q::ParameterList { parameters: [] }, statementlist: new Q::StatementList { statements: [] }, diff --git a/t/features/unhygienic-declarations.t b/t/features/unhygienic-declarations.t index 49f41848..0df47c31 100644 --- a/t/features/unhygienic-declarations.t +++ b/t/features/unhygienic-declarations.t @@ -6,10 +6,7 @@ use _007::Test; my $program = q:to/./; macro moo() { return new Q::Statement::My { - identifier: new Q::Identifier { - name: "agent_name", - frame: None, - }, + identifier: new Q::Identifier { name: "agent_name" }, expr: new Q::Literal::Str { value: "James Bond" } From 31b0fe60b230f588555724bb162bc002fe0e3732 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 7 Oct 2017 22:21:27 +0200 Subject: [PATCH 88/91] Make Q::Statement::My's .expr field optional --- lib/_007/Test.pm | 3 --- lib/_007/Type.pm | 2 +- t/features/q.t | 2 -- 3 files changed, 1 insertion(+), 6 deletions(-) diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index 7e876248..e63927a2 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -144,9 +144,6 @@ sub read(Str $ast) is export { :traits(wrap([])), ); } - if $qtype === TYPE { - %arguments //= NONE; - } if $qtype === TYPE { %arguments //= NONE; } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 97124f7e..fd6ed61c 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -1028,7 +1028,7 @@ TYPE = _007::Type.new( :base(TYPE), :fields[ { :name, :type }, - { :name, :type("Q::Expr | NoneType") }, # XXX: make optional + { :name, :type("Q::Expr"), :optional }, ], ); diff --git a/t/features/q.t b/t/features/q.t index cef4c58c..13f44ded 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -6,8 +6,6 @@ use _007::Test; my $program = q:to/./; my q = new Q::Statement::My { identifier: new Q::Identifier { name: "foo" }, - # XXX: and `expr: None` too - expr: None, }; say(q.expr); . From f2f25faac9f085b7a951a723f93d9883305bfeeb Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 7 Oct 2017 22:22:05 +0200 Subject: [PATCH 89/91] Add a long-missed `new` in the tutorial --- tutorial/README.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) 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" } }; From b79e0beee369f0def116dff95165d5678a2c79b4 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 7 Oct 2017 22:37:06 +0200 Subject: [PATCH 90/91] Make Q::Statement::If's .else field optional --- lib/_007/Test.pm | 3 --- lib/_007/Type.pm | 2 +- t/features/q.t | 2 -- 3 files changed, 1 insertion(+), 6 deletions(-) diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index e63927a2..edcead69 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -144,9 +144,6 @@ sub read(Str $ast) is export { :traits(wrap([])), ); } - if $qtype === TYPE { - %arguments //= NONE; - } if $qtype === TYPE { %arguments //= NONE; } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index fd6ed61c..310573d1 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -1067,7 +1067,7 @@ TYPE = _007::Type.new( :fields[ { :name, :type }, { :name, :type }, - { :name, :type("Q::Block | Q::Statement::If | NoneType") }, + { :name, :type("Q::Block | Q::Statement::If"), :optional }, ], ); diff --git a/t/features/q.t b/t/features/q.t index 13f44ded..7b240977 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -43,8 +43,6 @@ use _007::Test; # XXX: can remove this later "static-lexpad": {}, }, - # XXX: and this - else: None, }; say(q.else); . From dd967dd1f142b4e9ab39c0383f8edc89868c6ef9 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sun, 8 Oct 2017 12:53:03 +0200 Subject: [PATCH 91/91] Make Q::Statement::Return's .expr field optional --- lib/_007/Test.pm | 3 --- lib/_007/Type.pm | 2 +- t/features/q.t | 3 +-- 3 files changed, 2 insertions(+), 6 deletions(-) diff --git a/lib/_007/Test.pm b/lib/_007/Test.pm index edcead69..2b61f936 100644 --- a/lib/_007/Test.pm +++ b/lib/_007/Test.pm @@ -144,9 +144,6 @@ sub read(Str $ast) is export { :traits(wrap([])), ); } - if $qtype === TYPE { - %arguments //= NONE; - } make create($qtype, |%arguments); } method expr:symbol ($/) { make ~$/ } diff --git a/lib/_007/Type.pm b/lib/_007/Type.pm index 310573d1..50fd8339 100644 --- a/lib/_007/Type.pm +++ b/lib/_007/Type.pm @@ -1124,7 +1124,7 @@ TYPE = _007::Type.new( :name, :base(TYPE), :fields[ - { :name, :type("Q::Expr | NoneType") }, # XXX: make optional + { :name, :type("Q::Expr"), :optional }, ], ); diff --git a/t/features/q.t b/t/features/q.t index 7b240977..f3ce23b3 100644 --- a/t/features/q.t +++ b/t/features/q.t @@ -18,8 +18,7 @@ use _007::Test; { my $program = q:to/./; - # XXX: Can remove `expr: None` once we have proper initializers - my q = new Q::Statement::Return { expr: None }; + my q = new Q::Statement::Return {}; say(q.expr); .