The attached patch is functionally complete, but I still have a few loose ends to nail down, so I thought it would be a good time to post it for review. The issues are as follows:
1. It needs more higher-level documentation. Is compiler_faq.pod the best place for this? 2. Binding 'foo' to a null PMC should cause find_global to err out with "Global "foo" not found", but this is not happening. 3. There are no tests for threads or stack-unwinding continuations. (Yes, I am procrastinating.) Others issues are marked with dated comments between '[' and ']'. Comments and criticisms are most welcome -- I haven't much experience with hacking C. TIA, -- Bob Rogers http://rgrjr.dyndns.org/
Index: src/ops/var.ops =================================================================== --- src/ops/var.ops (revision 10791) +++ src/ops/var.ops (working copy) @@ -199,6 +199,45 @@ goto NEXT(); } +=item B<bind_global>(in STR, in PMC) + +Bind the PMC $2 as global symbol $1 in the current context. If $2 is a Null +PMC, then the global is effectively made locally unbound. The newly-created +dynamic binding will be used by C<find_global> and C<store_global> in the +current dynamic environment only, i.e. this call and all calls made from it. +[should expand on this. -- rgr, 28-Dec-05.] + +Note that there is no C<bind_global_p_s_p> op, as dynamic binding only +makes sense with respect to an execution context. + +=item B<bind_global>(in STR, in STR, in PMC) + +Bind the PMC $3 as symbol $2 of namespace $1 in the current context. +The binding is created whether or not namespace $1 exists already. + +=item B<unbind_globals>(in INT) + +Remove zero or more dynamic bindings created in the current +execution context. The integer value must not be more than +the number of bindings established during the current call. + +=cut + +op bind_global(in STR, in PMC) { + Parrot_bind_global(interpreter, NULL, $1, $2); + goto NEXT(); +} + +op bind_global(in STR, in STR, in PMC) { + Parrot_bind_global(interpreter, $1, $2, $3); + goto NEXT(); +} + +op unbind_globals(in INT) { + Parrot_unbind_globals(interpreter, $1); + goto NEXT(); +} + =back =cut Index: src/ops/ops.num =================================================================== --- src/ops/ops.num (revision 10791) +++ src/ops/ops.num (working copy) @@ -1212,3 +1212,11 @@ find_global_p_p_sc 1182 find_name_p_s 1183 find_name_p_sc 1184 +bind_global_s_p 1185 +bind_global_sc_p 1186 +bind_global_s_s_p 1187 +bind_global_sc_s_p 1188 +bind_global_s_sc_p 1189 +bind_global_sc_sc_p 1190 +unbind_globals_i 1191 +unbind_globals_ic 1192 Index: src/register.c =================================================================== --- src/register.c (revision 10791) +++ src/register.c (working copy) @@ -131,6 +131,7 @@ ctx->bp = interpreter->ctx.bp; ctx->bp_ps = interpreter->ctx.bp_ps; ctx->prev = NULL; + ctx->dynamic_bindings = NULL; } #else @@ -172,6 +173,7 @@ * extenders) are assuming the presence of these registers */ Parrot_alloc_context(interpreter, num_regs); + CONTEXT(interpreter->ctx)->dynamic_bindings = NULL; } #endif @@ -348,6 +350,7 @@ /* returning from main */ return; } + Parrot_free_dynamic_bindings(interpreter, ctx, 999999); CONTEXT(ctx)->prev = NULL; used_ctx_mem = (char *)ctx.bp + sizeof(struct parrot_regs_t); Index: src/global.c =================================================================== --- src/global.c (revision 10791) +++ src/global.c (working copy) @@ -27,34 +27,79 @@ /* =item C<PMC * -Parrot_find_global(Parrot_Interp interpreter, STRING *class, STRING *globalname)> +Parrot_find_global(Parrot_Interp interpreter, STRING *namespace, STRING *globalname)> -If C<class> is NULL search global stash. If C<globalname> is NULL, return the -stash PMC. +Look for a global named C<globalname> in the namespace named C<namespace>, +looking first in the context's dynamic bindings. If C<namespace> is NULL, then +search the global stash. Return NULL if the global isn't found. -Return NULL if the global isn't found or the global. +If C<globalname> is NULL, then the dynamic binding search is skipped, and the +stash PMC itself is returned.. +Note that if the named global has been shadowed by C<bind_global> in some +calling context, then C<Parrot_find_global> will fetch the value from the +innermost such binding. This, too, could be NULL. + =item C<PMC * Parrot_get_global(Parrot_Interp interpreter, STRING *class, STRING *globalname)> -If the global exists, return it. If not either throw an exception or return an -C<Undef> depending on the interpreter's error settings. +If the global exists (i.e. C<Parrot_find_global> returns something other than +NULL), return it. If not, then either throw an exception or return an C<Undef>, +depending on the interpreter's error settings. =cut */ +static Parrot_DBE * +find_dynamic_binding(Interp *interpreter, STRING *namespace, + STRING *globalname) +{ + parrot_context_t *ctx = CONTEXT(interpreter->ctx); + Parrot_DBE *bindings = ctx->dynamic_bindings; + + while (bindings != NULL) { + #if 0 + fprintf(stderr, "[woop 0x%x => '%s', %s']\n", + (int) bindings, + (bindings->namespace + ? (char *)bindings->namespace->strstart + : "(null)"), + (char *)bindings->globalname->strstart); + #endif + if ((bindings->namespace == namespace + || (bindings->namespace && namespace + && ! string_equal(interpreter, + bindings->namespace, namespace))) + && ! string_equal(interpreter, bindings->globalname, globalname)) + return (bindings); + bindings = bindings->next; + } + return NULL; +} + PMC * Parrot_find_global(Parrot_Interp interpreter, STRING *class, STRING *globalname) { PMC *stash; STRING *ns_name; + HashBucket *b; + + /* try the dynamic binding stack first. */ + if (globalname) { + Parrot_DBE *entry + = find_dynamic_binding(interpreter, class, globalname); + if (entry) { + return entry->binding; + } + } + + /* look in the appropriate stash. */ #if 1 /* * we are cheating a bit and use Hash internals to avoid * hash lookup duplication */ - HashBucket *b; #if DEBUG_GLOBAL PIO_printf(interpreter, "find_global class '%Ss' meth '%Ss'\n", class, globalname); @@ -279,7 +324,9 @@ Parrot_store_global(Parrot_Interp, STRING *class, STRING *globalname, PMC *)> Store the given PMC as global C<globalname> in the namespace C<class>. If -C<class> is NULL, the top-level global namespace is used. +C<class> is NULL, the top-level global namespace is used. Note that if +the named global has been shadowed by C<bind_global> in a calling context, +then only the innermost binding is affected by C<Parrot_store_global>. =cut @@ -291,6 +338,16 @@ { PMC *globals = interpreter->globals->stash_hash; PMC *stash; + + /* try the dynamic binding stack first. */ + Parrot_DBE *entry = find_dynamic_binding(interpreter, class, globalname); + if (entry) { + entry->binding = pmc; + Parrot_invalidate_method_cache(interpreter, class, globalname); + return; + } + + /* look in the appropriate stash. */ if (class) { stash = Parrot_global_namespace(interpreter, globals, class); } @@ -300,6 +357,104 @@ Parrot_invalidate_method_cache(interpreter, class, globalname); } +/* + +=item C<void +Parrot_bind_global(Parrot_Interp, STRING *class, STRING *globalname, PMC *)> + +Create a new dynamic binding for global C<globalname> of the +namespace C<class> in the current dynamic environment, using the +given PMC as the initial value. If C<class> is NULL, the +top-level global namespace is used. + +=cut + +*/ + +void +Parrot_bind_global(Interp *interpreter, STRING *class, + STRING *globalname, PMC *pmc) +{ + Parrot_DBE *entry = (Parrot_DBE *) mem_sys_allocate(sizeof(Parrot_DBE)); + entry->namespace = class; + entry->globalname = globalname; + entry->binding = pmc; + entry->next = CONTEXT(interpreter->ctx)->dynamic_bindings; + CONTEXT(interpreter->ctx)->dynamic_bindings = entry; + Parrot_invalidate_method_cache(interpreter, class, globalname); +} + +/* + +=item C<void +Parrot_unbind_globals(Parrot_Interp, INTVAL n)> + +Unbind globals that were created by the last N C<bind_global> calls +for the current context. An error is signalled if N is less than zero, +or if we attempt to undo more bindings than were created in the current +context. + +=cut + +*/ + +/* [this probably belongs with Parrot_free_context, but miniparrot won't link if + i put it in the register.c file. -- rgr, 29-Dec-05.] + */ +INTVAL +Parrot_free_dynamic_bindings(Interp *interpreter, + struct Parrot_Context *ctx, + INTVAL max_n_bindings) +{ + /* Free at most max_n_bindings of the context's dynamic bindings, being + careful not to step off the end of the list, or into the calling frame's + list of bindings. Returns max_n_bindings-n, where n is the number of + bindings actually removed. In other words, the return value will be zero + if and only if the max_n_bindings limit was reached. + */ + INTVAL n = max_n_bindings; + Parrot_DBE *current = ctx->dynamic_bindings, *next; + parrot_context_t *caller_ctx = ctx->caller_ctx; + Parrot_DBE *caller = (caller_ctx ? caller_ctx->dynamic_bindings : NULL); + + while (n > 0 + && current != caller + /* just in case. */ + && current != NULL) { + next = current->next; + Parrot_invalidate_method_cache(interpreter, current->namespace, + current->globalname); + ctx->dynamic_bindings = next; + mem_sys_free(current); + current = next; + n--; + } + return (n); +} + +void +Parrot_unbind_globals(Interp *interpreter, INTVAL n_bindings) +{ + parrot_context_t *ctx = CONTEXT(interpreter->ctx); + INTVAL n = Parrot_free_dynamic_bindings(interpreter, ctx, n_bindings); + + if (n == 0) { + /* normal completion */ + } + else if (n < 0) { + /* Save this test until here so we don't usually have to check it. */ + real_exception(interpreter, NULL, E_NameError, + "Attempt to unbind %d global bindings.", + n); + } + else { /* (n > 0) */ + real_exception(interpreter, NULL, E_NameError, + "Attempt to unbind %d global bindings " + "in a frame with %d in effect.", + n_bindings, n_bindings-n); + } +} + static void store_sub_in_namespace(Parrot_Interp interpreter, PMC* sub_pmc, PMC *namespace, STRING *sub_name) Index: src/classes/coroutine.pmc =================================================================== --- src/classes/coroutine.pmc (revision 10791) +++ src/classes/coroutine.pmc (working copy) @@ -148,6 +148,7 @@ PMC_cont(ccont)->from_ctx = ctx; ctx->current_sub = SELF; ctx->current_cont = ccont; + ctx->dynamic_bindings = caller_ctx->dynamic_bindings; ctx->current_object = NULL; INTERP->current_object = NULL; INTERP->current_cont = NULL; Index: src/classes/sub.pmc =================================================================== --- src/classes/sub.pmc (revision 10791) +++ src/classes/sub.pmc (working copy) @@ -295,6 +295,7 @@ context->caller_ctx = caller_ctx; context->current_pc = pc; context->current_cont = ccont; + context->dynamic_bindings = caller_ctx->dynamic_bindings; /* check recursion/call depth */ if (++context->recursion_depth > INTERP->recursion_limit) { Index: src/sub.c =================================================================== --- src/sub.c (revision 10791) +++ src/sub.c (working copy) @@ -37,6 +37,7 @@ mark_context(Interp* interpreter, parrot_context_t* ctx) { PObj *obj; + Parrot_DBE *entry; int i; mark_stack(interpreter, ctx->user_stack); @@ -78,6 +79,20 @@ if (obj) pobject_lives(interpreter, obj); } + entry = ctx->dynamic_bindings; + while (entry != NULL) { + /* [stop at the caller's topmost entry? -- rgr, 28-Dec-05.] */ + obj = (PObj*)entry->namespace; + if (obj) + pobject_lives(interpreter, obj); + obj = (PObj*)entry->globalname; + if (obj) + pobject_lives(interpreter, obj); + obj = (PObj*)entry->binding; + if (obj) + pobject_lives(interpreter, obj); + entry = entry->next; + } } /* Index: CREDITS =================================================================== --- CREDITS (revision 10791) +++ CREDITS (working copy) @@ -80,7 +80,8 @@ D: patch regarding macro argument expansion N: Bob Rogers -D: Updates to pmc2c.pl +D: Miscellaneous small tests and bug fixes. +D: Dynamic binding (see the bind_global op). E: [EMAIL PROTECTED] N: Brent Royal-Gordon Index: include/parrot/global.h =================================================================== --- include/parrot/global.h (revision 10791) +++ include/parrot/global.h (working copy) @@ -19,6 +19,9 @@ PMC *Parrot_get_global_p(Interp *, PMC *ns, STRING *name); PMC *Parrot_global_namespace(Interp *, PMC *globals, STRING *ns); void Parrot_store_global(Interp *, STRING *class, STRING *globalname, PMC *pmc); +void Parrot_bind_global(Interp *, STRING *class, STRING *globalname, PMC *pmc); +INTVAL Parrot_free_dynamic_bindings(Interp *, struct Parrot_Context *, INTVAL); +void Parrot_unbind_globals(Interp *, INTVAL); void Parrot_store_sub_in_namespace(Interp*, PMC* sub_pmc); PMC *Parrot_get_name(Interp *, STRING *name); Index: include/parrot/interpreter.h =================================================================== --- include/parrot/interpreter.h (revision 10791) +++ include/parrot/interpreter.h (working copy) @@ -167,6 +167,14 @@ INTVAL *regs_i; } Regs_ni; +typedef struct _parrot_dynamic_binding_entry { + struct _parrot_dynamic_binding_entry *next; /* linked list pointer */ + STRING *namespace; /* namespace/class name string; NULL => top */ + /* NB: globalname must not be NULL. */ + STRING *globalname; /* global object name string */ + PMC *binding; /* the bound value; NULL means unbound. */ +} Parrot_DBE; + typedef struct Parrot_Context { /* common header with Interp_Context */ struct Parrot_Context *prev; @@ -198,6 +206,7 @@ */ PMC *current_cont; /* the return continuation PMC */ PMC *current_object; /* current object if a method call */ + Parrot_DBE *dynamic_bindings; /* binding list */ STRING *current_method; /* name of method */ opcode_t *current_pc; /* program counter of Sub invocation */ String *current_package; /* The package we're currently in */ Index: t/op/globals.t =================================================================== --- t/op/globals.t (revision 10791) +++ t/op/globals.t (working copy) @@ -43,7 +43,7 @@ /Tried to get null global/ OUTPUT -output_like(<<'CODE', <<OUT, "not found exception"); +output_like(<<'CODE', <<OUT, "not found exception: global"); find_global P1, "no_such_global" print "ok 1\n" print P1 @@ -52,7 +52,16 @@ /Global 'no_such_global' not found/ OUT -output_is(<<'CODE', <<OUT, "not found - error turned off"); +output_like(<<'CODE', <<OUT, "not found exception: namespace"); + find_global P1, "Foo::Bar", "no_such_global" + print "ok 1\n" + print P1 + end +CODE +/Global 'no_such_global' not found/ +OUT + +output_is(<<'CODE', <<OUT, "not found: global, error turned off"); .include "errors.pasm" errorsoff .PARROT_ERRORS_GLOBALS_FLAG find_global P1, "no_such_global" @@ -67,7 +76,386 @@ ok 2 OUT +output_is(<<'CODE', <<OUT, "not found: namespace, error turned off"); + .include "errors.pasm" + errorsoff .PARROT_ERRORS_GLOBALS_FLAG + find_global P1, "Foo::Bar", "no_such_global" + print "ok 1\n" + defined I0, P1 + unless I0, ok2 + print "not " +ok2: print "ok 2\n" + end +CODE +ok 1 +ok 2 +OUT +### Dynamic binding tests. + +pir_output_is(<<'CODE', <<OUT, "DB 1: two nesting levels"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value +.end +CODE +Outer value +Inner value +Outer value +OUT + +pir_output_is(<<'CODE', <<OUT, "DB 2: store_global on bindings"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() + show_value() + show_value() +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value + ## mutate the value for next time. + .local string str + str = value + str = concat 'x ', str + value = str +.end +CODE +Outer value +Inner value +x Inner value +x x Inner value +x Outer value +OUT + +pir_output_is(<<'CODE', <<OUT, "DB 3: 3 levels, PMC side effect"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() + test2() + show_value() + test1_binding = "Inner value revised\n" + show_value() +.end +.sub test2 + $P1 = new String + $P1 = "Innerer value\n" + bind_global "Foo::Bar", "test", $P1 + show_value() +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value +.end +CODE +Outer value +Inner value +Innerer value +Inner value +Inner value revised +Outer value +OUT + +pir_output_is(<<'CODE', <<OUTPUT, "DB 4: coroutines, GC"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local int i, odd, fib + i = 0 +next: + if i >= 5 goto done + if i != 3 goto no_sweep + sweep 1 +no_sweep: + odd = gen_odd() + fib = gen_fib() + print odd + print ' ' + print fib + print "\n" + show_value() + i = i + 1 + goto next +done: +.end +.sub gen_odd + ## Generate the odd numbers, starting with 1. + .local int i + i = 1 + .local pmc global_value + global_value = new String + global_value = "gen_odd value\n" + bind_global "Foo::Bar", "test", global_value +next: + show_value() + .yield (i) + i = i + 2 + goto next +.end +.sub gen_fib + ## Generate the Fibonacci numbers: 1, 1, 2, 3, 5, 8, ... + .local int i, j, tmp + i = 1 + j = 1 + .local pmc global_value + global_value = new String + global_value = "gen_fib value\n" + bind_global "Foo::Bar", "test", global_value +next: + show_value() + .yield (i) + tmp = i + j + i = j + j = tmp + goto next +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value +.end +CODE +Outer value +gen_odd value +gen_fib value +1 1 +Outer value +gen_odd value +gen_fib value +3 1 +Outer value +gen_odd value +gen_fib value +5 2 +Outer value +gen_odd value +gen_fib value +7 3 +Outer value +gen_odd value +gen_fib value +9 5 +Outer value +Outer value +OUTPUT + +pir_output_is(<<'CODE', <<OUT, "DB 5: trivial unbinding"); +.sub main :main + unbind_globals 0 + print "Done.\n" +.end +CODE +Done. +OUT + +pir_output_like(<<'CODE', <<OUT, "DB 6: unbind with no bindings"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + unbind_globals 1 + print "oops\n" +.end +CODE +/Attempt to unbind 1 global/ +OUT + +pir_output_like(<<'CODE', <<OUT, "DB 7: unbind too many"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() + test2() + show_value() +.end +.sub test2 + $P1 = new String + $P1 = "Innerer value\n" + bind_global "Foo::Bar", "test", $P1 + show_value() + unbind_globals 1 + show_value() + unbind_globals 1 + show_value() +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value +.end +CODE +/Inner value +Innerer value +Inner value +Attempt to unbind 1 global/ +OUT + +pir_output_is(<<'CODE', <<OUT, "DB 8: explicit unbinding"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() + unbind_globals 1 + show_value() +.end +.sub show_value + .local pmc value + value = find_global "Foo::Bar", "test" + print value +.end +CODE +Outer value +Inner value +Outer value +Outer value +OUT + +pir_output_is(<<'CODE', <<OUT, "DB 9: explicit unbinding of a global global"); +.sub main :main + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "test", test1_binding + show_value() + unbind_globals 1 + show_value() +.end +.sub show_value + .local pmc value + value = find_global "test" + print value +.end +CODE +Outer value +Inner value +Outer value +Outer value +OUT + +## [this doesn't signal an unbound error. -- rgr, 30-Dec-05.] +pir_output_is(<<'CODE', <<OUT, "DB 10: binding a null PMC makes it unbound"); +.sub main :main + .include "errors.pasm" + errorson .PARROT_ERRORS_GLOBALS_FLAG + .local pmc outer + outer = new String + outer = "Outer value\n" + store_global "Foo::Bar", "test", outer + show_value() + test1() + show_value() +.end +.sub test1 + .local pmc test1_binding, null_binding + test1_binding = new String + test1_binding = "Inner value\n" + bind_global "Foo::Bar", "test", test1_binding + show_value() + null null_binding + bind_global "Foo::Bar", "test", null_binding + show_value() +.end +.sub show_value + .local pmc value + .local int bound_p + value = find_global "Foo::Bar", "test" + bound_p = defined value + if bound_p goto bound + print "(unbound)\n" + goto done +bound: + print value +done: +.end +CODE +Outer value +Inner value +(unbound) +Outer value +OUT + ## remember to change the number of tests :-) -BEGIN { plan tests => 4; } +BEGIN { plan tests => 16; }