First cut of enforcing return types of subs and methods. Both of Foo …

…and returns Foo forms work - also did some more general infrastructure for trait verbs on routines to make this work. Limitation in this patch is it only works for explicit calls to return, not yet implicit returns by falling off the end of the sub. .of and .returns on a Sub also work as a result of this, since it's done by having the Callable[::T] role holding the return type. Because when we get the current Sub using interpinfo we end up with the Parrot-level sub rather than our reblessed one, need to maintain a reference on that to the re-blessed one that carries the type info. Hopefully we can drop that in the future, somehow.
rakudo · Apr 4, 2009 · b13a6af · b13a6af
1 parent c6301b7
commit b13a6af
Show file tree

Hide file tree

Showing 3 changed files with 109 additions and 10 deletions.
diff --git a/src/builtins/assign.pir b/src/builtins/assign.pir
@@ -41,6 +41,12 @@ src/builtins/assign.pir - assignments
     unless $I0 goto assign_done
     $P0 = getprop '$!signature', source
     setprop cont, '$!signature', $P0
+    $I0 = isa source, 'Code'
+    unless $I0 goto assign_done
+    $P0 = getattribute source, ['Sub'], 'proxy'
+    $P0 = getprop '$!real_self', $P0
+    $P1 = getattribute cont, ['Sub'], 'proxy'
+    setprop $P1, '$!real_self', $P0
   assign_done:
     .return (cont)
 .end

diff --git a/src/builtins/guts.pir b/src/builtins/guts.pir
@@ -883,11 +883,11 @@ in an ambiguous multiple dispatch.
     exportns = blockns.'make_namespace'('EXPORT')
     if null arg goto default_export
     .local pmc it
-    arg = arg.'list'()
+    arg = 'list'(arg)
     $I0 = arg.'elems'()
     if $I0 goto have_arg
   default_export:
-    $P0 = get_hll_global 'Perl6Pair'
+    $P0 = get_hll_global 'Pair'
     $P0 = $P0.'new'('key' => 'DEFAULT', 'value' => 1)
     arg = 'list'($P0)
   have_arg:
@@ -907,6 +907,49 @@ in an ambiguous multiple dispatch.
     ns[blockname] = block
 .end
 
+=item !sub_trait_verb(sub, trait, arg?)
+
+=cut
+
+.sub '!sub_trait_verb'
+    .param pmc block
+    .param string trait
+    .param pmc arg             :optional
+    .param int has_arg         :opt_flag
+
+    if has_arg goto have_arg
+    null arg
+  have_arg:
+
+    $S0 = substr trait, 11
+    $S0 = concat '!sub_trait_verb_', $S0
+    $P0 = find_name $S0
+    if null $P0 goto done
+    $P0(block, arg)
+  done:
+.end
+
+
+=item !sub_trait_returns(trait, block, arg)
+
+Sets the returns trait, which sets the type that the block must return.
+The of trait is just an alias to this.
+
+=cut
+
+.sub '!sub_trait_verb_returns'
+    .param pmc block
+    .param pmc type
+    $P0 = get_hll_global 'Callable'
+    $P0 = $P0.'!select'(type)
+    'infix:does'(block, $P0)
+.end
+.sub '!sub_trait_verb_of'
+    .param pmc block
+    .param pmc arg
+    .tailcall '!sub_trait_verb_returns'(block, arg)
+.end
+
 
 =item !set_resolves_list(class)
 

