Author: leo
Date: Mon Jan 16 05:26:23 2006
New Revision: 11212
Modified:
trunk/compilers/imcc/pbc.c
trunk/src/classes/closure.pmc
trunk/t/op/lexicals.t
Log:
lexicals - experimental support for package-scoped closures
* .sub bar :outer(foo) creates 'bar' as closure
* if it's invoked as is (no newclosure cloning code), it locates
'foo' in the call chain and sets outer_ctx to that context
* tests; also remove bogus tests with multiple indentical sub names
Modified: trunk/compilers/imcc/pbc.c
==============================================================================
--- trunk/compilers/imcc/pbc.c (original)
+++ trunk/compilers/imcc/pbc.c Mon Jan 16 05:26:23 2006
@@ -656,7 +656,8 @@ add_const_pmc_sub(Interp *interpreter, S
type = (r->pcc_sub->calls_a_sub & ITPCCYIELD) ?
- enum_class_Coroutine : enum_class_Sub;
+ enum_class_Coroutine :
+ unit->outer ? enum_class_Closure : enum_class_Sub;
/* TODO constant - see also src/packfile.c
*/
sub_pmc = pmc_new(interpreter, type);
Modified: trunk/src/classes/closure.pmc
==============================================================================
--- trunk/src/classes/closure.pmc (original)
+++ trunk/src/classes/closure.pmc Mon Jan 16 05:26:23 2006
@@ -84,6 +84,21 @@ Invokes the closure.
*/
sub->ctx->outer_ctx = sub->outer_ctx;
}
+ else {
+ /* closure is just invoked - located :outer's ctx */
+ parrot_context_t *caller = sub->ctx->caller_ctx;
+ while (caller) {
+ if (caller->current_sub == sub->outer_sub) {
+ sub->ctx->outer_ctx = caller;
+ break;
+ }
+ caller = caller->caller_ctx;
+ }
+ if (!caller)
+ real_exception(interpreter, NULL, INVALID_OPERATION,
+ ":outer '%Ss' not found",
+ VTABLE_get_string(INTERP, sub->outer_sub));
+ }
return next;
}
}
Modified: trunk/t/op/lexicals.t
==============================================================================
--- trunk/t/op/lexicals.t (original)
+++ trunk/t/op/lexicals.t Mon Jan 16 05:26:23 2006
@@ -465,121 +465,6 @@ main
I messed with your var
OUTPUT
-
-pir_output_is(<<'CODE', <<'OUTPUT', 'get_outer(outer sub name reused) - always
uses first sub of same name');
-.sub main :main
- bar()
-.end
-
-.sub foo :anon :outer('main')
-.end
-
-.sub foo :anon
-.end
-
-.sub foo
-.end
-
-.sub bar :outer('foo')
- .include 'interpinfo.pasm'
- $P1 = interpinfo .INTERPINFO_CURRENT_SUB
- $P2 = $P1.'get_outer'()
- print $P2
- print "\n"
- $P3 = $P2.'get_outer'()
- print $P3
- print "\n"
-.end
-CODE
-foo
-main
-OUTPUT
-
-pir_output_like(<<'CODE', <<'OUTPUT', 'get_outer(outer sub name reused) -
always uses first sub of same name');
-.sub main :main
- bar()
-.end
-
-.sub foo :anon
-.end
-
-.sub foo :anon :outer('main')
-.end
-
-.sub foo
-.end
-
-.sub bar :outer('foo')
- .include 'interpinfo.pasm'
- $P1 = interpinfo .INTERPINFO_CURRENT_SUB
- $P2 = $P1.'get_outer'()
- print $P2
- print "\n"
- $P3 = $P2.'get_outer'()
- print $P3
- print "\n"
-.end
-CODE
-/foo\nNull PMC access in get_string()/
-OUTPUT
-
-pir_output_is(<<'CODE', <<'OUTPUT', 'get_outer(outer sub name reused) - always
uses first sub of same name');
-.sub main :main
- bar()
-.end
-
-.sub foo :outer('main')
-.end
-
-.sub foo :anon
-.end
-
-.sub foo :anon
-.end
-
-.sub bar :outer('foo')
- .include 'interpinfo.pasm'
- $P1 = interpinfo .INTERPINFO_CURRENT_SUB
- $P2 = $P1.'get_outer'()
- print $P2
- print "\n"
- $P3 = $P2.'get_outer'()
- print $P3
- print "\n"
-.end
-CODE
-foo
-main
-OUTPUT
-
-pir_output_like(<<'CODE', <<'OUTPUT', 'get_outer(outer sub name reused) -
always uses first sub of same name');
-.sub main :main
- bar()
-.end
-
-.sub foo
-.end
-
-.sub foo :anon :outer('main')
-.end
-
-.sub foo :anon
-.end
-
-.sub bar :outer('foo')
- .include 'interpinfo.pasm'
- $P1 = interpinfo .INTERPINFO_CURRENT_SUB
- $P2 = $P1.'get_outer'()
- print $P2
- print "\n"
- $P3 = $P2.'get_outer'()
- print $P3
- print "\n"
-.end
-CODE
-/foo\nNull PMC access in get_string()/
-OUTPUT
-
pir_output_is(<<'CODE', <<'OUTPUT', 'closure 3');
# sub foo {
# my ($n) = @_;
@@ -1024,6 +909,59 @@ ok
ok
OUTPUT
+pir_output_is(<<'CODE', <<'OUTPUT', 'package-scoped closure 1');
+# my $x;
+# sub f{$x++}
+# f()
+# print "$x\n"
+.sub '&main' :main :anon
+ .local pmc sx
+ .lex '$x', sx
+ sx = new .PerlUndef
+ '&f'()
+ print sx # no find_lex needed - 'sx' is defined here
+ print "\n"
+.end
+
+.sub '&f' :outer('&main')
+ $P0 = find_lex '$x' # find_lex needed
+ inc $P0
+.end
+CODE
+1
+OUTPUT
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'package-scoped closure 2');
+# my $x;
+# sub f{$x++}
+# sub g{f();f()}
+# g()
+# print "$x\n"
+.sub '&main' :main :anon
+ .local pmc sx
+ .lex '$x', sx
+ sx = new .PerlUndef
+ '&g'()
+ print sx
+ print "\n"
+.end
+
+.sub '&f' :outer('&main')
+ $P0 = find_lex '$x'
+ inc $P0
+.end
+
+.sub '&g' :outer('&main') # :outer not needed - no find_lex
+ '&f'()
+ '&f'()
+.end
+
+
+
+CODE
+2
+OUTPUT
+
## remember to change the number of tests :-)
-BEGIN { plan tests => 40; }
+BEGIN { plan tests => 38; }
