Merge branch 'ng' of git@github.com:rakudo/rakudo into ng

rakudo · Feb 6, 2010 · a02ed62 · a02ed62
2 parents 4efce8e + 61f444a
commit a02ed62
Show file tree

Hide file tree

Showing 9 changed files with 103 additions and 17 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -135,6 +135,7 @@ CHEATS_PIR = \
   src/cheats/fail.pir \
   src/cheats/object.pir \
   src/cheats/postcircumfix-array.pir \
+  src/cheats/postcircumfix-hash.pir \
   src/cheats/int-ops.pir \
   src/cheats/num-ops.pir \
   src/cheats/str-ops.pir \
@@ -174,6 +175,8 @@ CORE_SOURCES = \
   src/core/Pair.pm \
   src/core/Range.pm \
   src/core/RangeIter.pm \
+  src/core/EnumMap.pm \
+  src/core/Hash.pm \
   src/core/IO.pm \
   src/core/Parameter.pm \
   src/core/Block.pm \

diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
@@ -1492,15 +1492,13 @@ method postcircumfix:sym<[ ]>($/) {
 }
 
 method postcircumfix:sym<{ }>($/) {
-    make PAST::Var.new( $<EXPR>.ast , :scope('keyed'),
-                        :viviself('Undef'),
-                        :vivibase('Hash') );
+    make PAST::Op.new( $<EXPR>.ast, :name('!postcircumfix:<{ }>'),
+                       :pasttype('call'), :node($/) );
 }
 
 method postcircumfix:sym<ang>($/) {
-    make PAST::Var.new( $<quote_EXPR>.ast, :scope('keyed'),
-                        :viviself('Undef'),
-                        :vivibase('Hash') );
+    make PAST::Op.new( $<quote_EXPR>.ast, :name('!postcircumfix:<{ }>'),
+                       :pasttype('call'), :node($/) );
 }
 
 method postcircumfix:sym<( )>($/) {

diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm
@@ -153,6 +153,7 @@ token def_module_name {
     [
         <?before '['>
         <?{ $*PKGDECL eq 'role' }>
+        :my $*SCOPE := 'my';
         '[' ~ ']' <signature>
     ]?
 }

diff --git a/src/binder/bind.c b/src/binder/bind.c
@@ -14,9 +14,6 @@ Copyright (C) 2009, The Perl Foundation.
 /* Cache of the type ID for low level signatures. */
 static INTVAL lls_id = 0;
 
-/* Names of types we create. */
-#define PERL6_HASH  "Hash"
-
 /* Unwraps things inside a scalar reference. */
 static PMC *
 descalarref(PARROT_INTERP, PMC *ref) {
@@ -40,6 +37,17 @@ Rakudo_binding_create_array(PARROT_INTERP) {
 }
 
 
+/* Creates a Perl 6 Hash. */
+static PMC *
+Rakudo_binding_create_hash(PARROT_INTERP, PMC *storage) {    
+    PMC *ns        = Parrot_get_ctx_HLL_namespace(interp);
+    PMC *creator   = Parrot_get_global(interp, ns, string_from_literal(interp, "&CREATE_HASH_LOW_LEVEL"));
+    PMC *result    = PMCNULL;
+    Parrot_ext_call(interp, creator, "P->P", storage, &result);
+    return result;
+}
+
+
 /* Creates a Perl 6 object of the type given by C<classname> */
 static PMC *
 Rakudo_binding_create(PARROT_INTERP, STRING *classname) {
@@ -253,7 +261,7 @@ Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, llsig_element *sig_inf
                 }
                 else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) {
                     STRING *STORE = string_from_literal(interp, "!STORE");
-                    copy          = pmc_new(interp, pmc_type(interp, string_from_literal(interp, PERL6_HASH)));
+                    copy          = Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash));
                     store_meth    = VTABLE_find_method(interp, copy, STORE);
                     Parrot_ext_call(interp, store_meth, "PiP", copy, value);
                     VTABLE_setprop(interp, copy, string_from_literal(interp, "flatten"), copy);
