Merge branch 'nom' into podparser

src/Perl6/Actions.pm

@@ -985,7 +985,7 @@ class Perl6::Actions is HLL::Actions {
     method package_declarator:sym<native>($/)  { make $<package_def>.ast; }
 
     method package_declarator:sym<trusts>($/) {
-        $/.CURSOR.panic("trusts not yet implemented");
+        $*ST.apply_trait('&trait_mod:<trusts>', $*PACKAGE, $<typename>.ast);
     }
 
     method package_declarator:sym<also>($/) {
@@ -1385,7 +1385,8 @@ class Perl6::Actions is HLL::Actions {
 
         # Install method.
         if $<longname> {
-            install_method($/, $<longname>.Str, $*SCOPE, $code, $outer);
+            install_method($/, $<longname>.Str, $*SCOPE, $code, $outer,
+                :private($<specials> && ~$<specials> eq '!'));
         }
         elsif $*MULTINESS {
             $/.CURSOR.panic('Cannot put ' ~ $*MULTINESS ~ ' on anonymous method');
@@ -1421,6 +1422,8 @@ class Perl6::Actions is HLL::Actions {
                 is_multi_invocant => 1,
                 is_method_named_slurpy => 1
             ));
+            $past[0].unshift(PAST::Var.new( :name('%_'), :scope('lexical_6model'), :isdecl(1) ));
+            $past.symbol('%_', :scope('lexical_6model'));
         }
         set_default_parameter_type(@params, 'Any');
         my $signature := create_signature_object(@params, $past);
@@ -1441,10 +1444,17 @@ class Perl6::Actions is HLL::Actions {
     }
 
     # Installs a method into the various places it needs to go.
-    sub install_method($/, $name, $scope, $code, $outer) {
+    sub install_method($/, $name, $scope, $code, $outer, :$private) {
         # Ensure that current package supports methods, and if so
         # add the method.
-        my $meta_meth := $*MULTINESS eq 'multi' ?? 'add_multi_method' !! 'add_method';
+        my $meta_meth;
+        if $private {
+            if $*MULTINESS { $/.CURSOR.panic("Private multi-methods are not supported"); }
+            $meta_meth := 'add_private_method';
+        }
+        else {
+            $meta_meth := $*MULTINESS eq 'multi' ?? 'add_multi_method' !! 'add_method';
+        }
         if $scope ne 'anon' && pir::can($*PACKAGE.HOW, $meta_meth) {
             $*ST.pkg_add_method($*PACKAGE, $meta_meth, $name, $code);
         }
@@ -2098,12 +2108,39 @@ class Perl6::Actions is HLL::Actions {
     }
 
     method privop($/) {
+        # Compiling private method calls is somewhat interesting. If it's
+        # in any way qualified, we need to ensure that the current package
+        # is trusted by the target class. Otherwise we assume that the call
+        # is to a private method in the current (non-virtual) package.
+        # XXX Optimize the case where the method is declared up front - but
+        # maybe this is for the optimizer, not for here.
+        # XXX Attribute accesses? Again, maybe for the optimizer, since it
+        # runs after CHECK time.
         my $past := $<methodop>.ast;
-        if $<methodop><quote> {
-            $past.name(PAST::Op.new( :pasttype('call'), :name('&infix:<~>'), '!', $past.name ));
+        if $<methodop><longname> {
+            my @parts   := Perl6::Grammar::parse_name(~$<methodop><longname>);
+            my $name    := @parts.pop;
+            if @parts {
+                my $methpkg := $*ST.find_symbol(@parts);
+                unless $methpkg.HOW.is_trusted($methpkg, $*PACKAGE) {
+                    $/.CURSOR.panic("Cannot call private method '$name' on package " ~
+                        $methpkg.HOW.name($methpkg) ~ " because it does not trust " ~
+                        $*PACKAGE.HOW.name($*PACKAGE));
+                }
+            }
+            else {
+                $past.unshift($*ST.get_object_sc_ref_past($*PACKAGE));
+                $past.unshift($*ST.add_constant('Str', 'str', $name));
+            }
+            $past.name('dispatch:<!>');
+        }
+        elsif $<methodop><quote> {
+            $past.unshift($*ST.get_object_sc_ref_past($*PACKAGE));
+            $past.unshift($<methodop><quote>.ast);
+            $past.name('dispatch:<!>');
         }
         else {
-            $past.name( '!' ~ $past.name );
+            $/.CURSOR.panic("Cannot use this form of method call with a private method");
         }
         make $past;
     }
@@ -3512,7 +3549,9 @@ class Perl6::Actions is HLL::Actions {
                     'handled'
                 ),
                 1
-            )
+            ),
+            PAST::Op.new( :pirop('finalize vP'),
+                PAST::Var.new( :scope('register'), :name('exception')))
         );
 
         $block.handlers.unshift(

src/Perl6/Grammar.pm

@@ -1043,8 +1043,7 @@ grammar Perl6::Grammar is HLL::Grammar {
         <sym> <package_def>
     }
     token package_declarator:sym<trusts> {
-        <sym> <.ws>
-        <module_name>
+        <sym> <.ws> <typename>
     }
     token package_declarator:sym<also> {
         <sym>:s

src/Perl6/Metamodel/BOOTSTRAP.pm

@@ -572,9 +572,16 @@ my stub Hash metaclass Perl6::Metamodel::ClassHOW { ... };
 Hash.HOW.add_parent(Hash, EnumMap);
 Hash.HOW.add_attribute(Hash, BOOTSTRAPATTR.new(:name<$!descriptor>, :type(Mu)));
 
+# class Capture {
+#     ...
+# }
+my stub Capture metaclass Perl6::Metamodel::ClassHOW { ... };
+Capture.HOW.add_parent(Capture, Any);
+
 # Configure declarative listy/hashy types.
 pir::perl6_set_types_list_array_lol__vPP(List, ListIter, Array, LoL, Parcel);
 pir::perl6_set_types_enummap_hash__vPP(EnumMap, Hash);
+pir::perl6_set_type_capture__vP(Capture);
 
 # XXX Quick and dirty Bool. Probably done by EnumHOW in the end.
 my stub Bool metaclass Perl6::Metamodel::ClassHOW { ... };
@@ -707,6 +714,7 @@ my module EXPORT {
         $?PACKAGE.WHO<LoL>       := LoL;
         $?PACKAGE.WHO<EnumMap>   := EnumMap;
         $?PACKAGE.WHO<Hash>      := Hash;
+        $?PACKAGE.WHO<Capture>   := Capture;
         $?PACKAGE.WHO<Stash>     := Stash;
         $?PACKAGE.WHO<Scalar>    := Scalar;
         $?PACKAGE.WHO<Grammar>   := Grammar;

src/Perl6/Metamodel/ClassHOW.pm

@@ -5,13 +5,15 @@ class Perl6::Metamodel::ClassHOW
     does Perl6::Metamodel::Stashing
     does Perl6::Metamodel::AttributeContainer
     does Perl6::Metamodel::MethodContainer
+    does Perl6::Metamodel::PrivateMethodContainer
     does Perl6::Metamodel::MultiMethodContainer
     does Perl6::Metamodel::RoleContainer
     does Perl6::Metamodel::MultipleInheritance
     does Perl6::Metamodel::DefaultParent
     does Perl6::Metamodel::C3MRO
     does Perl6::Metamodel::MROBasedMethodDispatch
     does Perl6::Metamodel::MROBasedTypeChecking
+    does Perl6::Metamodel::Trusting
     does Perl6::Metamodel::BUILDPLAN
     does Perl6::Metamodel::Mixins
     does Perl6::Metamodel::NonGeneric

src/Perl6/Metamodel/ConcreteRoleHOW.pm

@@ -1,6 +1,7 @@
 class Perl6::Metamodel::ConcreteRoleHOW
     does Perl6::Metamodel::Naming
     does Perl6::Metamodel::Versioning
+    does Perl6::Metamodel::PrivateMethodContainer
     does Perl6::Metamodel::MethodContainer
     does Perl6::Metamodel::MultiMethodContainer
     does Perl6::Metamodel::AttributeContainer

src/Perl6/Metamodel/ParametricRoleHOW.pm

@@ -4,6 +4,7 @@ class Perl6::Metamodel::ParametricRoleHOW
     does Perl6::Metamodel::Documenting
     does Perl6::Metamodel::Versioning
     does Perl6::Metamodel::MethodContainer
+    does Perl6::Metamodel::PrivateMethodContainer
     does Perl6::Metamodel::MultiMethodContainer
     does Perl6::Metamodel::AttributeContainer
     does Perl6::Metamodel::RoleContainer
@@ -87,6 +88,9 @@ class Perl6::Metamodel::ParametricRoleHOW
         for self.methods($obj, :local(1)) {
             $conc.HOW.add_method($conc, $_.name, $_.instantiate_generic($type_env))
         }
+        for self.private_method_table($obj) {
+            $conc.HOW.add_private_method($conc, $_.key, $_.value.instantiate_generic($type_env));
+        }
         for self.multi_methods_to_incorporate($obj) {
             $conc.HOW.add_multi_method($conc, $_.name, $_.code.instantiate_generic($type_env))
         }

src/Perl6/Metamodel/PrivateMethodContainer.pm

@@ -0,0 +1,24 @@
+role Perl6::Metamodel::PrivateMethodContainer {
+    has %!private_methods;
+
+    # Adds a private method.
+    method add_private_method($obj, $name, $code) {
+        if pir::exists(%!private_methods, $name) {
+            pir::die("Private method '$name' already declared in package " ~
+                self.name($obj));
+        }
+        %!private_methods{$name} := $code;
+    }
+
+    # Gets the table of private methods.
+    method private_method_table($obj) {
+        %!private_methods
+    }
+
+    # Locates a private method, and hands back null if it doesn't exist.
+    method find_private_method($obj, $name) {
+        pir::exists(%!private_methods, $name) ??
+            %!private_methods{$name} !!
+            nqp::null()
+    }
+}

src/Perl6/Metamodel/RoleToClassApplier.pm

@@ -3,6 +3,11 @@ my class RoleToClassApplier {
         my %mt := $target.HOW.method_table($target);
         return pir::exists(%mt, $name)
     }
+
+    sub has_private_method($target, $name) {
+        my %pmt := $target.HOW.private_method_table($target);
+        return pir::exists(%pmt, $name)
+    }
 
     sub has_attribute($target, $name) {
         my @attributes := $target.HOW.attributes($target, :local(1));
@@ -49,6 +54,13 @@ my class RoleToClassApplier {
                 $target.HOW.add_method($target, ~$_, $_);
             }
         }
+        if pir::can__IPs($to_compose_meta, 'private_method_table') {
+            for $to_compose_meta.private_method_table($to_compose) {
+                unless has_private_method($target, $_.key) {
+                    $target.HOW.add_private_method($target, $_.key, $_.value);
+                }
+            }
+        }
 
         # Compose in any multi-methods; conflicts can be caught by
         # the multi-dispatcher later.

src/Perl6/Metamodel/Trusting.pm

@@ -0,0 +1,34 @@
+# Implements managing trust relationships between types.
+role Perl6::Metamodel::Trusting {
+    # Who do we trust?
+    has @!trustees;
+
+    # Adds a type that we trust.
+    method add_trustee($obj, $trustee) {
+        @!trustees[+@!trustees] := $trustee;
+    }
+
+    # Introspect the types that we trust.
+    method trusts($obj) {
+        @!trustees
+    }
+
+    # Checks if we trust a certain type. Can be used by the compiler
+    # to check if a private call is allowable.
+    method is_trusted($obj, $claimant) {
+        # Always trust ourself.
+        if $claimant.WHAT =:= $obj.WHAT {
+            return 1;
+        }
+
+        # Otherwise, look through our trustee list.
+        for @!trustees {
+            if $_.WHAT =:= $claimant.WHAT {
+                return 1;
+            }
+        }
+
+        # If we get here, not trusted.
+        0
+    }
+}

src/binder/bind.c

@@ -24,10 +24,10 @@ static STRING *SELF_str         = NULL;
 static STRING *NAME_str         = NULL;
 static STRING *BLOCK_str        = NULL;
 static STRING *CAPTURE_str      = NULL;
-static STRING *SNAPCAP_str      = NULL;
 static STRING *STORAGE_str      = NULL;
 static STRING *REST_str         = NULL;
 static STRING *LIST_str         = NULL;
+static STRING *HASH_str         = NULL;
 static STRING *FLATTENS_str     = NULL;
 static STRING *NEXTITER_str     = NULL;
 static STRING *HASH_SIGIL_str   = NULL;
@@ -47,10 +47,10 @@ static void setup_binder_statics(PARROT_INTERP) {
     SELF_str         = Parrot_str_new_constant(interp, "self");
     BLOCK_str        = Parrot_str_new_constant(interp, "Block");
     CAPTURE_str      = Parrot_str_new_constant(interp, "Capture");
-    SNAPCAP_str      = Parrot_str_new_constant(interp, "!snapshot_capture");
     STORAGE_str      = Parrot_str_new_constant(interp, "$!storage");
     REST_str         = Parrot_str_new_constant(interp, "$!rest");
     LIST_str         = Parrot_str_new_constant(interp, "$!list");
+    HASH_str         = Parrot_str_new_constant(interp, "$!hash");
     FLATTENS_str     = Parrot_str_new_constant(interp, "$!flattens");
     NEXTITER_str     = Parrot_str_new_constant(interp, "$!nextiter");
     HASH_SIGIL_str   = Parrot_str_new_constant(interp, "%");
@@ -575,19 +575,26 @@ Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
 
         /* Is it looking for us to bind a capture here? */
         if (param->flags & SIG_ELEM_IS_CAPTURE) {
-            /* XXX In the long run, we need to snapshot any current CaptureCursor.
-             * For now, we don't have that, so we just build off the current
-             * capture. Of course, if there's no variable name we can (cheaply)
-             * do pretty much nothing. */
+            /* Capture the arguments from this point forwards into a Capture.
+             * Of course, if there's no variable name we can (cheaply) do pretty
+             * much nothing. */
             if (STRING_IS_NULL(param->variable_name)) {
                 bind_fail = BIND_RESULT_OK;
             }
             else {
-                PMC *ns       = Parrot_hll_get_ctx_HLL_namespace(interp);
-                PMC *snapper  = Parrot_ns_get_global(interp, ns, SNAPCAP_str);
-                PMC *snapshot = PMCNULL;
-                Parrot_ext_call(interp, snapper, "PiIP->P", capture, cur_pos_arg, named_args_copy, &snapshot);
-                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, snapshot,
+                PMC *captype  = Rakudo_types_capture_get();
+                PMC *capsnap  = REPR(captype)->instance_of(interp, captype);
+                PMC *pos_args = pmc_new(interp, enum_class_ResizablePMCArray);
+                INTVAL k;
+                VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args);
+                for (k = cur_pos_arg; k < num_pos_args; k++)
+                    VTABLE_push_pmc(interp, pos_args,
+                        VTABLE_get_pmc_keyed_int(interp, capture, k));
+                VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str,
+                    PMC_IS_NULL(named_args_copy) ?
+                        pmc_new(interp, enum_class_Hash) :
+                        VTABLE_clone(interp, named_args_copy));
+                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, capsnap,
                         no_nom_type_check, error);
             }
             if (bind_fail) {

src/binder/types.c

@@ -20,6 +20,7 @@ static PMC * Array      = NULL;
 static PMC * LoL        = NULL;
 static PMC * EnumMap    = NULL;
 static PMC * _Hash      = NULL;
+static PMC * Capture    = NULL;
 static PMC * BoolFalse  = NULL;
 static PMC * BoolTrue   = NULL;
 static PMC * PackageHOW = NULL;
@@ -61,6 +62,9 @@ PMC * Rakudo_types_enummap_get(void) { return EnumMap; }
 void Rakudo_types_hash_set(PMC * type) { _Hash = type; }
 PMC * Rakudo_types_hash_get(void) { return _Hash; }
 
+void Rakudo_types_capture_set(PMC * type) { Capture = type; }
+PMC * Rakudo_types_capture_get(void) { return Capture; }
+
 void Rakudo_types_bool_false_set(PMC * type) { BoolFalse = type; }
 PMC * Rakudo_types_bool_false_get(void) { return BoolFalse; }
 

src/binder/types.h

@@ -37,6 +37,9 @@ PMC * Rakudo_types_enummap_get(void);
 void Rakudo_types_hash_set(PMC * type);
 PMC * Rakudo_types_hash_get(void);
 
+void Rakudo_types_capture_set(PMC * type);
+PMC * Rakudo_types_capture_get(void);
+
 void Rakudo_types_bool_false_set(PMC * type);
 PMC * Rakudo_types_bool_false_get(void);
 

src/core/Capture.pm

@@ -19,7 +19,7 @@ my class Capture {
     }
 
     method hash(Capture:D:) {
-        my $enum := new::create(EnumMap);
+        my $enum := nqp::create(EnumMap);
         nqp::bindattr($enum, EnumMap, '$!storage', $!hash);
         $enum;
     }

src/core/Mu.pm

@@ -165,6 +165,13 @@ my class Mu {
         pir::find_method__PPS($type, $name)(self, |@pos, |%named)
     }
 
+    method dispatch:<!>($name, Mu $type, *@pos, *%named) {
+        my $meth := $type.HOW.find_private_method($type, $name);
+        nqp::isnull($meth) ??
+            die("Private method '$name' not found on type " ~ $type.HOW.name($type)) !!
+            $meth(self, |@pos, |%named)
+    }
+
     method dispatch:<.^>($name, *@pos, *%named) {
         self.HOW."$name"(self, |@pos, |%named)
     }

src/core/traits.pm

@@ -87,3 +87,8 @@ proto trait_mod:<will>(|$) { * }
 multi trait_mod:<will>(Attribute $attr, Block $closure, :$build!) {
     $attr.set_build_closure($closure)
 }
+
+proto trait_mod:<trusts>(|$) { * }
+multi trait_mod:<trusts>(Mu:U $truster, Mu:U $trustee) {
+    $truster.HOW.add_trustee($truster, $trustee);
+}