[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-2-30-gafe
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-2-30-gafe5e6b |
|
Date: |
Thu, 20 Aug 2009 16:57:36 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=afe5e6baa76796b1467890fd55416a7f304bed5c
The branch, master has been updated
via afe5e6baa76796b1467890fd55416a7f304bed5c (commit)
via 2fb924f64f6cf47a9b4d6e8a22433ac2c5739379 (commit)
via cdde57b2f11a6c28518aebed234b98ce5bd7131f (commit)
via 12136c7148485e1a32cc1c59797289f46706fd45 (commit)
via 32aa2111591bb4a98124646d26d92d17d1b6dc6d (commit)
via 7ea9a0a764f7219deb4eb3bd85b60e9d8368aca5 (commit)
via 8274228f79ac2b2371b83d0e88b648c18d2e6103 (commit)
via b7946e9ec6cfb9d2d50d9f4e8cbf2532924b0a5b (commit)
via 03e6c1659623d1aac4121730c1e453c626042c47 (commit)
via d94be25f72d217a484b4f4c9b742c610fc9e501c (commit)
via 609edba7eaa2bb30df90a09541a48d97ab4a3bf8 (commit)
via 48a0fe4d6bd105bcf959752df4ac8704c9bb218a (commit)
from 53a468dd8c2d8a6552b1b7ed4025414fc219d21d (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit afe5e6baa76796b1467890fd55416a7f304bed5c
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 14:33:38 2009 +0200
eval is actually compile
* module/ice-9/boot-9.scm (eval): Here at the tail of boot-9, replace
the root definition of `eval' with a procedure that will call
`compile'.
* test-suite/tests/syntax.test ("top-level define"):
("internal define"): Run unmemoization tests in the interpreter, using
primitive-eval.
commit 2fb924f64f6cf47a9b4d6e8a22433ac2c5739379
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 14:27:38 2009 +0200
programs have their own tc7 now
* libguile/tags.h (scm_tc7_program):
* libguile/programs.h: Programs now have their own tc7 code. Fix up the
macros appropriately.
* libguile/programs.c: Remove smobby bits, leaving marking, printing,
and application for other parts of Guile.
* libguile/debug.c (scm_procedure_source):
* libguile/eval.c (scm_trampoline_0, scm_trampoline_1)
(scm_trampoline_2): Add cases for tc7_program.
* libguile/eval.i.c (CEVAL, SCM_APPLY):
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/gc-card.c (scm_i_sweep_card, scm_i_tag_name):
* libguile/gc-mark.c (1):
* libguile/print.c (iprin1):
* libguile/procs.c (scm_procedure_p, scm_thunk_p)
* libguile/vm-i-system.c (make-closure): Adapt to new procedure
representation.
* libguile/procprop.c (scm_i_procedure_arity): Do the right thing for
programs.
* test-suite/tests/procprop.test ("procedure-arity"): Arity test now
succeeds.
* libguile/goops.c (scm_class_of): Programs now belong to the class
<procedure>, not a smob class.
* libguile/vm.h (struct vm, struct vm_cont):
* libguile/vm-engine.c (vm_engine):
* libguile/frames.h (SCM_FRAME_BYTE_CAST, struct vm_frame):
* libguile/frames.c (scm_c_make_vm_frame): Fix usages of scm_byte_t,
changing them to scm_t_uint8.
commit cdde57b2f11a6c28518aebed234b98ce5bd7131f
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 12:55:05 2009 +0200
eval-elisp uses primitive-eval
* lang/elisp/interface.scm (eval-elisp): Use primitive-eval, as we will
be switching the evaluator soon.
commit 12136c7148485e1a32cc1c59797289f46706fd45
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 12:48:11 2009 +0200
define @bind using syntax-case
* module/ice-9/boot-9.scm (@bind): Define a VM-compatible syntax
definition for this old evaluator primitive.
* test-suite/tests/dynamic-scope.test: Change the expected error
messages.
commit 32aa2111591bb4a98124646d26d92d17d1b6dc6d
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 12:47:11 2009 +0200
use primitive-eval in run-vm-tests.scm
* testsuite/run-vm-tests.scm (run-vm-tests): Use primitive-eval, as
we'll be changing eval soon.
commit 7ea9a0a764f7219deb4eb3bd85b60e9d8368aca5
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 12:46:36 2009 +0200
better VM error messages
* libguile/vm-engine.c: Attempt to make error messages more friendly
and uniform with historical expectation.
commit 8274228f79ac2b2371b83d0e88b648c18d2e6103
Author: Andy Wingo <address@hidden>
Date: Sat Aug 15 14:27:15 2009 +0200
update docs for calling convention change
* doc/ref/vm.texi: Update.
commit b7946e9ec6cfb9d2d50d9f4e8cbf2532924b0a5b
Author: Andy Wingo <address@hidden>
Date: Sat Aug 15 14:15:56 2009 +0200
push new frame on stack before procedure & args
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump
* libguile/vm-engine.c (vm_engine): Push a frame corresponding to the
mv-call.
* libguile/vm-i-system.c: Renumber ops.
(new-frame): New op, pushes a frame.
(call, mv-call): No need to shuffle args, though we do need to pop the
frame in the non-vm call case.
(goto/args): Inconsequential tweaks.
(call/cc): Push a frame if needed.
* module/language/tree-il/compile-glil.scm (flatten): Emit `new-frame'
as appropriate.
* test-suite/tests/tree-il.test: Fix to expect new-frame.
commit 03e6c1659623d1aac4121730c1e453c626042c47
Author: Andy Wingo <address@hidden>
Date: Sat Aug 15 14:13:08 2009 +0200
reorder frame layout
* libguile/frames.h: Reorder the frame layout so the return address
comes below the arguments.working
(SCM_FRAME_SET_RETURN_ADDRESS, SCM_FRAME_SET_MV_RETURN_ADDRESS): New
macros.
* libguile/frames.c (scm_vm_frame_arguments): Use the macros to access
the arguments.
* libguile/vm-engine.c (vm_engine): Fix for new calling convention.
* libguile/vm-engine.h (INIT_FRAME): New macro. Does part of what
NEW_FRAME used to do.
* libguile/vm-i-system.c (call, mv-call): Shuffle args up to make room
for the stack, and adapt to new calling convention.
(goto/args): Shuffling down is easier now.
(return, return/args): Adapt to new frame layout.
* libguile/vm.c (vm_mark_stack): Adapt to new frame layout, and the
possibility of there being crap on the stack.
(really_make_boot_program): Remove extraneous comment.
commit d94be25f72d217a484b4f4c9b742c610fc9e501c
Author: Andy Wingo <address@hidden>
Date: Sat Aug 15 14:11:51 2009 +0200
remove dead weight from vm-i-system.c
* libguile/vm-i-system.c: Remove mark, list-mark, cons-mark,
vector-mark, and list-break, as they are no longer used.
(call, goto/args, mv-call): Remove bits about trampolines, which was
slower, and VM continuations, which are not used (we use Guile's
continuations as the applicable objects).
Renumber ops.
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
commit 609edba7eaa2bb30df90a09541a48d97ab4a3bf8
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 18:46:09 2009 +0200
disable autocompilation in the test suite
* check-guile.in: Disable autocompilation while working in the test
suite, for now at least. We'll enable it again later.
commit 48a0fe4d6bd105bcf959752df4ac8704c9bb218a
Author: Andy Wingo <address@hidden>
Date: Thu Aug 20 17:56:44 2009 +0200
autocompiled files before installation go to a cache dir in the builddir
* libguile/load.c (scm_init_load_path): Append a slash after
XDG_CACHE_HOME.
* meta/gdb-uninstalled-guile.in:
* meta/guile.in (XDG_CACHE_HOME): Export this var so we write to a cache
within the build directory. Probably we should have a GUILE_CACHE_DIR
to be more specific, though.
* Makefile.am (clean-local): Clear the cache when making clean.
-----------------------------------------------------------------------
Summary of changes:
Makefile.am | 3 +
check-guile.in | 2 +-
doc/ref/vm.texi | 118 ++++-----
lang/elisp/interface.scm | 5 +-
libguile/_scm.h | 2 +-
libguile/debug.c | 1 +
libguile/eval.c | 3 +
libguile/eval.i.c | 22 ++
libguile/evalext.c | 1 +
libguile/frames.c | 8 +-
libguile/frames.h | 40 ++--
libguile/gc-card.c | 4 +
libguile/gc-mark.c | 8 +
libguile/goops.c | 1 +
libguile/load.c | 2 +-
libguile/print.c | 4 +
libguile/procprop.c | 6 +
libguile/procs.c | 5 +
libguile/programs.c | 70 +----
libguile/programs.h | 18 +-
libguile/tags.h | 4 +-
libguile/vm-engine.c | 31 ++-
libguile/vm-engine.h | 29 +--
libguile/vm-i-system.c | 429 +++++++++---------------------
libguile/vm.c | 17 +-
libguile/vm.h | 6 +-
meta/gdb-uninstalled-guile.in | 4 +-
meta/guile.in | 4 +-
module/ice-9/boot-9.scm | 40 +++
module/language/tree-il/compile-glil.scm | 6 +
test-suite/tests/dynamic-scope.test | 16 +-
test-suite/tests/procprop.test | 4 +-
test-suite/tests/syntax.test | 46 ++--
test-suite/tests/tree-il.test | 10 +-
testsuite/run-vm-tests.scm | 3 +-
35 files changed, 418 insertions(+), 554 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 4562ddd..80231bb 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -42,6 +42,9 @@ DISTCLEANFILES = check-guile.log
dist-hook: gen-ChangeLog
+clean-local:
+ rm -rf cache/
+
gen_start_rev = 61db429e251bfd2f75cb4632972e0238056eb24b
.PHONY: gen-ChangeLog
gen-ChangeLog:
diff --git a/check-guile.in b/check-guile.in
index 3162fa6..dde51b3 100644
--- a/check-guile.in
+++ b/check-guile.in
@@ -41,7 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
- -e main -s "$TEST_SUITE_DIR/guile-test" \
+ --no-autocompile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 59798d8..04a3b79 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -159,17 +159,19 @@ The structure of the fixed part of an application frame
is as follows:
@example
Stack
- | | <- fp + bp->nargs + bp->nlocs + 3
- +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
- | Return address |
- | MV return address|
- | Dynamic link | <- fp + bp->nargs + bp->nlocs
- | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | ... |
+ | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs =
SCM_FRAME_UPPER_ADDRESS (fp)
+ +==================+
+ | Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
- +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ +------------------+
+ | Return address |
+ | MV return address|
+ | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) =
SCM_FRAME_LOWER_ADDRESS (fp)
+ +==================+
| |
@end example
@@ -649,32 +651,30 @@ closures.
@node Procedural Instructions
@subsubsection Procedural Instructions
address@hidden Instruction return
-Free the program's frame, returning the top value from the stack to
-the current continuation. (The stack should have exactly one value on
-it.)
-
-Specifically, the @code{sp} is decremented to one below the current
address@hidden, the @code{ip} is reset to the current return address, the
address@hidden is reset to the value of the current dynamic link, and then
-the top item on the stack (formerly the procedure being applied) is
-set to the returned value.
address@hidden Instructions new-frame
+Push a new frame on the stack, reserving space for the dynamic link,
+return address, and the multiple-values return address. The frame
+pointer is not yet updated, because the frame is not yet active -- it
+has to be patched by a @code{call} instruction to get the return
+address.
@end deffn
@deffn Instruction call nargs
Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
-For compiled procedures, this instruction sets up a new stack frame,
-as described in @ref{Stack Layout}, and then dispatches to the first
-instruction in the called procedure, relying on the called procedure
-to return one value to the newly-created continuation. Because the new
-frame pointer will point to sp[-nargs + 1], the arguments don't have
-to be shuffled around -- they are already in place.
+This instruction requires that a new frame be pushed on the stack
+before the procedure, via @code{new-frame}. @xref{Stack Layout}, for
+more information. It patches up that frame with the current @code{ip}
+as the return address, then dispatches to the first instruction in the
+called procedure, relying on the called procedure to return one value
+to the newly-created continuation. Because the new frame pointer will
+point to sp[-nargs + 1], the arguments don't have to be shuffled
+around -- they are already in place.
For non-compiled procedures (continuations, primitives, and
-interpreted procedures), @code{call} will pop the procedure and
-arguments off the stack, and push the result of calling
+interpreted procedures), @code{call} will pop the frame, procedure,
+and arguments off the stack, and push the result of calling
@code{scm_apply}.
@end deffn
@@ -682,10 +682,10 @@ arguments off the stack, and push the result of calling
Like @code{call}, but reusing the current continuation. This
instruction implements tail calls as required by RnRS.
-For compiled procedures, that means that @code{goto/args} reuses the
-current frame instead of building a new one. The @code{goto/*}
-instruction family is named as it is because tail calls are equivalent
-to @code{goto}, along with relabeled variables.
+For compiled procedures, that means that @code{goto/args} simply
+shuffles down the procedure and arguments to the current stack frame.
+The @code{goto/*} instruction family is named as it is because tail
+calls are equivalent to @code{goto}, along with relabeled variables.
For non-VM procedures, the result is the same, but the current VM
invocation remains on the C stack. True tail calls are not currently
@@ -708,15 +708,6 @@ These instructions are used in the implementation of
multiple value
returns, where the actual number of values is pushed on the stack.
@end deffn
address@hidden Instruction call/cc
address@hidden Instruction goto/cc
-Capture the current continuation, and then call (or tail-call) the
-procedure on the top of the stack, with the continuation as the
-argument.
-
-Both the VM continuation and the C continuation are captured.
address@hidden deffn
-
@deffn Instruction mv-call nargs offset
Like @code{call}, except that a multiple-value continuation is created
in addition to a single-value continuation.
@@ -729,6 +720,18 @@ the stack to be the number of values, and below that values
themselves, pushed separately.
@end deffn
address@hidden Instruction return
+Free the program's frame, returning the top value from the stack to
+the current continuation. (The stack should have exactly one value on
+it.)
+
+Specifically, the @code{sp} is decremented to one below the current
address@hidden, the @code{ip} is reset to the current return address, the
address@hidden is reset to the value of the current dynamic link, and then
+the top item on the stack (formerly the procedure being applied) is
+set to the returned value.
address@hidden deffn
+
@deffn Instruction return/values nvalues
Return the top @var{nvalues} to the current continuation.
@@ -763,6 +766,19 @@ be 1 (to indicate that one of the bindings was a rest
argument).
Signals an error if there is an insufficient number of values.
@end deffn
address@hidden Instruction call/cc
address@hidden Instruction goto/cc
+Capture the current continuation, and then call (or tail-call) the
+procedure on the top of the stack, with the continuation as the
+argument.
+
address@hidden/cc} does not require a @code{new-frame} to be pushed on the
+stack, as @code{call} does, because it needs to capture the stack
+before the frame is pushed.
+
+Both the VM continuation and the C continuation are captured.
address@hidden deffn
+
@node Data Control Instructions
@subsubsection Data Control Instructions
@@ -838,32 +854,6 @@ popping off those values and pushing on the resulting
vector. @var{n}
is a two-byte value, like in @code{vector}.
@end deffn
address@hidden Instruction mark
-Pushes a special value onto the stack that other stack instructions
-like @code{list-mark} can use.
address@hidden deffn
-
address@hidden Instruction list-mark
-Create a list from values from the stack, as in @code{list}, but
-instead of knowing beforehand how many there will be, keep going until
-we see a @code{mark} value.
address@hidden deffn
-
address@hidden Instruction cons-mark
-As the scheme procedure @code{cons*} is to the scheme procedure
address@hidden, so the instruction @code{cons-mark} is to the instruction
address@hidden
address@hidden deffn
-
address@hidden Instruction vector-mark
-Like @code{list-mark}, but makes a vector instead of a list.
address@hidden deffn
-
address@hidden Instruction list-break
-The opposite of @code{list}: pops a value, which should be a list, and
-pushes its elements on the stack.
address@hidden deffn
-
@node Miscellaneous Instructions
@subsubsection Miscellaneous Instructions
diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm
index fcd748f..31864cc 100644
--- a/lang/elisp/interface.scm
+++ b/lang/elisp/interface.scm
@@ -20,7 +20,10 @@
(define (eval-elisp x)
"Evaluate the Elisp expression @var{x}."
- (eval x the-elisp-module))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module the-elisp-module)
+ (primitive-eval x))))
(define (translate-elisp x)
"Translate the Elisp expression @var{x} to equivalent Scheme code."
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 627c51e..8a9a211 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -172,7 +172,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION B
+#define SCM_OBJCODE_MINOR_VERSION D
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/debug.c b/libguile/debug.c
index 71278c5..4bf3111 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -363,6 +363,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0,
0,
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
break;
case scm_tcs_subrs:
+ case scm_tc7_program:
procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */
diff --git a/libguile/eval.c b/libguile/eval.c
index 6a6a0ce..1563b51 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -3328,6 +3328,7 @@ scm_trampoline_0 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_0;
break;
default:
@@ -3454,6 +3455,7 @@ scm_trampoline_1 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_1;
break;
default:
@@ -3548,6 +3550,7 @@ scm_trampoline_2 (SCM proc)
break;
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_2;
break;
default:
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 99aa265..461349a 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1132,6 +1132,8 @@ dispatch:
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+ case scm_tc7_program:
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@@ -1243,6 +1245,8 @@ dispatch:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr:
RETURN (SCM_BOOL_T);
+ case scm_tc7_program:
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
@@ -1353,6 +1357,12 @@ dispatch:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_program:
+ { SCM args[2];
+ args[0] = arg1;
+ args[1] = arg2;
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
+ }
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@@ -1492,6 +1502,8 @@ dispatch:
SCM_CDDR (debug.info->a.args)));
case scm_tc7_gsubr:
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
+ case scm_tc7_program:
+ RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
debug.info->a.proc = proc;
@@ -1563,6 +1575,11 @@ dispatch:
scm_cons2 (arg1, arg2,
scm_ceval_args (x, env,
proc))));
+ case scm_tc7_program:
+ RETURN (scm_vm_apply
+ (scm_the_vm (), proc,
+ scm_cons (arg1, scm_cons (arg2,
+ scm_ceval_args (x, env, proc)))));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
@@ -1798,6 +1815,11 @@ tail:
args = SCM_CDR (args);
}
RETURN (arg1);
+ case scm_tc7_program:
+ if (SCM_UNBNDP (arg1))
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
+ else
+ RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
case scm_tc7_rpsubr:
if (scm_is_null (args))
RETURN (SCM_BOOL_T);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 19d8f2e..b1f185c 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -82,6 +82,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_pws:
+ case scm_tc7_program:
case scm_tcs_subrs:
case scm_tcs_struct:
return SCM_BOOL_T;
diff --git a/libguile/frames.c b/libguile/frames.c
index e89184d..737babc 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -33,7 +33,7 @@ scm_t_bits scm_tc16_vm_frame;
SCM
scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_byte_t *ip, scm_t_ptrdiff offset)
+ scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
"vmframe");
@@ -111,12 +111,12 @@ SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments",
1, 0, 0,
if (!bp->nargs)
return SCM_EOL;
else if (bp->nrest)
- ret = fp[bp->nargs - 1];
+ ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
else
- ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
+ ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (fp[i], ret);
+ ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
return ret;
}
diff --git a/libguile/frames.h b/libguile/frames.h
index 1b3153a..0165924 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -30,39 +30,46 @@
/* VM Frame Layout
---------------
- | | <- fp + bp->nargs + bp->nlocs + 3
- +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
- | Return address |
- | MV return address|
- | Dynamic link | <- fp + bp->nargs + bp->blocs
- | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | ... |
+ | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs =
SCM_FRAME_UPPER_ADDRESS (fp)
+ +==================+
+ | Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
- +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ +------------------+
+ | Return address |
+ | MV return address|
+ | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) =
SCM_FRAME_LOWER_ADDRESS (fp)
+ +==================+
| |
As can be inferred from this drawing, it is assumed that
`sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
assumed to be as long as SCM objects. */
-#define SCM_FRAME_DATA_ADDRESS(fp) \
- (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3)
-#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
+#define SCM_FRAME_UPPER_ADDRESS(fp) \
+ (fp \
+ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra);
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra);
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
-#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
@@ -79,7 +86,7 @@ struct scm_vm_frame
SCM stack_holder;
SCM *fp;
SCM *sp;
- scm_byte_t *ip;
+ scm_t_uint8 *ip;
scm_t_ptrdiff offset;
};
@@ -92,9 +99,8 @@ struct scm_vm_frame
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-/* FIXME rename scm_byte_t */
SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_byte_t *ip, scm_t_ptrdiff offset);
+ scm_t_uint8 *ip, scm_t_ptrdiff offset);
SCM_API SCM scm_vm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);
diff --git a/libguile/gc-card.c b/libguile/gc-card.c
index 85520f8..af29233 100644
--- a/libguile/gc-card.c
+++ b/libguile/gc-card.c
@@ -162,6 +162,8 @@ scm_i_sweep_card (scm_t_cell *card, SCM *free_list,
scm_t_heap_segment *seg)
break;
case scm_tc7_variable:
break;
+ case scm_tc7_program:
+ break;
case scm_tcs_subrs:
/* the various "subrs" (primitives) are never freed */
continue;
@@ -386,6 +388,8 @@ scm_i_tag_name (scm_t_bits tag)
return "closures";
case scm_tc7_pws:
return "pws";
+ case scm_tc7_program:
+ return "program";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c
index 8471450..ccbcdcc 100644
--- a/libguile/gc-mark.c
+++ b/libguile/gc-mark.c
@@ -40,6 +40,7 @@ extern unsigned long *
__libc_ia64_register_backing_store_base;
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
+#include "libguile/programs.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
@@ -285,6 +286,13 @@ scm_gc_mark_dependencies (SCM p)
scm_gc_mark (SCM_CLOSCAR (ptr));
ptr = SCM_ENV (ptr);
goto gc_mark_nimp;
+ case scm_tc7_program:
+ if (SCM_PROGRAM_FREE_VARIABLES (ptr) != SCM_BOOL_F)
+ scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (ptr));
+ if (SCM_PROGRAM_OBJTABLE (ptr) != SCM_BOOL_F)
+ scm_gc_mark (SCM_PROGRAM_OBJTABLE (ptr));
+ ptr = SCM_PROGRAM_OBJCODE (ptr);
+ goto gc_mark_nimp;
case scm_tc7_vector:
i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
if (i == 0)
diff --git a/libguile/goops.c b/libguile/goops.c
index c286dbe..8145e41 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -241,6 +241,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
return scm_class_procedure;
case scm_tc7_gsubr:
+ case scm_tc7_program:
return scm_class_procedure;
case scm_tc7_pws:
return scm_class_procedure_with_setter;
diff --git a/libguile/load.c b/libguile/load.c
index 8a6fadb..9e54dfa 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -257,7 +257,7 @@ scm_init_load_path ()
"guile/ccache/" SCM_EFFECTIVE_VERSION "-"
SCM_OBJCODE_MACHINE_VERSION_STRING
if ((e = getenv ("XDG_CACHE_HOME")))
- snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e);
+ snprintf (cachedir, sizeof(cachedir), "%s/" FALLBACK_DIR, e);
else if ((e = getenv ("HOME")))
snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, e);
#ifdef HAVE_GETPWENT
diff --git a/libguile/print.c b/libguile/print.c
index 152baef..74f7d8d 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -35,6 +35,7 @@
#include "libguile/procprop.h"
#include "libguile/read.h"
#include "libguile/weaks.h"
+#include "libguile/programs.h"
#include "libguile/unif.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
@@ -682,6 +683,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_variable:
scm_i_variable_print (exp, port, pstate);
break;
+ case scm_tc7_program:
+ scm_i_program_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
diff --git a/libguile/procprop.c b/libguile/procprop.c
index df96eaa..5054291 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -33,6 +33,7 @@
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
+#include "libguile/programs.h"
#include "libguile/validate.h"
#include "libguile/procprop.h"
@@ -72,6 +73,11 @@ scm_i_procedure_arity (SCM proc)
case scm_tc7_lsubr:
r = 1;
break;
+ case scm_tc7_program:
+ a += SCM_PROGRAM_DATA (proc)->nargs;
+ r = SCM_PROGRAM_DATA (proc)->nrest;
+ a -= r;
+ break;
case scm_tc7_lsubr_2:
a += 2;
r = 1;
diff --git a/libguile/procs.c b/libguile/procs.c
index d873ff5..815e29f 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -112,6 +112,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
case scm_tcs_closures:
case scm_tcs_subrs:
case scm_tc7_pws:
+ case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
@@ -151,6 +152,10 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
return SCM_BOOL_T;
case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
+ case scm_tc7_program:
+ return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
+ || (SCM_PROGRAM_DATA (obj)->nargs == 1
+ && SCM_PROGRAM_DATA (obj)->nrest));
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
diff --git a/libguile/programs.c b/libguile/programs.c
index 5c43ac5..b2bf806 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -31,8 +31,6 @@
#include "vm.h"
-scm_t_bits scm_tc16_program;
-
static SCM write_program = SCM_BOOL_F;
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
@@ -50,49 +48,13 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
else if (free_variables != SCM_BOOL_F)
SCM_VALIDATE_VECTOR (3, free_variables);
- SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
+ return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode,
+ (scm_t_bits)objtable, (scm_t_bits)free_variables);
}
#undef FUNC_NAME
-static SCM
-program_mark (SCM obj)
-{
- if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
- scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
- if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
- scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
- return SCM_PROGRAM_OBJCODE (obj);
-}
-
-static SCM
-program_apply (SCM program, SCM args)
-{
- return scm_vm_apply (scm_the_vm (), program, args);
-}
-
-static SCM
-program_apply_0 (SCM program)
-{
- return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
-}
-
-static SCM
-program_apply_1 (SCM program, SCM a)
-{
- return scm_c_vm_run (scm_the_vm (), program, &a, 1);
-}
-
-static SCM
-program_apply_2 (SCM program, SCM a, SCM b)
-{
- SCM args[2];
- args[0] = a;
- args[1] = b;
- return scm_c_vm_run (scm_the_vm (), program, args, 2);
-}
-
-static int
-program_print (SCM program, SCM port, scm_print_state *pstate)
+void
+scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
static int print_error = 0;
@@ -102,12 +64,17 @@ program_print (SCM program, SCM port, scm_print_state
*pstate)
scm_from_locale_symbol ("write-program"));
if (SCM_FALSEP (write_program) || print_error)
- return scm_smob_print (program, port, pstate);
-
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- return 1;
+ {
+ scm_puts ("#<program ", port);
+ scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else
+ {
+ print_error = 1;
+ scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
+ print_error = 0;
+ }
}
@@ -319,13 +286,6 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0,
0,
void
scm_bootstrap_programs (void)
{
- scm_tc16_program = scm_make_smob_type ("program", 0);
- scm_set_smob_mark (scm_tc16_program, program_mark);
- scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
- scm_set_smob_print (scm_tc16_program, program_print);
scm_c_register_extension ("libguile", "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs,
NULL);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index 040e8ea..d52631f 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -26,19 +26,15 @@
* Programs
*/
-typedef unsigned char scm_byte_t;
+#define SCM_F_PROGRAM_IS_BOOT (1<<16)
-SCM_API scm_t_bits scm_tc16_program;
-
-#define SCM_F_PROGRAM_IS_BOOT (1<<0)
-
-#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
-#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
-#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
+#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
+#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_3 (x))
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
+#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
@@ -58,6 +54,8 @@ SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
SCM_INTERNAL void scm_init_programs (void);
diff --git a/libguile/tags.h b/libguile/tags.h
index 3294533..9a11df5 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -453,11 +453,11 @@ typedef unsigned long scm_t_bits;
#define scm_tc7_unused_6 55
#define scm_tc7_unused_7 71
#define scm_tc7_unused_8 77
-#define scm_tc7_unused_9 79
#define scm_tc7_dsubr 61
#define scm_tc7_gsubr 63
#define scm_tc7_rpsubr 69
+#define scm_tc7_program 79
#define scm_tc7_subr_0 85
#define scm_tc7_subr_1 87
#define scm_tc7_cxr 93
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index b0888c1..b373cd0 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -41,7 +41,7 @@ static SCM
VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
{
/* VM registers */
- register scm_byte_t *ip IP_REG; /* instruction pointer */
+ register scm_t_uint8 *ip IP_REG; /* instruction pointer */
register SCM *sp SP_REG; /* stack pointer */
register SCM *fp FP_REG; /* frame pointer */
@@ -107,11 +107,17 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* Initial frame */
CACHE_REGISTER ();
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* ra */
+ PUSH (0); /* mvra */
CACHE_PROGRAM ();
PUSH (program);
- NEW_FRAME ();
-
- /* Initial arguments */
+ fp = sp + 1;
+ INIT_FRAME ();
+ /* MV-call frame, function & arguments */
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* ra */
+ PUSH (0); /* mvra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
@@ -152,12 +158,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
SCM err_msg;
vm_error_bad_instruction:
- err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
+ err_msg = scm_from_locale_string ("VM: Bad instruction: ~s");
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
goto vm_error;
vm_error_unbound:
- err_msg = scm_from_locale_string ("VM: Unbound variable: ~A");
+ err_msg = scm_from_locale_string ("VM: Unbound variable: ~s");
goto vm_error;
vm_error_wrong_type_arg:
@@ -178,10 +184,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
goto vm_error;
vm_error_wrong_type_apply:
- err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
- "[IP offset: ~a]");
- finish_args = scm_list_2 (program,
- SCM_I_MAKINUM (ip - bp->base));
+ SYNC_ALL ();
+ scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S",
+ scm_list_1 (program), SCM_BOOL_F);
goto vm_error;
vm_error_stack_overflow:
@@ -195,7 +200,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
goto vm_error;
vm_error_improper_list:
- err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper
list: tail is ~A");
+ err_msg = scm_from_locale_string ("Expected a proper list, but got object
with tail ~s");
goto vm_error;
vm_error_not_a_pair:
@@ -211,12 +216,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
goto vm_error;
vm_error_no_values:
- err_msg = scm_from_locale_string ("VM: 0-valued return");
+ err_msg = scm_from_locale_string ("Zero values returned to single-valued
continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_not_enough_values:
- err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind");
+ err_msg = scm_from_locale_string ("Too few values returned to
continuation");
finish_args = SCM_EOL;
goto vm_error;
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 240969c..36d4d28 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -386,34 +386,29 @@ do { \
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
and the arguments are already on the stack */
-#define NEW_FRAME() \
+#define INIT_FRAME() \
{ \
int i; \
- SCM *dl, *data; \
- scm_byte_t *ra = ip; \
- \
- /* Save old registers */ \
- ra = ip; \
- dl = fp; \
\
/* New registers */ \
- fp = sp - bp->nargs + 1; \
- data = SCM_FRAME_DATA_ADDRESS (fp); \
- sp = data + 2; \
+ sp += bp->nlocs; \
CHECK_OVERFLOW (); \
stack_base = sp; \
ip = bp->base; \
\
/* Init local variables */ \
- for (i=bp->nlocs; i; i--) \
- data[-i] = SCM_UNDEFINED; \
- \
- /* Set frame data */ \
- data[2] = (SCM)ra; \
- data[1] = 0x0; \
- data[0] = (SCM)dl; \
+ for (i=bp->nlocs; i;) \
+ sp[-(--i)] = SCM_UNDEFINED; \
}
+#define DROP_FRAME() \
+ { \
+ sp -= 3; \
+ NULLSTACK (3); \
+ CHECK_UNDERFLOW (); \
+ }
+
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index b298c88..0662f81 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -71,13 +71,7 @@ VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
-{
- PUSH (SCM_UNDEFINED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (4, dup, "dup", 0, 0, 1)
{
SCM x = *sp;
PUSH (x);
@@ -89,49 +83,49 @@ VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
* Object creation
*/
-VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (5, void, "void", 0, 0, 1)
{
PUSH (SCM_UNSPECIFIED);
NEXT;
}
-VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (6, make_true, "make-true", 0, 0, 1)
{
PUSH (SCM_BOOL_T);
NEXT;
}
-VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1)
{
PUSH (SCM_BOOL_F);
NEXT;
}
-VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
{
PUSH (SCM_EOL);
NEXT;
}
-VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
{
PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
{
PUSH (SCM_INUM0);
NEXT;
}
-VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
{
PUSH (SCM_I_MAKINUM (1));
NEXT;
}
-VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
{
int h = FETCH ();
int l = FETCH ();
@@ -139,7 +133,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0,
1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -154,7 +148,7 @@ VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0,
1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
{
scm_t_uint64 v = 0;
v += FETCH ();
@@ -169,7 +163,7 @@ VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
{
scm_t_uint8 v = 0;
v = FETCH ();
@@ -181,7 +175,7 @@ VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0,
1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
+VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -221,34 +215,6 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
-{
- POP_CONS_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- SYNC_REGISTER ();
- *sp = scm_vector (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
-{
- SCM l;
- POP (l);
- PUSH_LIST (l, SCM_NULLP);
- NEXT;
-}
-
/*
* Variable access
@@ -271,7 +237,7 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0,
0)
/* ref */
-VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -280,7 +246,7 @@ VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0,
1)
}
/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
{
unsigned int objnum = FETCH ();
objnum <<= 8;
@@ -290,14 +256,14 @@ VM_DEFINE_INSTRUCTION (24, long_object_ref,
"long-object-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -307,7 +273,7 @@ VM_DEFINE_INSTRUCTION (26, long_local_ref,
"long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -326,7 +292,7 @@ VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -349,7 +315,7 @@ VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (25, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -376,14 +342,14 @@ VM_DEFINE_INSTRUCTION (29, long_toplevel_ref,
"long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -393,14 +359,14 @@ VM_DEFINE_INSTRUCTION (31, long_local_set,
"long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -419,7 +385,7 @@ VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1,
1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -464,7 +430,7 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set,
"long-toplevel-set", 2, 1, 0)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
{
scm_t_int16 offset;
FETCH_OFFSET (offset);
@@ -472,34 +438,34 @@ VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -509,7 +475,15 @@ VM_DEFINE_INSTRUCTION (41, br_if_not_null,
"br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
+{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -528,71 +502,32 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
+ fp = sp - bp->nargs + 1;
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* Seems to slow down the fibo test, dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- NEXT;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- NEXT;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- NEXT;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
- /* At this point, the stack contains the procedure and each one of its
- arguments. */
+ SCM args;
+ /* At this point, the stack contains the frame, the procedure and each
one
+ of its arguments. */
POP_LIST (nargs);
+ POP (args);
+ DROP (); /* drop the procedure */
+ DROP_FRAME ();
+
SYNC_REGISTER ();
- /* keep args on stack so they are marked */
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* truncate values */
@@ -605,32 +540,12 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- vm_call_continuation:
- /* Check the number of arguments */
- /* FIXME multiple args */
- if (nargs != 1)
- scm_wrong_num_args (program);
-
- /* Reinstate the continuation */
- EXIT_HOOK ();
- reinstate_vm_cont (vp, program);
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -641,151 +556,55 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1,
-1, 1)
SCM_TICK; /* allow interrupt here */
/*
- * Tail recursive call
- */
- if (SCM_EQ_P (x, program))
- {
- int i;
-
- /* Move arguments */
- INIT_ARGS ();
- sp -= bp->nargs - 1;
- for (i = 0; i < bp->nargs; i++)
- LOCAL_SET (i, sp[i]);
-
- /* Drop the first argument and the program itself. */
- sp -= 2;
- NULLSTACK (bp->nargs + 1);
-
- /* Init locals to valid SCM values */
- for (i = 0; i < bp->nlocs; i++)
- LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
-
- /* Call itself */
- ip = bp->base;
- APPLY_HOOK ();
- NEXT;
- }
-
- /*
- * Tail call, but not to self -- reuse the frame, keeping the ra and dl
+ * Tail call
*/
if (SCM_PROGRAM_P (x))
{
- SCM *data, *tail_args, *dl;
int i;
- scm_byte_t *ra, *mvra;
#ifdef VM_ENABLE_STACK_NULLING
SCM *old_sp;
#endif
EXIT_HOOK ();
- /* save registers */
- tail_args = stack_base + 2;
- ra = SCM_FRAME_RETURN_ADDRESS (fp);
- mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- dl = SCM_FRAME_DYNAMIC_LINK (fp);
-
/* switch programs */
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- /* delay updating the frame so that if INIT_ARGS has to cons up a rest
- arg, going into GC, the stack still makes sense */
- fp[-1] = program;
- nargs = bp->nargs;
#ifdef VM_ENABLE_STACK_NULLING
old_sp = sp;
CHECK_STACK_LEAK ();
#endif
- /* new registers -- logically this would be better later, but let's make
- sure we have space for the locals now */
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ip = bp->base;
- stack_base = data + 2;
- sp = stack_base;
- CHECK_OVERFLOW ();
-
- /* copy args, bottom-up */
- for (i = 0; i < nargs; i++)
- fp[i] = tail_args[i];
+ /* delay shuffling the new program+args down so that if INIT_ARGS had to
+ cons up a rest arg, going into GC, the stack still made sense */
+ for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++)
+ fp[i] = sp[i];
+ sp = fp + i - 1;
NULLSTACK (old_sp - sp);
- /* init locals */
- for (i = bp->nlocs; i; i--)
- data[-i] = SCM_UNDEFINED;
-
- /* Set frame data */
- data[2] = (SCM)ra;
- data[1] = (SCM)mvra;
- data[0] = (SCM)dl;
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* This seems to actually slow down the fibo test -- dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- goto vm_return;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- goto vm_return;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- goto vm_return;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
POP_LIST (nargs);
+ POP (args);
+
SYNC_REGISTER ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ *sp = scm_apply (x, args, SCM_EOL);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
+
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* multiple values returned to continuation */
@@ -796,21 +615,16 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1,
1)
PUSH_LIST (values, SCM_NULLP);
goto vm_return_values;
}
- goto vm_return;
+ else
+ goto vm_return;
}
program = x;
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (program))
- goto vm_call_continuation;
-
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -819,7 +633,7 @@ VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0,
1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -828,7 +642,7 @@ VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0,
1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
scm_t_int16 offset;
@@ -848,8 +662,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
- SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
+ fp = sp - bp->nargs + 1;
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -859,13 +677,17 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
/* At this point, the stack contains the procedure and each one of its
arguments. */
POP_LIST (nargs);
+ POP (args);
+ DROP (); /* drop the procedure */
+ DROP_FRAME ();
+
SYNC_REGISTER ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_VALUESP (*sp))
{
SCM values, len;
@@ -878,20 +700,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- goto vm_call_continuation;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -910,7 +724,7 @@ VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -929,7 +743,7 @@ VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1,
1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -938,6 +752,9 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
cont = scm_make_continuation (&first);
if (first)
{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (proc);
PUSH (cont);
nargs = 1;
@@ -963,7 +780,7 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -995,7 +812,7 @@ VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1003,17 +820,16 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
SYNC_REGISTER ();
SCM_TICK; /* allow interrupt here */
{
- SCM ret, *data;
- data = SCM_FRAME_DATA_ADDRESS (fp);
+ SCM ret;
POP (ret);
ASSERT (sp == stack_base);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_BYTE_CAST (data[2]);
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
{
#ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp;
@@ -1033,28 +849,25 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say.
*/
- SCM *data;
-
nvalues = FETCH ();
vm_return_values:
EXIT_HOOK ();
RETURN_HOOK ();
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* data[1] is the mv return address */
- if (nvalues != 1 && data[1])
+ if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
@@ -1073,8 +886,8 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values",
1, -1, -1)
continuation.) */
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
*++sp = stack_base[1];
@@ -1093,7 +906,7 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values",
1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1116,7 +929,7 @@ VM_DEFINE_INSTRUCTION (54, return_values_star,
"return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1139,7 +952,7 @@ VM_DEFINE_INSTRUCTION (55, truncate_values,
"truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1153,7 +966,7 @@ VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1161,7 +974,7 @@ VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1169,7 +982,7 @@ VM_DEFINE_INSTRUCTION (58, local_boxed_ref,
"local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1179,7 +992,7 @@ VM_DEFINE_INSTRUCTION (59, local_boxed_set,
"local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1190,7 +1003,7 @@ VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1201,7 +1014,7 @@ VM_DEFINE_INSTRUCTION (61, free_boxed_ref,
"free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1213,18 +1026,18 @@ VM_DEFINE_INSTRUCTION (62, free_boxed_set,
"free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
SYNC_BEFORE_GC ();
/* fixme underflow */
- SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
- SCM_PROGRAM_OBJTABLE (*sp), vect);
+ *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE
(*sp),
+ (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp),
(scm_t_bits)vect);
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1232,7 +1045,7 @@ VM_DEFINE_INSTRUCTION (64, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@@ -1246,7 +1059,7 @@ VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1258,7 +1071,7 @@ VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1266,7 +1079,7 @@ VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword",
0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (68, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
diff --git a/libguile/vm.c b/libguile/vm.c
index cc5e4f9..660f25c 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -66,21 +66,20 @@ scm_t_bits scm_tc16_vm_cont;
static void
vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
{
- SCM *sp, *upper, *lower;
+ SCM *sp, *mark;
sp = base + size - 1;
while (sp > base && fp)
{
- upper = SCM_FRAME_UPPER_ADDRESS (fp);
- lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ mark = SCM_FRAME_LOWER_ADDRESS (fp) + 3;
- for (; sp >= upper; sp--)
+ for (; sp >= mark; sp--)
if (SCM_NIMP (*sp))
{
if (scm_in_heap_p (*sp))
scm_gc_mark (*sp);
- else
- fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
+ /* this can happen for open frames */
+ /* else fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
*/
}
@@ -89,11 +88,6 @@ vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp,
scm_t_ptrdiff reloc)
/* update fp from the dynamic link */
fp = (SCM*)*sp-- + reloc;
-
- /* mark from the el down to the lower address */
- for (; sp >= lower; sp--)
- if (*sp && SCM_NIMP (*sp))
- scm_gc_mark (*sp);
}
}
@@ -224,7 +218,6 @@ static SCM
really_make_boot_program (long nargs)
{
SCM u8vec;
- /* Make sure "bytes" is 64-bit aligned. */
scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
scm_op_make_int8_1, scm_op_nop, scm_op_nop,
scm_op_nop,
scm_op_halt };
diff --git a/libguile/vm.h b/libguile/vm.h
index b079c7a..eace1cb 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -41,7 +41,7 @@ typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM
program, SCM *argv, int n
#define SCM_VM_NUM_ENGINES 2
struct scm_vm {
- scm_byte_t *ip; /* instruction pointer */
+ scm_t_uint8 *ip; /* instruction pointer */
SCM *sp; /* stack pointer */
SCM *fp; /* frame pointer */
size_t stack_size; /* stack size */
@@ -88,7 +88,7 @@ SCM_API SCM scm_vm_stats (SCM vm);
SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
- scm_byte_t *ip;
+ scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
scm_t_ptrdiff stack_size;
diff --git a/meta/gdb-uninstalled-guile.in b/meta/gdb-uninstalled-guile.in
index 1151dbc..d55e215 100644
--- a/meta/gdb-uninstalled-guile.in
+++ b/meta/gdb-uninstalled-guile.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -34,5 +34,7 @@
set -e
# env (set by configure)
top_builddir="@top_builddir_absolute@"
+XDG_CACHE_HOME=${top_builddir}/cache
+export XDG_CACHE_HOME
exec ${top_builddir}/meta/uninstalled-env libtool --mode=execute \
gdb --args ${top_builddir}/libguile/guile "$@"
diff --git a/meta/guile.in b/meta/guile.in
index ab1fe37..d1ae0d4 100644
--- a/meta/guile.in
+++ b/meta/guile.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -41,6 +41,8 @@ top_builddir="@top_builddir_absolute@"
# set GUILE (clobber)
GUILE=${top_builddir}/libguile/guile
export GUILE
+XDG_CACHE_HOME=${top_builddir}/cache
+export XDG_CACHE_HOME
# do it
exec ${top_builddir}/meta/uninstalled-env $GUILE "$@"
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 574cb2b..ead175d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -308,6 +308,38 @@
(syntax-rules ()
((_ exp) (make-promise (lambda () exp)))))
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+ (lambda (x)
+ (define (bound-member id ids)
+ (cond ((null? ids) #f)
+ ((bound-identifier=? id (car ids)) #t)
+ ((bound-member (car ids) (cdr ids)))))
+
+ (syntax-case x ()
+ ((_ () b0 b1 ...)
+ #'(let () b0 b1 ...))
+ ((_ ((id val) ...) b0 b1 ...)
+ (and-map identifier? #'(id ...))
+ (if (let lp ((ids #'(id ...)))
+ (cond ((null? ids) #f)
+ ((bound-member (car ids) (cdr ids)) #t)
+ (else (lp (cdr ids)))))
+ (syntax-violation '@bind "duplicate bound identifier" x)
+ (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+ ((v ...) (generate-temporaries #'(id ...))))
+ #'(let ((old-v id) ...
+ (v val) ...)
+ (dynamic-wind
+ (lambda ()
+ (set! id v) ...)
+ (lambda () b0 b1 ...)
+ (lambda ()
+ (set! id old-v) ...)))))))))
+
+
;;; {Defmacros}
@@ -3460,6 +3492,14 @@ module '(ice-9 q) '(make-q q-length))}."
+;;; Replace the C evaluator with the compiler.
+;;;
+
+(define (eval x env)
+ ((@ (system base compile) compile) x #:from 'scheme #:to 'value #:env env))
+
+
+
;;; Place the user in the guile-user module.
;;;
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 8886fa3..86b610f 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -286,6 +286,7 @@
(for-each comp-push args)
(emit-code src (make-glil-call 'goto/apply (1+ (length
args)))))
((push)
+ (emit-code src (make-glil-call 'new-frame 0))
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call 'apply (1+ (length args))))
@@ -343,7 +344,10 @@
(else
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
(comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
(comp-push producer)
(emit-code src (make-glil-mv-call 0 MV))
(case context
@@ -444,6 +448,8 @@
(emit-branch src 'br (lexical-ref-gensym proc)))
(else
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
(comp-push proc)
(for-each comp-push args)
(let ((len (length args)))
diff --git a/test-suite/tests/dynamic-scope.test
b/test-suite/tests/dynamic-scope.test
index 77be3b4..08cf1c4 100644
--- a/test-suite/tests/dynamic-scope.test
+++ b/test-suite/tests/dynamic-scope.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,12 +21,10 @@
:use-module (test-suite lib))
-(define exception:missing-expr
- (cons 'syntax-error "Missing expression"))
-(define exception:bad-binding
- (cons 'syntax-error "Bad binding"))
+(define exception:syntax-error
+ (cons 'syntax-error "failed to match"))
(define exception:duplicate-binding
- (cons 'syntax-error "Duplicate binding"))
+ (cons 'syntax-error "duplicate"))
(define global-a 0)
(define (fetch-global-a) global-a)
@@ -48,17 +46,17 @@
(interaction-environment)))
(pass-if-exception "@bind missing expression"
- exception:missing-expr
+ exception:syntax-error
(eval '(@bind ((global-a 1)))
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
- exception:bad-binding
+ exception:syntax-error
(eval '(@bind (a) #f)
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
- exception:bad-binding
+ exception:syntax-error
(eval '(@bind ((a)) #f)
(interaction-environment)))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 5768e1a..6af73f6 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -43,9 +43,7 @@
'(1 0 #f)))
(pass-if "apply"
- (equal? (if ((@ (system vm program) program?) apply)
- (throw 'unresolved)
- (procedure-property apply 'arity))
+ (equal? (procedure-property apply 'arity)
'(1 0 #t)))
(pass-if "cons*"
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 0593ea6..282072b 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1,6 +1,6 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009 Free Software Foundation,
Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -807,21 +807,20 @@
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
- (eval '(begin
- (define (blub) (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () (cons ('(1 . 2)) 2))))
- (interaction-environment)))
+ (primitive-eval '(begin
+ (define (blub) (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () (cons ('(1 . 2)) 2))))))
+
(pass-if "definition with documentation unmemoized without prior execution"
- (eval '(begin
- (define (blub) "Comment" (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () "Comment" (cons ('(1 . 2)) 2))))
- (interaction-environment))))
-
+ (primitive-eval '(begin
+ (define (blub) "Comment" (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () "Comment" (cons ('(1 . 2)) 2)))))))
+
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
@@ -896,16 +895,15 @@
(interaction-environment)))
(pass-if "unmemoization"
- (eval '(begin
- (define (foo)
- (define (bar)
- 'ok)
- (bar))
- (foo)
- (matches?
- (procedure-source foo)
- (lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
- (current-module))))
+ (primitive-eval '(begin
+ (define (foo)
+ (define (bar)
+ 'ok)
+ (bar))
+ (foo)
+ (matches?
+ (procedure-source foo)
+ (lambda () (letrec ((_ (lambda () (quote ok))))
(_))))))))
(with-test-prefix "set!"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 73ea9c1..ee5e4d3 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -80,7 +80,7 @@
(program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call
1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -88,7 +88,7 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+ (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar)
(call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
@@ -444,7 +444,7 @@
(assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program 0 0 0 ()
- (toplevel ref apply) (toplevel ref foo) (toplevel ref bar)
(mv-call 2 ,l1)
+ (call new-frame 0) (toplevel ref apply) (toplevel ref foo)
(toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
@@ -453,7 +453,7 @@
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel
baz)))
(program 0 0 0 ()
(toplevel ref foo)
- (toplevel ref bar) (toplevel ref baz) (call apply 2)
+ (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call
apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
@@ -463,7 +463,7 @@
(assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo))
(void))
(program 0 0 0 ()
- (toplevel ref call-with-current-continuation) (toplevel ref foo)
(mv-call 1 ,l1)
+ (call new-frame 0) (toplevel ref call-with-current-continuation)
(toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
(void) (call return 1))
diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm
index f7eba40..39e7bf1 100644
--- a/testsuite/run-vm-tests.scm
+++ b/testsuite/run-vm-tests.scm
@@ -72,8 +72,7 @@ equal in the sense of @var{equal?}."
(if (catch #t
(lambda ()
(equal? (compile/run-test-from-file file)
- (eval (fetch-sexp-from-file file)
- (interaction-environment))))
+ (primitive-eval (fetch-sexp-from-file
file))))
(lambda (key . args)
(format #t "[~a/~a] " key args)
#f))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-2-30-gafe5e6b,
Andy Wingo <=