@@ -372,7 +380,7 @@ Rakudo_binding_handle_optional(PARROT_INTERP, llsig_element *sig_info, PMC *lexp
             return Rakudo_binding_create_array(interp);
         }
         else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) {
-            return pmc_new(interp, pmc_type(interp, string_from_literal(interp, PERL6_HASH)));
+            return Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash));
         }
         else {
             return pmc_new(interp, pmc_type(interp, string_from_literal(interp, "Perl6Scalar")));
@@ -479,7 +487,7 @@ Rakudo_binding_bind_signature(PARROT_INTERP, PMC *lexpad, PMC *signature,
      * be wanting to bind positionally. */
     if (!PMC_IS_NULL(named_names)) {
         PMC *iter = VTABLE_get_iter(interp, named_names);
-        named_args_copy = pmc_new(interp, pmc_type(interp, string_from_literal(interp, PERL6_HASH)));
+        named_args_copy = pmc_new(interp, enum_class_Hash);
         while (VTABLE_get_bool(interp, iter)) {
             STRING *name = VTABLE_shift_string(interp, iter);
             if (VTABLE_exists_keyed_str(interp, named_to_pos_cache, name)) {
@@ -519,10 +527,10 @@ Rakudo_binding_bind_signature(PARROT_INTERP, PMC *lexpad, PMC *signature,
              * will by definition contain all unbound named parameters and use
              * that, or just create an empty one. */
             PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
-                    pmc_new(interp, pmc_type(interp, string_from_literal(interp, PERL6_HASH))) :
+                    pmc_new(interp, enum_class_Hash) :
                     named_args_copy;
             bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, elements[i],
-                    slurpy, no_nom_type_check, error);
+                    Rakudo_binding_create_hash(interp, slurpy), no_nom_type_check, error);
             if (bind_fail) {
                 if (pos_from_named)
                     mem_sys_free(pos_from_named);

diff --git a/src/builtins/Role.pir b/src/builtins/Role.pir
@@ -272,13 +272,13 @@ just here so postcircumfix:[ ] doesn't explode).
     .param pmc role
     .param pmc pos_args   :slurpy
     .param pmc named_args :slurpy :named
+    $P0 = interpinfo .INTERPINFO_CURRENT_SUB
+    $P0 = getprop 'name', $P0
+    $S0 = $P0
     $I0 = isa role, 'P6role'
     if $I0 goto already_selected
     role = role.'!select'()
   already_selected:
-    $P0 = interpinfo .INTERPINFO_CURRENT_SUB
-    $P0 = getprop 'name', $P0
-    $S0 = $P0
     $P0 = role.'!pun'()
     .tailcall $P0.$S0(pos_args :flat, named_args :flat :named)
 .end

diff --git a/src/cheats/postcircumfix-hash.pir b/src/cheats/postcircumfix-hash.pir
@@ -0,0 +1,25 @@
+=item !postcircumfix:<{ }>
+
+Because foreign (non-Rakudo) Parrot objects generally won't
+understand the "postcircumfix:<{ }>" method, we generate
+postcircumfix as a private call to this function, and this
+function then delegates to the appropriate method.  For PMCs
+that don't have a postcircumfix:<{ }> method, we'll have to
+fake it later.
+
+=cut
+
+.namespace []
+.sub '!postcircumfix:<{ }>'
+    .param pmc invocant
+    .param pmc args            :slurpy
+    $I0 = can invocant, 'postcircumfix:<{ }>'
+    if $I0 goto object_method
+    $I0 = isa invocant, 'Mu'
+    if $I0 goto object_method
+  foreign:
+    die "Can't postcircumfix:<{ }> foreign objects yet."
+  object_method:
+    .tailcall invocant.'postcircumfix:<{ }>'(args :flat)
+.end
+
diff --git a/src/core/EnumMap.pm b/src/core/EnumMap.pm
@@ -0,0 +1,22 @@
+role EnumMap {
+    has $!storage;
+
+    method new(*%values) {
+        self.bless(*, storage => pir::getattribute__PPs(%values, '$!storage'));
+    }
+
+    method postcircumfix:<{ }>($key) {
+        Q:PIR {
+            .local pmc self
+            self = find_lex 'self'
+            $P0 = getattribute self, '$!storage'
+            $P1 = find_lex '$key'
+            %r = $P0[$P1]
+            unless null %r goto done
+            %r = new ['Proxy']
+            setattribute %r, '$!base', $P0
+            setattribute %r, '$!key', $P1
+          done:
+        }
+    }
+}
diff --git a/src/core/Hash.pm b/src/core/Hash.pm
@@ -0,0 +1,18 @@
+role Hash is EnumMap {
+    method postcircumfix:<{ }>($key) {
+        Q:PIR {
+            .local pmc self
+            self = find_lex 'self'
+            $P0 = getattribute self, '$!storage'
+            $P1 = find_lex '$key'
+            %r = $P0[$P1]
+            unless null %r goto done
+            %r = new ['Proxy']
+            setattribute %r, '$!base', $P0
+            setattribute %r, '$!key', $P1
+            $P2 = get_hll_global ['Bool'], 'True'
+            setprop %r, 'rw', $P2
+          done:
+        }
+    }
+}
diff --git a/src/glue/types.pir b/src/glue/types.pir
@@ -55,6 +55,17 @@ subtyping relations, etc).
     .return (1)
 .end
 
+
+.sub '&CREATE_HASH_LOW_LEVEL'
+    .param pmc storage
+    $P0 = get_hll_global 'Hash'
+    $P0 = $P0.'!select'()
+    $P0 = $P0.'!pun'()
+    $P1 = $P0.'CREATE'()
+    $P0 = $P0.'bless'($P1, 'storage'=>storage)
+    .return ($P0)
+.end
+
 =back
 
 =cut