core: Fix internal define bug.
* src/eval-apply.c (eval_apply): When evaluating 'define', recompute the 'global_p' and 'local_p' flags; when evaluating a local definition, set the closure directly instead of using 'set_x'. * tests/base.test: Add a test.
This commit is contained in:
parent
aab9e925ac
commit
84a4169428
|
@ -688,6 +688,15 @@ eval:
|
|||
goto eval;
|
||||
}
|
||||
eval_define:
|
||||
/* These may have been clobbered by an inline define
|
||||
during evaluation, so they must be recomputed. */
|
||||
global_p = 0;
|
||||
if (R0->car->car != cell_closure)
|
||||
global_p = 1;
|
||||
macro_p = 0;
|
||||
if (R2->car == cell_symbol_define_macro)
|
||||
macro_p = 1;
|
||||
|
||||
name = R2->cdr->car;
|
||||
aa = R2->cdr->car;
|
||||
if (aa->type == TPAIR)
|
||||
|
@ -706,9 +715,13 @@ eval:
|
|||
{
|
||||
entry = cons (name, R1);
|
||||
aa = cons (entry, cell_nil);
|
||||
/* Push the definition onto the current lexical
|
||||
environment, but keep the first element (named
|
||||
'*closure*') pointing to the rest of the
|
||||
environment. */
|
||||
set_cdr_x (aa, cdr (R0));
|
||||
set_cdr_x (R0, aa);
|
||||
set_x (cell_closure, aa);
|
||||
set_cdr_x (car (R0), aa);
|
||||
}
|
||||
R1 = cell_unspecified;
|
||||
goto vm_return;
|
||||
|
|
|
@ -94,6 +94,17 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
(let () (define *top-let-define-a* '*top-let-define-a*) #t)
|
||||
(pass-if-not "top let define " (defined? '*top-let-define-a*))
|
||||
|
||||
(define (lookup-toplevel name)
|
||||
(if guile?
|
||||
(module-variable (current-module) name)
|
||||
(hashq-ref (initial-module) name)))
|
||||
|
||||
(define (nested-define-value) (define x 12) x)
|
||||
(define *top-nested-define* (nested-define-value))
|
||||
(pass-if "top nested define"
|
||||
(let ((v (lookup-toplevel '*top-nested-define*)))
|
||||
(and v (equal? (variable-ref v) 12))))
|
||||
|
||||
(pass-if "apply" (sequal? (apply list '(1)) '(1)))
|
||||
(pass-if "apply 2" (sequal? (apply list 1 '(2)) '(1 2)))
|
||||
(pass-if "apply 3" (sequal? (apply list 1 2 '(3)) '(1 2 3)))
|
||||
|
|
Loading…
Reference in New Issue