diff --git a/src/parser/actions.pm b/src/parser/actions.pm
@@ -32,10 +32,17 @@ method TOP($/) {
                                          '    unless meth_iter goto it_loop_end',
                                          '    $S0 = shift meth_iter',
                                          '    $P0 = meths[$S0]',
-                                         '    $P1 = getprop "$!signature", $P0',
-                                         '    $P0 = newclosure $P0',
-                                         '    setprop $P0, "$!signature", $P1',
-                                         '    .mr."add_method"($S0, $P0)',
+                                         '    $P1 = newclosure $P0',
+                                         '    $P2 = getprop "$!signature", $P0',
+                                         '    setprop $P1, "$!signature", $P2',
+                                         '    $I0 = isa $P0, "Code"',
+                                         '    unless $I0 goto ret_pir_skip_rs',
+                                         '    $P2 = getattribute $P0, ["Sub"], "proxy"',
+                                         '    $P2 = getprop "$!real_self", $P2',
+                                         '    $P3 = getattribute $P1, ["Sub"], "proxy"',
+                                         '    setprop $P3, "$!real_self", $P2',
+                                         '  ret_pir_skip_rs:',
+                                         '    .mr."add_method"($S0, $P1)',
                                          '    goto it_loop',
                                          '  it_loop_end:',
                                          '    .return (.mr)',
@@ -1018,7 +1025,7 @@ method routine_def($/) {
         our @?BLOCK;
         @?BLOCK[0].symbol( $name, :scope('package') );
     }
-    $block.control('return_pir');
+    $block.control(return_handler_past());
     block_signature($block);
 
     if $<trait> {
@@ -1029,7 +1036,12 @@ method routine_def($/) {
             #  We just modify them to call !sub_trait and add
             #  'block' as the first argument.
             my $trait := $( $_ );
-            $trait.name('!sub_trait');
+            if substr($trait[0], 0, 11) eq 'trait_verb:' {
+                $trait.name('!sub_trait_verb');
+            }
+            else {
+                $trait.name('!sub_trait');
+            }
             $trait.unshift($blockreg);
             $loadinit.push($trait);
         }
@@ -1053,7 +1065,7 @@ method method_def($/) {
         )
     );
 
-    $block.control('return_pir');
+    $block.control(return_handler_past());
     block_signature($block);
     # Ensure there's an invocant in the signature.
     $block.loadinit().push(PAST::Op.new(
@@ -1070,7 +1082,12 @@ method method_def($/) {
             #  We just modify them to call !sub_trait and add
             #  'block' as the first argument.
             my $trait := $( $_ );
-            $trait.name('!sub_trait');
+            if substr($trait[0], 0, 11) eq 'trait_verb:' {
+                $trait.name('!sub_trait_verb');
+            }
+            else {
+                $trait.name('!sub_trait');
+            }
             $trait.unshift($blockreg);
             $loadinit.push($trait);
         }
@@ -3193,6 +3210,12 @@ sub set_block_type($block, $type) {
         );
         $block<block_class_type> := $set_type;
         $block.loadinit().push($set_type);
+        # The following is to make sure the Parrot-level sub has a backlink
+        # to the Rakudo-level object, since it's all that we can find from
+        # interpinfo.
+        $block.loadinit().push(PAST::Op.new(
+            :inline("    $P0 = getattribute block, ['Sub'], 'proxy'",
+                    "    setprop $P0, '$!real_self', block") ) );
     }
 }
 
@@ -3274,6 +3297,33 @@ sub block_has_state($block) {
     }
 }
 
+# Manufactures PAST to handle check of return type.
+sub return_handler_past() {
+    PAST::Stmts.new(
+        PAST::Op.new( :inline('    exception = getattribute exception, "payload"') ),
+        PAST::Op.new(
+            :pasttype('if'),
+            PAST::Op.new(
+                :pasttype('callmethod'),
+                :name('ACCEPTS'),
+                PAST::Op.new( :inline("    %r = interpinfo .INTERPINFO_CURRENT_SUB",
+                                      "    %r = getprop '$!real_self', %r",
+                                      "    %r = %r.'of'()") ),
+                PAST::Var.new( :name('exception'), :scope('register') )
+            ),
+            PAST::Op.new(
+                :inline('    .return (%0)'),
+                PAST::Var.new( :name('exception'), :scope('register') )
+            ),
+            PAST::Op.new(
+                :pasttype('call'),
+                :name('die'),
+                'Type check failed on return value'
+            )
+        )
+    )
+}
+
 # Local Variables:
 #   mode: cperl
 #   cperl-indent-level: 4