From a078e497ded8165b83ff1bc5e3d5e0d59fc90255 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 13 Mar 2010 16:35:08 +0100 Subject: [PATCH 1/6] [Any-str] format should be hexadecimal, not float --- src/core/Any-str.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/Any-str.pm b/src/core/Any-str.pm index 00549b433d4..a9406f87b24 100644 --- a/src/core/Any-str.pm +++ b/src/core/Any-str.pm @@ -251,7 +251,7 @@ augment class Any { } multi method Str() { - sprintf '%s<0x%f>', self.WHAT, self.WHERE; + sprintf '%s<0x%x>', self.WHAT, self.WHERE; } } From 3ddd00236bebbe1c1fad0cbd0fc80f15243cf996 Mon Sep 17 00:00:00 2001 From: Jonathan Worthington Date: Sat, 13 Mar 2010 20:41:10 +0100 Subject: [PATCH 2/6] Implement 'use MONKEY_TYPING'; augment and supersede are now forbidden without it. Infinitesimally small chance of entire works of Shakespeare being written as a side effect. --- src/Perl6/Actions.pm | 3 +++ src/Perl6/Grammar.pm | 6 +++++- src/core/traits.pm | 4 ++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm index 9336ad7963b..8dd63cec07a 100644 --- a/src/Perl6/Actions.pm +++ b/src/Perl6/Actions.pm @@ -394,6 +394,9 @@ method statement_control:sym($/) { ), ); } + elsif ~$ eq 'MONKEY_TYPING' { + $*MONKEY_TYPING := 1; + } else { need($); import($/); diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm index d7af22d226b..75faee41c12 100644 --- a/src/Perl6/Grammar.pm +++ b/src/Perl6/Grammar.pm @@ -85,7 +85,10 @@ method add_our_name($name) { method add_name($name) { if $*SCOPE eq 'augment' || $*SCOPE eq 'supersede' { unless self.is_name($name) { - pir::die("Can't $*SCOPE something that doesn't exist"); + pir::die("Can't $*SCOPE $*PKGDECL that doesn't exist"); + } + unless $*MONKEY_TYPING { + pir::die("Can't $*SCOPE $*PKGDECL $name without 'use MONKEY_TYPING'"); } } else { @@ -239,6 +242,7 @@ token comp_unit { :my %*METAOPGEN; # hash of generated metaops :my $*IN_DECL; # what declaration we're in :my $*IMPLICIT; # whether we allow an implicit param + :my $*MONKEY_TYPING := 0; # whether augment/supersede are allowed <.newpad> <.outerlex> <.finishpad> diff --git a/src/core/traits.pm b/src/core/traits.pm index 589424aa740..3585f7e1382 100644 --- a/src/core/traits.pm +++ b/src/core/traits.pm @@ -1,3 +1,7 @@ +# Need to be able to augment in the setting, and this is the first file, so we +# put this here. +use MONKEY_TYPING; + # XXX Signature is wrong really - will fix once we can parse other things. our multi trait_mod:(Mu $child, Mu $parent) { $child.^add_parent($parent); From 5ec16a7798c50b602cb810ec39336e647a0df76e Mon Sep 17 00:00:00 2001 From: Jonathan Worthington Date: Sat, 13 Mar 2010 23:27:02 +0100 Subject: [PATCH 3/6] Get several more cases of smart-matching to work again. --- src/core/Any-str.pm | 4 ++++ src/core/EnumMap.pm | 7 ++++++- src/core/Parcel.pm | 2 +- src/core/Seq.pm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 56 insertions(+), 2 deletions(-) diff --git a/src/core/Any-str.pm b/src/core/Any-str.pm index a9406f87b24..fe88534f711 100644 --- a/src/core/Any-str.pm +++ b/src/core/Any-str.pm @@ -1,4 +1,8 @@ augment class Any { + method ACCEPTS($topic) { + self === $topic + } + our Int multi method bytes() is export { pir::box__PI(pir::bytelength__IS(self)) } diff --git a/src/core/EnumMap.pm b/src/core/EnumMap.pm index 7b7ffb28851..30c6bf8b599 100644 --- a/src/core/EnumMap.pm +++ b/src/core/EnumMap.pm @@ -21,7 +21,12 @@ class EnumMap does Associative { } multi method ACCEPTS(Regex $topic) { - any(@.keys) ~~ $topic; + for @.keys -> $k { + if $topic.ACCEPTS($k) { + return True; + } + } + False } multi method ACCEPTS(%topic) { diff --git a/src/core/Parcel.pm b/src/core/Parcel.pm index 1a755a526d4..803883ff348 100644 --- a/src/core/Parcel.pm +++ b/src/core/Parcel.pm @@ -8,7 +8,7 @@ augment class Parcel { if self.elems == 0 { $x.notdef || ($x.does(::Positional) && $x == 0) } else { - die "Don't know how to smart-match against a Parcel that doesn't happen to be empty"; + self.Seq.ACCEPTS($x) } } } diff --git a/src/core/Seq.pm b/src/core/Seq.pm index ac39d164706..e7eb226f594 100644 --- a/src/core/Seq.pm +++ b/src/core/Seq.pm @@ -1,4 +1,49 @@ augment class Seq { + multi method ACCEPTS(@topic) { + my $self_it = self.iterator(); + my $topic_it = @topic.iterator(); + loop { + my $cur_self_elem = $self_it.get; + if $cur_self_elem ~~ EMPTY { last } + if $cur_self_elem ~~ Whatever { + # If we just have * left, we're done. Otherwise, we have a + # "target" to look for. + loop { + $cur_self_elem = $self_it.get; + if $cur_self_elem ~~ EMPTY { return True } + unless $cur_self_elem ~~ Whatever { + last; + } + } + + # Need to find our target in the topic, if possible. + loop { + my $cur_topic_elem = $topic_it.get; + if $cur_topic_elem ~~ EMPTY { + # Ran out before finding what we wanted. + return False; + } + elsif $cur_topic_elem === $cur_self_elem { + last; + } + } + } + else { + my $cur_topic_elem = $topic_it.get; + if $cur_topic_elem ~~ EMPTY || $cur_topic_elem !=== $cur_self_elem { + return False; + } + } + } + + # If we've nothing left to match, we're successful. + $topic_it.get ~~ EMPTY + } + + multi method ACCEPTS($topic) { + self.ACCEPTS(@($topic)) + } + method elems() { pir::set__IP(self!fill); } method Str() { From 8edd6c934d6933e320f3a5104c606e7d1037a6e4 Mon Sep 17 00:00:00 2001 From: Jonathan Worthington Date: Sat, 13 Mar 2010 23:31:51 +0100 Subject: [PATCH 4/6] Turn five more test files on again. --- t/spectest.data | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/t/spectest.data b/t/spectest.data index 2402694fd3d..23cbefaf48e 100644 --- a/t/spectest.data +++ b/t/spectest.data @@ -160,9 +160,9 @@ S03-operators/series-arity0.t S03-operators/series-arity2ormore.t S03-operators/series-simple.t S03-operators/series.t -# S03-smartmatch/any-any.t +S03-smartmatch/any-any.t # S03-smartmatch/any-array-slice.t -# S03-smartmatch/any-array.t +S03-smartmatch/any-array.t S03-smartmatch/any-bool.t S03-smartmatch/any-callable.t S03-smartmatch/any-complex.t @@ -174,18 +174,18 @@ S03-smartmatch/any-pair.t S03-smartmatch/any-str.t # S03-smartmatch/any-sub.t S03-smartmatch/any-type.t -# S03-smartmatch/array-array.t +S03-smartmatch/array-array.t S03-smartmatch/array-hash.t S03-smartmatch/disorganized.t S03-smartmatch/hash-hash.t -# S03-smartmatch/regex-hash.t +S03-smartmatch/regex-hash.t S03-smartmatch/scalar-hash.t # S03-operators/series.t # S03-operators/short-circuit.t S03-operators/spaceship-and-containers.t # S03-operators/spaceship.t S03-operators/subscript-vs-lt.t -# S03-operators/ternary.t +S03-operators/ternary.t S03-operators/so.t S03-operators/value_equivalence.t # S04-blocks-and-statements/pointy-rw.t From 04102ca84d4a5d7651ecd0c5fad01f4a0be9e854 Mon Sep 17 00:00:00 2001 From: Jonathan Worthington Date: Sun, 14 Mar 2010 00:37:48 +0100 Subject: [PATCH 5/6] Get $x.Foo::bar method syntax working again, minus a bug the version in alpha had. --- src/Perl6/Actions.pm | 24 +++++++++++++++++++++--- src/Perl6/Grammar.pm | 2 +- src/glue/dispatch.pir | 27 +++++++++++++++++++++++++++ 3 files changed, 49 insertions(+), 4 deletions(-) diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm index 8dd63cec07a..0bdb4874da0 100644 --- a/src/Perl6/Actions.pm +++ b/src/Perl6/Actions.pm @@ -1565,6 +1565,9 @@ method dotty:sym<.>($/) { make $.ast; } method dotty:sym<.*>($/) { my $past := $.ast; + unless $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' { + $/.CURSOR.panic("Can not use " ~ $.Str ~ " on a non-identifier method call"); + } $past.unshift($past.name); $past.name('!dispatch_' ~ $.Str); $past.pasttype('call'); @@ -1592,13 +1595,28 @@ method privop($/) { method methodop($/) { my $past := $ ?? $[0].ast !! PAST::Op.new( :node($/) ); - if $ { - $past.name( ~$ ); + $past.pasttype('callmethod'); + if $ { + # May just be .foo, but could also be .Foo::bar + my @parts := Perl6::Grammar::parse_name(~$); + my $name := @parts.pop; + if +@parts { + $past.unshift(PAST::Var.new( + :name(@parts.pop), + :namespace(@parts), + :scope('package') + )); + $past.unshift($name); + $past.name('!dispatch_::'); + $past.pasttype('call'); + } + else { + $past.name( $name ); + } } elsif $ { $past.name( $.ast ); } - $past.pasttype('callmethod'); make $past; } diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm index 75faee41c12..2352bb309c5 100644 --- a/src/Perl6/Grammar.pm +++ b/src/Perl6/Grammar.pm @@ -1092,7 +1092,7 @@ token privop { token methodop { [ - | + | | > [ || <.panic: "Quoted method name requires parenthesized arguments"> ] diff --git a/src/glue/dispatch.pir b/src/glue/dispatch.pir index 46d4d899ac0..549b93e5d06 100644 --- a/src/glue/dispatch.pir +++ b/src/glue/dispatch.pir @@ -258,6 +258,33 @@ there are none. .end +=item !dispatch_:: + +Helper for handling calls of the form .Foo::bar. + +=cut + +.sub '!dispatch_::' + .param pmc invocant + .param string name + .param pmc target + .param pmc pos_args :slurpy + .param pmc named_args :slurpy :named + $I0 = target.'ACCEPTS'(invocant) + unless $I0 goto not_allowed + $P0 = find_method target, name + .tailcall $P0(invocant, pos_args :flat, named_args :flat :named) + not_allowed: + $S0 = "Can not call method '" + concat $S0, name + concat $S0, "' on unrelated type '" + $S1 = target.'perl'() + concat $S0, $S1 + concat $S0, "'" + '&die'($S0) +.end + + =item !deferal_fail Used by P6invocation to help us get soft-failure semantics when no deferal From 328227447f920434edfc389adf4ed82276312032 Mon Sep 17 00:00:00 2001 From: Jonathan Worthington Date: Sun, 14 Mar 2010 00:38:02 +0100 Subject: [PATCH 6/6] Turn back on two inheritance related test files. --- t/spectest.data | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t/spectest.data b/t/spectest.data index 23cbefaf48e..9b0e7e0ec0a 100644 --- a/t/spectest.data +++ b/t/spectest.data @@ -334,7 +334,7 @@ S09-typed-arrays/hashes.t # S12-attributes/class.t S12-attributes/clone.t # S12-attributes/delegation.t -# S12-attributes/inheritance.t +S12-attributes/inheritance.t # S12-attributes/instance.t # S12-attributes/recursive.t S12-attributes/undeclared.t @@ -343,7 +343,7 @@ S12-attributes/undeclared.t S12-class/basic.t S12-class/declaration-order.t S12-class/inheritance-class-methods.t -# S12-class/inheritance.t +S12-class/inheritance.t S12-class/instantiate.t # S12-class/interface-consistency.t # S12-class/namespaced.t