summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/Makefile.am4
-rw-r--r--libguile/debug.c310
-rw-r--r--libguile/debug.h41
-rw-r--r--libguile/eval.c4746
-rw-r--r--libguile/eval.h62
-rw-r--r--libguile/init.c2
-rw-r--r--libguile/memoize.c1141
-rw-r--r--libguile/memoize.h106
-rw-r--r--libguile/modules.c43
-rw-r--r--libguile/modules.h5
-rw-r--r--libguile/print.c24
-rw-r--r--libguile/procprop.c12
-rw-r--r--libguile/procs.c2
-rw-r--r--libguile/procs.h5
-rw-r--r--libguile/srcprop.c12
-rw-r--r--libguile/stacks.c40
-rw-r--r--libguile/tags.h44
-rw-r--r--libguile/validate.h2
-rw-r--r--module/ice-9/boot-9.scm1
-rw-r--r--module/ice-9/deprecated.scm5
-rw-r--r--module/ice-9/psyntax-pp.scm9
-rw-r--r--test-suite/tests/chars.test2
-rw-r--r--test-suite/tests/eval.test7
-rw-r--r--test-suite/tests/syntax.test167
24 files changed, 1742 insertions, 5050 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 0e616f23f..a093053f3 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -154,6 +154,7 @@ libguile_la_SOURCES = \
load.c \
macros.c \
mallocs.c \
+ memoize.c \
modules.c \
null-threads.c \
numbers.c \
@@ -249,6 +250,7 @@ DOT_X_FILES = \
load.x \
macros.x \
mallocs.x \
+ memoize.x \
modules.x \
numbers.x \
objprop.x \
@@ -345,6 +347,7 @@ DOT_DOC_FILES = \
load.doc \
macros.doc \
mallocs.doc \
+ memoize.doc \
modules.doc \
numbers.doc \
objprop.doc \
@@ -507,6 +510,7 @@ modinclude_HEADERS = \
load.h \
macros.h \
mallocs.h \
+ memoize.h \
modules.h \
net_db.h \
null-threads.h \
diff --git a/libguile/debug.c b/libguile/debug.c
index 53eb16b76..f0dd29a0a 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -48,6 +48,7 @@
#include "libguile/root.h"
#include "libguile/fluids.h"
#include "libguile/programs.h"
+#include "libguile/memoize.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
@@ -77,11 +78,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
}
- SCM_RESET_DEBUG_MODE;
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
- scm_debug_eframe_size = 2 * SCM_N_FRAMES;
scm_dynwind_end ();
return ans;
@@ -131,175 +130,6 @@ SCM_SYMBOL (scm_sym_procname, "procname");
SCM_SYMBOL (scm_sym_dots, "...");
SCM_SYMBOL (scm_sym_source, "source");
-/* {Memoized Source}
- */
-
-scm_t_bits scm_tc16_memoized;
-
-static int
-memoized_print (SCM obj, SCM port, scm_print_state *pstate)
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<memoized ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
- return 1;
-}
-
-SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is memoized.")
-#define FUNC_NAME s_scm_memoized_p
-{
- return scm_from_bool(SCM_MEMOIZEDP (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_make_memoized (SCM exp, SCM env)
-{
- /* *fixme* Check that env is a valid environment. */
- SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
-}
-
-#ifdef GUILE_DEBUG
-/*
- * Some primitives for construction of memoized code
- *
- * - procedure: memcons CAR CDR [ENV]
- *
- * Construct a pair, encapsulated in a memoized object.
- *
- * The CAR and CDR can be either normal or memoized. If ENV isn't
- * specified, the top-level environment of the current module will
- * be assumed. All environments must match.
- *
- * - procedure: make-iloc FRAME BINDING CDRP
- *
- * Return an iloc referring to frame no. FRAME, binding
- * no. BINDING. If CDRP is non-#f, the iloc is referring to a
- * frame consisting of a single pair, with the value stored in the
- * CDR.
- *
- * - procedure: iloc? OBJECT
- *
- * Return #t if OBJECT is an iloc.
- *
- * - procedure: mem->proc MEMOIZED
- *
- * Construct a closure from the memoized lambda expression MEMOIZED
- *
- * WARNING! The code is not copied!
- *
- * - procedure: proc->mem CLOSURE
- *
- * Turn the closure CLOSURE into a memoized object.
- *
- * WARNING! The code is not copied!
- *
- * - constant: SCM_IM_AND
- * - constant: SCM_IM_BEGIN
- * - constant: SCM_IM_CASE
- * - constant: SCM_IM_COND
- * - constant: SCM_IM_DO
- * - constant: SCM_IM_IF
- * - constant: SCM_IM_LAMBDA
- * - constant: SCM_IM_LET
- * - constant: SCM_IM_LETSTAR
- * - constant: SCM_IM_LETREC
- * - constant: SCM_IM_OR
- * - constant: SCM_IM_QUOTE
- * - constant: SCM_IM_SET
- * - constant: SCM_IM_DEFINE
- * - constant: SCM_IM_APPLY
- * - constant: SCM_IM_CONT
- * - constant: SCM_IM_DISPATCH
- */
-
-#include "libguile/variable.h"
-#include "libguile/procs.h"
-
-SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
- (SCM car, SCM cdr, SCM env),
- "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
- "as members and @var{env} as the environment.")
-#define FUNC_NAME s_scm_memcons
-{
- if (SCM_MEMOIZEDP (car))
- {
- /*fixme* environments may be two different but equal top-level envs */
- if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
- SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
- scm_list_2 (car, env));
- else
- env = SCM_MEMOIZED_ENV (car);
- car = SCM_MEMOIZED_EXP (car);
- }
- if (SCM_MEMOIZEDP (cdr))
- {
- if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
- SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
- scm_list_2 (cdr, env));
- else
- env = SCM_MEMOIZED_ENV (cdr);
- cdr = SCM_MEMOIZED_EXP (cdr);
- }
- if (SCM_UNBNDP (env))
- env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
- else
- SCM_VALIDATE_NULLORCONS (3, env);
- return scm_make_memoized (scm_cons (car, cdr), env);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
- (SCM obj),
- "Convert a memoized object (which must represent a body)\n"
- "to a procedure.")
-#define FUNC_NAME s_scm_mem_to_proc
-{
- SCM env;
- SCM_VALIDATE_MEMOIZED (1, obj);
- env = SCM_MEMOIZED_ENV (obj);
- obj = SCM_MEMOIZED_EXP (obj);
- return scm_closure (obj, env);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
- (SCM obj),
- "Convert a procedure to a memoized object.")
-#define FUNC_NAME s_scm_proc_to_mem
-{
- SCM_VALIDATE_CLOSURE (1, obj);
- return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
-}
-#undef FUNC_NAME
-
-#endif /* GUILE_DEBUG */
-
-SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
- (SCM m),
- "Unmemoize the memoized expression @var{m},")
-#define FUNC_NAME s_scm_i_unmemoize_expr
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
- (SCM m),
- "Return the environment of the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_environment
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return SCM_MEMOIZED_ENV (m);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
(SCM proc),
"Return the name of the procedure @var{proc}")
@@ -333,74 +163,32 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
"Return the source of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_source
{
- SCM_VALIDATE_NIM (1, proc);
- again:
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- const SCM body = SCM_CLOSURE_BODY (proc);
- const SCM src = scm_source_property (body, scm_sym_copy);
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
- if (scm_is_true (src))
- {
- return scm_cons2 (scm_sym_lambda, formals, src);
- }
- else
- {
- const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- return scm_cons2 (scm_sym_lambda,
- scm_i_finite_list_copy (formals),
- scm_i_unmemocopy_body (body, env));
- }
- }
- case scm_tcs_struct:
- if (!SCM_STRUCT_APPLICABLE_P (proc))
- break;
- proc = SCM_STRUCT_PROCEDURE (proc);
- if (SCM_IMP (proc))
- break;
- goto procprop;
- case scm_tc7_smob:
- 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! */
- return scm_procedure_property (proc, scm_sym_source);
- case scm_tc7_pws:
+ do
{
- SCM src = scm_procedure_property (proc, scm_sym_source);
+ src = scm_procedure_property (proc, scm_sym_source);
if (scm_is_true (src))
- return src;
- proc = SCM_PROCEDURE (proc);
- goto again;
+ return src;
+
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_struct:
+ if (!SCM_STRUCT_APPLICABLE_P (proc)
+ || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
+ break;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ continue;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ continue;
+ default:
+ break;
+ }
}
- default:
- ;
- }
- SCM_WRONG_TYPE_ARG (1, proc);
- return SCM_BOOL_F; /* not reached */
-}
-#undef FUNC_NAME
+ while (0);
-SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
- (SCM proc),
- "Return the environment of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_environment
-{
- SCM_VALIDATE_NIM (1, proc);
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_closures:
- return SCM_ENV (proc);
- case scm_tcs_subrs:
- return SCM_EOL;
- default:
- SCM_WRONG_TYPE_ARG (1, proc);
- /* not reached */
- }
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -413,37 +201,21 @@ SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
if (scm_is_true (scm_program_p (proc)))
return scm_program_module (proc);
+ else if (SCM_CLOSUREP (proc))
+ {
+ SCM env = SCM_ENV (proc);
+ while (scm_is_pair (env))
+ env = scm_cdr (env);
+ return env;
+ }
else
- return scm_env_module (scm_procedure_environment (proc));
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
-/* Eval in a local environment. We would like to have the ability to
- * evaluate in a specified local environment, but due to the
- * memoization this isn't normally possible. We solve it by copying
- * the code before evaluating. One solution would be to have eval.c
- * generate yet another evaluator. They are not very big actually.
- */
-SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
- (SCM exp, SCM env),
- "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n"
- "it is the environment in which to evaluate @var{exp}. Otherwise,\n"
- "@var{exp} must be a memoized code object (in which case, its environment\n"
- "is implicit).")
-#define FUNC_NAME s_scm_local_eval
-{
- if (SCM_UNBNDP (env))
- {
- SCM_VALIDATE_MEMOIZED (1, exp);
- return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
- }
- return scm_i_eval (exp, env);
-}
-#undef FUNC_NAME
-
#if 0
SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
#endif
@@ -565,31 +337,9 @@ scm_init_debug ()
init_stack_limit ();
scm_init_opts (scm_debug_options, scm_debug_opts);
- scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
- scm_set_smob_print (scm_tc16_memoized, memoized_print);
-
scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
-#ifdef GUILE_DEBUG
- scm_c_define ("SCM_IM_AND", SCM_IM_AND);
- scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
- scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
- scm_c_define ("SCM_IM_COND", SCM_IM_COND);
- scm_c_define ("SCM_IM_DO", SCM_IM_DO);
- scm_c_define ("SCM_IM_IF", SCM_IM_IF);
- scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
- scm_c_define ("SCM_IM_LET", SCM_IM_LET);
- scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
- scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
- scm_c_define ("SCM_IM_OR", SCM_IM_OR);
- scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
- scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
- scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
- scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
- scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
- scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
-#endif
scm_add_feature ("debug-extensions");
#include "libguile/debug.x"
diff --git a/libguile/debug.h b/libguile/debug.h
index 20febdb71..24c6b9e94 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -45,26 +45,6 @@
-SCM_API int scm_debug_mode_p;
-SCM_API int scm_check_entry_p;
-SCM_API int scm_check_apply_p;
-SCM_API int scm_check_exit_p;
-SCM_API int scm_check_memoize_p;
-
-#define SCM_RESET_DEBUG_MODE \
-do {\
- scm_check_entry_p = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\
- && scm_is_true (SCM_ENTER_FRAME_HDLR);\
- scm_check_apply_p = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\
- && scm_is_true (SCM_APPLY_FRAME_HDLR);\
- scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
- && scm_is_true (SCM_EXIT_FRAME_HDLR);\
- scm_check_memoize_p = (SCM_MEMOIZE_P)\
- && scm_is_true (SCM_MEMOIZE_HDLR);\
- scm_debug_mode_p = SCM_DEVAL_P\
- || scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
-} while (0)
-
/* {Evaluator}
*/
@@ -75,8 +55,6 @@ typedef union scm_t_debug_info
SCM id;
} scm_t_debug_info;
-SCM_API long scm_debug_eframe_size;
-
typedef struct scm_t_debug_frame
{
struct scm_t_debug_frame *prev;
@@ -125,28 +103,14 @@ SCM_API scm_t_bits scm_tc16_debugobj;
((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
-/* {Memoized Source}
- */
-
-SCM_API scm_t_bits scm_tc16_memoized;
-
-#define SCM_MEMOIZEDP(x) SCM_TYP16_PREDICATE (scm_tc16_memoized, x)
-#define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CELL_OBJECT_1 (x))
-#define SCM_MEMOIZED_ENV(x) SCM_CDR (SCM_CELL_OBJECT_1 (x))
-
SCM_API SCM scm_debug_object_p (SCM obj);
-SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
-SCM_API SCM scm_procedure_environment (SCM proc);
SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
-SCM_API SCM scm_memoized_environment (SCM m);
-SCM_API SCM scm_make_memoized (SCM exp, SCM env);
-SCM_API SCM scm_memoized_p (SCM obj);
SCM_API SCM scm_with_traps (SCM thunk);
SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);
@@ -156,9 +120,6 @@ SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized);
SCM_INTERNAL void scm_init_debug (void);
#ifdef GUILE_DEBUG
-SCM_API SCM scm_memcons (SCM car, SCM cdr, SCM env);
-SCM_API SCM scm_mem_to_proc (SCM obj);
-SCM_API SCM scm_proc_to_mem (SCM obj);
SCM_API SCM scm_debug_hang (SCM obj);
#endif /*GUILE_DEBUG*/
diff --git a/libguile/eval.c b/libguile/eval.c
index 30da3424b..b47721df7 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -44,6 +44,7 @@
#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/macros.h"
+#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/print.h"
@@ -67,2870 +68,503 @@
-static SCM unmemoize_exprs (SCM expr, SCM env);
-static SCM canonicalize_define (SCM expr);
-static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
-static SCM unmemoize_builtin_macro (SCM expr, SCM env);
-static SCM eval (SCM x, SCM env);
-
-
-
-/* {Syntax Errors}
- *
- * This section defines the message strings for the syntax errors that can be
- * detected during memoization and the functions and macros that shall be
- * called by the memoizer code to signal syntax errors. */
-
-
-/* Syntax errors that can be detected during memoization: */
-
-/* Circular or improper lists do not form valid scheme expressions. If a
- * circular list or an improper list is detected in a place where a scheme
- * expression is expected, a 'Bad expression' error is signalled. */
-static const char s_bad_expression[] = "Bad expression";
-
-/* If a form is detected that holds a different number of expressions than are
- * required in that context, a 'Missing or extra expression' error is
- * signalled. */
-static const char s_expression[] = "Missing or extra expression in";
-
-/* If a form is detected that holds less expressions than are required in that
- * context, a 'Missing expression' error is signalled. */
-static const char s_missing_expression[] = "Missing expression in";
-
-/* If a form is detected that holds more expressions than are allowed in that
- * context, an 'Extra expression' error is signalled. */
-static const char s_extra_expression[] = "Extra expression in";
-
-/* The empty combination '()' is not allowed as an expression in scheme. If
- * it is detected in a place where an expression is expected, an 'Illegal
- * empty combination' error is signalled. Note: If you encounter this error
- * message, it is very likely that you intended to denote the empty list. To
- * do so, you need to quote the empty list like (quote ()) or '(). */
-static const char s_empty_combination[] = "Illegal empty combination";
-
-/* A body may hold an arbitrary number of internal defines, followed by a
- * non-empty sequence of expressions. If a body with an empty sequence of
- * expressions is detected, a 'Missing body expression' error is signalled.
- */
-static const char s_missing_body_expression[] = "Missing body expression in";
-
-/* A body may hold an arbitrary number of internal defines, followed by a
- * non-empty sequence of expressions. Each the definitions and the
- * expressions may be grouped arbitraryly with begin, but it is not allowed to
- * mix definitions and expressions. If a define form in a body mixes
- * definitions and expressions, a 'Mixed definitions and expressions' error is
- * signalled. */
-static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
-/* Definitions are only allowed on the top level and at the start of a body.
- * If a definition is detected anywhere else, a 'Bad define placement' error
- * is signalled. */
-static const char s_bad_define[] = "Bad define placement";
-
-/* Case or cond expressions must have at least one clause. If a case or cond
- * expression without any clauses is detected, a 'Missing clauses' error is
- * signalled. */
-static const char s_missing_clauses[] = "Missing clauses";
-
-/* If there is an 'else' clause in a case or a cond statement, it must be the
- * last clause. If after the 'else' case clause further clauses are detected,
- * a 'Misplaced else clause' error is signalled. */
-static const char s_misplaced_else_clause[] = "Misplaced else clause";
-
-/* If a case clause is detected that is not in the format
- * (<label(s)> <expression1> <expression2> ...)
- * a 'Bad case clause' error is signalled. */
-static const char s_bad_case_clause[] = "Bad case clause";
-
-/* If a case clause is detected where the <label(s)> element is neither a
- * proper list nor (in case of the last clause) the syntactic keyword 'else',
- * a 'Bad case labels' error is signalled. Note: If you encounter this error
- * for an else-clause which seems to be syntactically correct, check if 'else'
- * is really a syntactic keyword in that context. If 'else' is bound in the
- * local or global environment, it is not considered a syntactic keyword, but
- * will be treated as any other variable. */
-static const char s_bad_case_labels[] = "Bad case labels";
-
-/* In a case statement all labels have to be distinct. If in a case statement
- * a label occurs more than once, a 'Duplicate case label' error is
- * signalled. */
-static const char s_duplicate_case_label[] = "Duplicate case label";
-
-/* If a cond clause is detected that is not in one of the formats
- * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
- * a 'Bad cond clause' error is signalled. */
-static const char s_bad_cond_clause[] = "Bad cond clause";
-
-/* If a cond clause is detected that uses the alternate '=>' form, but does
- * not hold a recipient element for the test result, a 'Missing recipient'
- * error is signalled. */
-static const char s_missing_recipient[] = "Missing recipient in";
-
-/* If in a position where a variable name is required some other object is
- * detected, a 'Bad variable' error is signalled. */
-static const char s_bad_variable[] = "Bad variable";
-
-/* Bindings for forms like 'let' and 'do' have to be given in a proper,
- * possibly empty list. If any other object is detected in a place where a
- * list of bindings was required, a 'Bad bindings' error is signalled. */
-static const char s_bad_bindings[] = "Bad bindings";
-
-/* Depending on the syntactic context, a binding has to be in the format
- * (<variable> <expression>) or (<variable> <expression1> <expression2>).
- * If anything else is detected in a place where a binding was expected, a
- * 'Bad binding' error is signalled. */
-static const char s_bad_binding[] = "Bad binding";
-
-/* Some syntactic forms don't allow variable names to appear more than once in
- * a list of bindings. If such a situation is nevertheless detected, a
- * 'Duplicate binding' error is signalled. */
-static const char s_duplicate_binding[] = "Duplicate binding";
-
-/* If the exit form of a 'do' expression is not in the format
- * (<test> <expression> ...)
- * a 'Bad exit clause' error is signalled. */
-static const char s_bad_exit_clause[] = "Bad exit clause";
-
-/* The formal function arguments of a lambda expression have to be either a
- * single symbol or a non-cyclic list. For anything else a 'Bad formals'
- * error is signalled. */
-static const char s_bad_formals[] = "Bad formals";
-
-/* If in a lambda expression something else than a symbol is detected at a
- * place where a formal function argument is required, a 'Bad formal' error is
- * signalled. */
-static const char s_bad_formal[] = "Bad formal";
-
-/* If in the arguments list of a lambda expression an argument name occurs
- * more than once, a 'Duplicate formal' error is signalled. */
-static const char s_duplicate_formal[] = "Duplicate formal";
-
-/* If the evaluation of an unquote-splicing expression gives something else
- * than a proper list, a 'Non-list result for unquote-splicing' error is
- * signalled. */
-static const char s_splicing[] = "Non-list result for unquote-splicing";
-
-/* If something else than an exact integer is detected as the argument for
- * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
-static const char s_bad_slot_number[] = "Bad slot number";
-
-
-/* Signal a syntax error. We distinguish between the form that caused the
- * error and the enclosing expression. The error message will print out as
- * shown in the following pattern. The file name and line number are only
- * given when they can be determined from the erroneous form or from the
- * enclosing expression.
- *
- * <filename>: In procedure memoization:
- * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
-
-SCM_SYMBOL (syntax_error_key, "syntax-error");
-
-/* The prototype is needed to indicate that the function does not return. */
-static void
-syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
-
-static void
-syntax_error (const char* const msg, const SCM form, const SCM expr)
-{
- SCM msg_string = scm_from_locale_string (msg);
- SCM filename = SCM_BOOL_F;
- SCM linenr = SCM_BOOL_F;
- const char *format;
- SCM args;
-
- if (scm_is_pair (form))
- {
- filename = scm_source_property (form, scm_sym_filename);
- linenr = scm_source_property (form, scm_sym_line);
- }
-
- if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
- {
- filename = scm_source_property (expr, scm_sym_filename);
- linenr = scm_source_property (expr, scm_sym_line);
- }
-
- if (!SCM_UNBNDP (expr))
- {
- if (scm_is_true (filename))
- {
- format = "In file ~S, line ~S: ~A ~S in expression ~S.";
- args = scm_list_5 (filename, linenr, msg_string, form, expr);
- }
- else if (scm_is_true (linenr))
- {
- format = "In line ~S: ~A ~S in expression ~S.";
- args = scm_list_4 (linenr, msg_string, form, expr);
- }
- else
- {
- format = "~A ~S in expression ~S.";
- args = scm_list_3 (msg_string, form, expr);
- }
- }
- else
- {
- if (scm_is_true (filename))
- {
- format = "In file ~S, line ~S: ~A ~S.";
- args = scm_list_4 (filename, linenr, msg_string, form);
- }
- else if (scm_is_true (linenr))
- {
- format = "In line ~S: ~A ~S.";
- args = scm_list_3 (linenr, msg_string, form);
- }
- else
- {
- format = "~A ~S.";
- args = scm_list_2 (msg_string, form);
- }
- }
-
- scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
-}
-
-
-/* Shortcut macros to simplify syntax error handling. */
-#define ASSERT_SYNTAX(cond, message, form) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, SCM_UNDEFINED); }
-#define ASSERT_SYNTAX_2(cond, message, form, expr) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, expr); }
-
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_defined_variable (SCM symbol) SCM_NORETURN;
+/* We have three levels of EVAL here:
-
+ - eval (exp, env)
-/* {Ilocs}
- *
- * Ilocs are memoized references to variables in local environment frames.
- * They are represented as three values: The relative offset of the
- * environment frame, the number of the binding within that frame, and a
- * boolean value indicating whether the binding is the last binding in the
- * frame.
- *
- * Frame numbers have 11 bits, relative offsets have 12 bits.
- */
+ evaluates EXP in environment ENV. ENV is a lexical environment
+ structure as used by the actual tree code evaluator. When ENV is
+ a top-level environment, then changes to the current module are
+ tracked by updating ENV so that it continues to be in sync with
+ the current module.
-#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
-#define SCM_IFRINC (0x00000100L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IDINC (0x00100000L)
-#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
- & (SCM_UNPACK (n) >> 8))
-#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
-#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
-#define SCM_IDSTMSK (-SCM_IDINC)
-#define SCM_IFRAMEMAX ((1<<11)-1)
-#define SCM_IDISTMAX ((1<<12)-1)
-#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
- SCM_PACK ( \
- ((frame_nr) << 8) \
- + ((binding_nr) << 20) \
- + ((last_p) ? SCM_ICDR : 0) \
- + scm_tc8_iloc )
-
-void
-scm_i_print_iloc (SCM iloc, SCM port)
-{
- scm_puts ("#@", port);
- scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
- scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
- scm_intprint ((long) SCM_IDIST (iloc), 10, port);
-}
+ - scm_primitive_eval (exp)
-#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
+ evaluates EXP in the top-level environment as determined by the
+ current module. This is done by constructing a suitable
+ environment and calling eval. Thus, changes to the
+ top-level module are tracked normally.
-SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
+ - scm_eval (exp, mod)
-SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
- (SCM frame, SCM binding, SCM cdrp),
- "Return a new iloc with frame offset @var{frame}, binding\n"
- "offset @var{binding} and the cdr flag @var{cdrp}.")
-#define FUNC_NAME s_scm_dbg_make_iloc
-{
- return SCM_MAKE_ILOC ((scm_t_bits) scm_to_unsigned_integer (frame, 0, SCM_IFRAMEMAX),
- (scm_t_bits) scm_to_unsigned_integer (binding, 0, SCM_IDISTMAX),
- scm_is_true (cdrp));
-}
-#undef FUNC_NAME
+ evaluates EXP while MOD is the current module. This is done
+ by setting the current module to MOD_OR_STATE, invoking
+ scm_primitive_eval on EXP, and then restoring the current module
+ to the value it had previously. That is, while EXP is evaluated,
+ changes to the current module (or dynamic state) are tracked,
+ but these changes do not persist when scm_eval returns.
-SCM scm_dbg_iloc_p (SCM obj);
+*/
-SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an iloc.")
-#define FUNC_NAME s_scm_dbg_iloc_p
-{
- return scm_from_bool (SCM_ILOCP (obj));
-}
-#undef FUNC_NAME
+#if 0
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#else
+#define CAR(x) scm_car(x)
+#define CDR(x) scm_cdr(x)
+#define CAAR(x) scm_caar(x)
+#define CADR(x) scm_cadr(x)
+#define CDAR(x) scm_cdar(x)
+#define CDDR(x) scm_cddr(x)
+#define CADDR(x) scm_caddr(x)
+#define CDDDR(x) scm_cdddr(x)
#endif
-
-
-/* {Evaluator byte codes (isyms)}
- */
-
-#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
-
-/* This table must agree with the list of SCM_IM_ constants in tags.h */
-static const char *const isymnames[] =
-{
- "#@and",
- "#@begin",
- "#@case",
- "#@cond",
- "#@do",
- "#@if",
- "#@lambda",
- "#@let",
- "#@let*",
- "#@letrec",
- "#@or",
- "#@quote",
- "#@set!",
- "#@define",
- "#@apply",
- "#@call-with-current-continuation",
- "#@dispatch",
- "#@slot-ref",
- "#@slot-set!",
- "#@delay",
- "#@call-with-values",
- "#@else",
- "#@arrow",
- "#@nil-cond",
- "#@bind"
-};
-
-void
-scm_i_print_isym (SCM isym, SCM port)
-{
- const size_t isymnum = ISYMNUM (isym);
- if (isymnum < (sizeof isymnames / sizeof (char *)))
- scm_puts (isymnames[isymnum], port);
- else
- scm_ipruk ("isym", isym, port);
-}
-
-
-
-/* The function lookup_symbol is used during memoization: Lookup the symbol in
- * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
- * returned. If the symbol is a global variable, the variable object to which
- * the symbol is bound is returned. Finally, if the symbol is a local
- * variable the corresponding iloc object is returned. */
-
-/* A helper function for lookup_symbol: Try to find the symbol in the top
- * level environment frame. The function returns SCM_UNDEFINED if the symbol
- * is unbound and it returns a variable object if the symbol is a global
- * variable. */
-static SCM
-lookup_global_symbol (const SCM symbol, const SCM top_level)
-{
- const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
- if (scm_is_false (variable))
- return SCM_UNDEFINED;
- else
- return variable;
-}
-
-static SCM
-lookup_symbol (const SCM symbol, const SCM env)
-{
- SCM frame_idx;
- unsigned int frame_nr;
-
- for (frame_idx = env, frame_nr = 0;
- !scm_is_null (frame_idx);
- frame_idx = SCM_CDR (frame_idx), ++frame_nr)
- {
- const SCM frame = SCM_CAR (frame_idx);
- if (scm_is_pair (frame))
- {
- /* frame holds a local environment frame */
- SCM symbol_idx;
- unsigned int symbol_nr;
-
- for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
- scm_is_pair (symbol_idx);
- symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
- {
- if (scm_is_eq (SCM_CAR (symbol_idx), symbol))
- /* found the symbol, therefore return the iloc */
- return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
- }
- if (scm_is_eq (symbol_idx, symbol))
- /* found the symbol as the last element of the current frame */
- return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
- }
- else
- {
- /* no more local environment frames */
- return lookup_global_symbol (symbol, frame);
- }
- }
-
- return lookup_global_symbol (symbol, SCM_BOOL_F);
-}
-
-
-/* Return true if the symbol is - from the point of view of a macro
- * transformer - a literal in the sense specified in chapter "pattern
- * language" of R5RS. In the code below, however, we don't match the
- * definition of R5RS exactly: It returns true if the identifier has no
- * binding or if it is a syntactic keyword. */
-static int
-literal_p (const SCM symbol, const SCM env)
-{
- const SCM variable = lookup_symbol (symbol, env);
- if (SCM_UNBNDP (variable))
- return 1;
- if (SCM_VARIABLEP (variable) && SCM_MACROP (SCM_VARIABLE_REF (variable)))
- return 1;
- else
- return 0;
-}
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-/* Return true if the expression is self-quoting in the memoized code. Thus,
- * some other objects (like e. g. vectors) are reported as self-quoting, which
- * according to R5RS would need to be quoted. */
-static int
-is_self_quoting_p (const SCM expr)
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_unbound_variable (SCM symbol)
{
- if (scm_is_pair (expr))
- return 0;
- else if (scm_is_symbol (expr))
- return 0;
- else if (scm_is_null (expr))
- return 0;
- else return 1;
+ scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
}
-
-SCM_SYMBOL (sym_three_question_marks, "???");
-
-static SCM
-unmemoize_expression (const SCM expr, const SCM env)
+static void error_used_before_defined (void)
{
- if (SCM_ILOCP (expr))
- {
- SCM frame_idx;
- unsigned long int frame_nr;
- SCM symbol_idx;
- unsigned long int symbol_nr;
-
- for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
- frame_nr != 0;
- frame_idx = SCM_CDR (frame_idx), --frame_nr)
- ;
- for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
- symbol_nr != 0;
- symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
- ;
- return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
- }
- else if (SCM_VARIABLEP (expr))
- {
- const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
- return scm_is_true (sym) ? sym : sym_three_question_marks;
- }
- else if (scm_is_simple_vector (expr))
- {
- return scm_list_2 (scm_sym_quote, expr);
- }
- else if (!scm_is_pair (expr))
- {
- return expr;
- }
- else if (SCM_ISYMP (SCM_CAR (expr)))
- {
- return unmemoize_builtin_macro (expr, env);
- }
- else
- {
- return unmemoize_exprs (expr, env);
- }
+ scm_error (scm_unbound_variable_key, NULL,
+ "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}
-
-static SCM
-unmemoize_exprs (const SCM exprs, const SCM env)
+int
+scm_badargsp (SCM formals, SCM args)
{
- SCM r_result = SCM_EOL;
- SCM expr_idx = exprs;
- SCM um_expr;
-
- /* Note that due to the current lazy memoizer we may find partially memoized
- * code during execution. In such code we have to expect improper lists of
- * expressions: On the one hand, for such code syntax checks have not yet
- * fully been performed, on the other hand, there may be even legal code
- * like '(a . b) appear as an improper list of expressions as long as the
- * quote expression is still in its unmemoized form. For this reason, the
- * following code handles improper lists of expressions until memoization
- * and execution have been completely separated. */
- for (; scm_is_pair (expr_idx); expr_idx = SCM_CDR (expr_idx))
- {
- const SCM expr = SCM_CAR (expr_idx);
-
- /* In partially memoized code, lists of expressions that stem from a
- * body form may start with an ISYM if the body itself has not yet been
- * memoized. This isym is just an internal marker to indicate that the
- * body still needs to be memoized. An isym may occur at the very
- * beginning of the body or after one or more comment strings. It is
- * dropped during unmemoization. */
- if (!SCM_ISYMP (expr))
- {
- um_expr = unmemoize_expression (expr, env);
- r_result = scm_cons (um_expr, r_result);
- }
- }
- um_expr = unmemoize_expression (expr_idx, env);
- if (!scm_is_null (r_result))
- {
- const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED);
- SCM_SETCDR (r_result, um_expr);
- return result;
- }
- else
+ while (!scm_is_null (formals))
{
- return um_expr;
+ if (!scm_is_pair (formals))
+ return 0;
+ if (scm_is_null (args))
+ return 1;
+ formals = CDR (formals);
+ args = CDR (args);
}
+ return !scm_is_null (args) ? 1 : 0;
}
+static SCM apply (SCM proc, SCM args);
-/* Rewrite the body (which is given as the list of expressions forming the
- * body) into its internal form. The internal form of a body (<expr> ...) is
- * just the body itself, but prefixed with an ISYM that denotes to what kind
- * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
- * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
- * SCM_IM_LET, etc.
- *
- * It is assumed that the calling expression has already made sure that the
- * body is a proper list. */
-static SCM
-m_body (SCM op, SCM exprs)
-{
- /* Don't add another ISYM if one is present already. */
- if (SCM_ISYMP (SCM_CAR (exprs)))
- return exprs;
- else
- return scm_cons (op, exprs);
-}
-
-
-/* The function m_expand_body memoizes a proper list of expressions forming a
- * body. This function takes care of dealing with internal defines and
- * transforming them into an equivalent letrec expression. The list of
- * expressions is rewritten in place. */
-
-/* This is a helper function for m_expand_body. If the argument expression is
- * a symbol that denotes a syntactic keyword, the corresponding macro object
- * is returned, in all other cases the function returns SCM_UNDEFINED. */
-static SCM
-try_macro_lookup (const SCM expr, const SCM env)
-{
- if (scm_is_symbol (expr))
- {
- const SCM variable = lookup_symbol (expr, env);
- if (SCM_VARIABLEP (variable))
- {
- const SCM value = SCM_VARIABLE_REF (variable);
- if (SCM_MACROP (value))
- return value;
- }
- }
-
- return SCM_UNDEFINED;
-}
+/* the environment:
+ ((SYM . VAL) (SYM . VAL) ... . MOD)
+ If MOD is #f, it means the environment was captured before modules were
+ booted.
+ If MOD is the literal value '(), we are evaluating at the top level, and so
+ should track changes to the current module. You have to be careful in this
+ case, because further lexical contours should capture the current module.
+*/
+#define CAPTURE_ENV(env) \
+ ((env == SCM_EOL) ? scm_current_module () : \
+ ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
-/* This is a helper function for m_expand_body. It expands user macros,
- * because for the correct translation of a body we need to know whether they
- * expand to a definition. */
static SCM
-expand_user_macros (SCM expr, const SCM env)
+eval (SCM x, SCM env)
{
- while (scm_is_pair (expr))
- {
- const SCM car_expr = SCM_CAR (expr);
- const SCM new_car = expand_user_macros (car_expr, env);
- const SCM value = try_macro_lookup (new_car, env);
+ SCM mx;
+ SCM proc = SCM_UNDEFINED, args = SCM_EOL;
- if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
- {
- /* User macros transform code into code. */
- expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
- /* We need to reiterate on the transformed code. */
- }
+ loop:
+ SCM_TICK;
+ if (!SCM_MEMOIZED_P (x))
+ abort ();
+
+ mx = SCM_MEMOIZED_ARGS (x);
+ switch (SCM_MEMOIZED_TAG (x))
+ {
+ case SCM_M_BEGIN:
+ for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
+ eval (CAR (mx), env);
+ x = CAR (mx);
+ goto loop;
+
+ case SCM_M_IF:
+ if (scm_is_true (eval (CAR (mx), env)))
+ x = CADR (mx);
else
- {
- /* No user macro: return. */
- SCM_SETCAR (expr, new_car);
- return expr;
- }
- }
+ x = CDDR (mx);
+ goto loop;
- return expr;
-}
-
-/* This is a helper function for m_expand_body. It determines if a given form
- * represents an application of a given built-in macro. The built-in macro to
- * check for is identified by its syntactic keyword. The form is an
- * application of the given macro if looking up the car of the form in the
- * given environment actually returns the built-in macro. */
-static int
-is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
-{
- if (scm_is_pair (form))
- {
- const SCM car_form = SCM_CAR (form);
- const SCM value = try_macro_lookup (car_form, env);
- if (SCM_BUILTIN_MACRO_P (value))
- {
- const SCM macro_name = scm_macro_name (value);
- return scm_is_eq (macro_name, syntactic_keyword);
- }
- }
-
- return 0;
-}
-
-static SCM
-macroexp (SCM x, SCM env)
-{
- SCM res, proc, orig_sym;
-
- /* Don't bother to produce error messages here. We get them when we
- eventually execute the code for real. */
-
- macro_tail:
- orig_sym = SCM_CAR (x);
- if (!scm_is_symbol (orig_sym))
- return x;
-
- {
- SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
- if (proc_ptr == NULL)
+ case SCM_M_LET:
{
- /* We have lost the race. */
- goto macro_tail;
+ SCM inits = CAR (mx);
+ SCM new_env = CAPTURE_ENV (env);
+ for (; scm_is_pair (inits); inits = CDR (inits))
+ new_env = scm_cons (eval (CAR (inits), env), new_env);
+ env = new_env;
+ x = CDR (mx);
+ goto loop;
}
- proc = *proc_ptr;
- }
-
- /* Only handle memoizing macros. `Acros' and `macros' are really
- special forms and should not be evaluated here. */
-
- if (!SCM_MACROP (proc)
- || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
- return x;
+
+ case SCM_M_LAMBDA:
+ return scm_closure (mx, CAPTURE_ENV (env));
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
- res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
+ case SCM_M_QUOTE:
+ return mx;
- if (scm_ilength (res) <= 0)
- /* Result of expansion is not a list. */
- return (scm_list_2 (SCM_IM_BEGIN, res));
- else
- {
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
-
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
-
- goto macro_tail;
- }
-}
-
-
-/* Start of the memoizers for the standard R5RS builtin macros. */
-
-static SCM scm_m_quote (SCM xorig, SCM env);
-static SCM scm_m_begin (SCM xorig, SCM env);
-static SCM scm_m_if (SCM xorig, SCM env);
-static SCM scm_m_set_x (SCM xorig, SCM env);
-static SCM scm_m_and (SCM xorig, SCM env);
-static SCM scm_m_or (SCM xorig, SCM env);
-static SCM scm_m_case (SCM xorig, SCM env);
-static SCM scm_m_cond (SCM xorig, SCM env);
-static SCM scm_m_lambda (SCM xorig, SCM env);
-static SCM scm_m_letstar (SCM xorig, SCM env);
-static SCM scm_m_do (SCM xorig, SCM env);
-static SCM scm_m_quasiquote (SCM xorig, SCM env);
-static SCM scm_m_delay (SCM xorig, SCM env);
-static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
-static SCM scm_m_define (SCM x, SCM env);
-static SCM scm_m_letrec (SCM xorig, SCM env);
-static SCM scm_m_let (SCM xorig, SCM env);
-static SCM scm_m_at (SCM xorig, SCM env);
-static SCM scm_m_atat (SCM xorig, SCM env);
-static SCM scm_m_atslot_ref (SCM xorig, SCM env);
-static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
-static SCM scm_m_apply (SCM xorig, SCM env);
-static SCM scm_m_cont (SCM xorig, SCM env);
-#if SCM_ENABLE_ELISP
-static SCM scm_m_nil_cond (SCM xorig, SCM env);
-static SCM scm_m_atfop (SCM xorig, SCM env);
-#endif /* SCM_ENABLE_ELISP */
-static SCM scm_m_atbind (SCM xorig, SCM env);
-static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
-static SCM scm_m_eval_when (SCM xorig, SCM env);
-
-
-static void
-m_expand_body (const SCM forms, const SCM env)
-{
- /* The first body form can be skipped since it is known to be the ISYM that
- * was prepended to the body by m_body. */
- SCM cdr_forms = SCM_CDR (forms);
- SCM form_idx = cdr_forms;
- SCM definitions = SCM_EOL;
- SCM sequence = SCM_EOL;
-
- /* According to R5RS, the list of body forms consists of two parts: a number
- * (maybe zero) of definitions, followed by a non-empty sequence of
- * expressions. Each the definitions and the expressions may be grouped
- * arbitrarily with begin, but it is not allowed to mix definitions and
- * expressions. The task of the following loop therefore is to split the
- * list of body forms into the list of definitions and the sequence of
- * expressions. */
- while (!scm_is_null (form_idx))
- {
- const SCM form = SCM_CAR (form_idx);
- const SCM new_form = expand_user_macros (form, env);
- if (is_system_macro_p (scm_sym_define, new_form, env))
- {
- definitions = scm_cons (new_form, definitions);
- form_idx = SCM_CDR (form_idx);
- }
- else if (is_system_macro_p (scm_sym_begin, new_form, env))
- {
- /* We have encountered a group of forms. This has to be either a
- * (possibly empty) group of (possibly further grouped) definitions,
- * or a non-empty group of (possibly further grouped)
- * expressions. */
- const SCM grouped_forms = SCM_CDR (new_form);
- unsigned int found_definition = 0;
- unsigned int found_expression = 0;
- SCM grouped_form_idx = grouped_forms;
- while (!found_expression && !scm_is_null (grouped_form_idx))
- {
- const SCM inner_form = SCM_CAR (grouped_form_idx);
- const SCM new_inner_form = expand_user_macros (inner_form, env);
- if (is_system_macro_p (scm_sym_define, new_inner_form, env))
- {
- found_definition = 1;
- definitions = scm_cons (new_inner_form, definitions);
- grouped_form_idx = SCM_CDR (grouped_form_idx);
- }
- else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
- {
- const SCM inner_group = SCM_CDR (new_inner_form);
- grouped_form_idx
- = scm_append (scm_list_2 (inner_group,
- SCM_CDR (grouped_form_idx)));
- }
- else
- {
- /* The group marks the start of the expressions of the body.
- * We have to make sure that within the same group we have
- * not encountered a definition before. */
- ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
- found_expression = 1;
- grouped_form_idx = SCM_EOL;
- }
- }
+ case SCM_M_DEFINE:
+ scm_define (CAR (mx), eval (CDR (mx), env));
+ return SCM_UNSPECIFIED;
- /* We have finished processing the group. If we have not yet
- * encountered an expression we continue processing the forms of the
- * body to collect further definition forms. Otherwise, the group
- * marks the start of the sequence of expressions of the body. */
- if (!found_expression)
+ case SCM_M_APPLY:
+ /* Evaluate the procedure to be applied. */
+ proc = eval (CAR (mx), env);
+ /* Evaluate the argument holding the list of arguments */
+ args = eval (CADR (mx), env);
+
+ apply_proc:
+ /* Go here to tail-apply a procedure. PROC is the procedure and
+ * ARGS is the list of arguments. */
+ if (SCM_CLOSUREP (proc))
+ {
+ int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = SCM_ENV (proc);
+ if (SCM_CLOSURE_HAS_REST_ARGS (proc))
{
- form_idx = SCM_CDR (form_idx);
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ new_env = scm_cons (args, new_env);
}
else
{
- sequence = form_idx;
- form_idx = SCM_EOL;
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (proc);
+ for (; scm_is_pair (args); args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
}
- }
- else
- {
- /* We have detected a form which is no definition. This marks the
- * start of the sequence of expressions of the body. */
- sequence = form_idx;
- form_idx = SCM_EOL;
- }
- }
-
- /* FIXME: forms does not hold information about the file location. */
- ASSERT_SYNTAX (scm_is_pair (sequence), s_missing_body_expression, cdr_forms);
-
- if (!scm_is_null (definitions))
- {
- SCM definition_idx;
- SCM letrec_tail;
- SCM letrec_expression;
- SCM new_letrec_expression;
-
- SCM bindings = SCM_EOL;
- for (definition_idx = definitions;
- !scm_is_null (definition_idx);
- definition_idx = SCM_CDR (definition_idx))
- {
- const SCM definition = SCM_CAR (definition_idx);
- const SCM canonical_definition = canonicalize_define (definition);
- const SCM binding = SCM_CDR (canonical_definition);
- bindings = scm_cons (binding, bindings);
- };
-
- letrec_tail = scm_cons (bindings, sequence);
- /* FIXME: forms does not hold information about the file location. */
- letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
- new_letrec_expression = scm_m_letrec (letrec_expression, env);
- SCM_SETCAR (forms, new_letrec_expression);
- SCM_SETCDR (forms, SCM_EOL);
- }
- else
- {
- SCM_SETCAR (forms, SCM_CAR (sequence));
- SCM_SETCDR (forms, SCM_CDR (sequence));
- }
-}
-
-SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
-SCM_GLOBAL_SYMBOL (scm_sym_and, "and");
-
-static SCM
-scm_m_and (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
-
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
-
- if (length == 0)
- {
- /* Special case: (and) is replaced by #t. */
- return SCM_BOOL_T;
- }
- else
- {
- SCM_SETCAR (expr, SCM_IM_AND);
- return expr;
- }
-}
-
-static SCM
-unmemoize_and (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
-
-static SCM
-scm_m_begin (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
- * That means, there should be a distinction between uses of begin where an
- * empty clause is OK and where it is not. */
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_BEGIN);
- return expr;
-}
-
-static SCM
-unmemoize_begin (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
-SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
-SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
-
-static SCM
-scm_m_case (SCM expr, SCM env)
-{
- SCM clauses;
- SCM all_labels = SCM_EOL;
-
- /* Check, whether 'else is a literal, i. e. not bound to a value. */
- const int else_literal_p = literal_p (scm_sym_else, env);
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
-
- clauses = SCM_CDR (cdr_expr);
- while (!scm_is_null (clauses))
- {
- SCM labels;
-
- const SCM clause = SCM_CAR (clauses);
- ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
- s_bad_case_clause, clause, expr);
-
- labels = SCM_CAR (clause);
- if (scm_is_pair (labels))
- {
- ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
- s_bad_case_labels, labels, expr);
- all_labels = scm_append (scm_list_2 (labels, all_labels));
- }
- else if (scm_is_null (labels))
- {
- /* The list of labels is empty. According to R5RS this is allowed.
- * It means that the sequence of expressions will never be executed.
- * Therefore, as an optimization, we could remove the whole
- * clause. */
+ x = SCM_CLOSURE_BODY (proc);
+ env = new_env;
+ goto loop;
}
else
- {
- ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p,
- s_bad_case_labels, labels, expr);
- ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)),
- s_misplaced_else_clause, clause, expr);
- }
-
- /* build the new clause */
- if (scm_is_eq (labels, scm_sym_else))
- SCM_SETCAR (clause, SCM_IM_ELSE);
-
- clauses = SCM_CDR (clauses);
- }
-
- /* Check whether all case labels are distinct. */
- for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels))
- {
- const SCM label = SCM_CAR (all_labels);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))),
- s_duplicate_case_label, label, expr);
- }
-
- SCM_SETCAR (expr, SCM_IM_CASE);
- return expr;
-}
-
-static SCM
-unmemoize_case (const SCM expr, const SCM env)
-{
- const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
- SCM um_clauses = SCM_EOL;
- SCM clause_idx;
-
- for (clause_idx = SCM_CDDR (expr);
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- const SCM clause = SCM_CAR (clause_idx);
- const SCM labels = SCM_CAR (clause);
- const SCM exprs = SCM_CDR (clause);
-
- const SCM um_exprs = unmemoize_exprs (exprs, env);
- const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE))
- ? scm_sym_else
- : scm_i_finite_list_copy (labels);
- const SCM um_clause = scm_cons (um_labels, um_exprs);
-
- um_clauses = scm_cons (um_clause, um_clauses);
- }
- um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
-
- return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
-}
-
-
-SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
-SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
-
-static SCM
-scm_m_cond (SCM expr, SCM env)
-{
- /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
- const int else_literal_p = literal_p (scm_sym_else, env);
- const int arrow_literal_p = literal_p (scm_sym_arrow, env);
-
- const SCM clauses = SCM_CDR (expr);
- SCM clause_idx;
-
- ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
-
- for (clause_idx = clauses;
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- SCM test;
-
- const SCM clause = SCM_CAR (clause_idx);
- const long length = scm_ilength (clause);
- ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
-
- test = SCM_CAR (clause);
- if (scm_is_eq (test, scm_sym_else) && else_literal_p)
- {
- const int last_clause_p = scm_is_null (SCM_CDR (clause_idx));
- ASSERT_SYNTAX_2 (length >= 2,
- s_bad_cond_clause, clause, expr);
- ASSERT_SYNTAX_2 (last_clause_p,
- s_misplaced_else_clause, clause, expr);
- SCM_SETCAR (clause, SCM_IM_ELSE);
- }
- else if (length >= 2
- && scm_is_eq (SCM_CADR (clause), scm_sym_arrow)
- && arrow_literal_p)
- {
- ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
- ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
- }
- /* SRFI 61 extended cond */
- else if (length >= 3
- && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow)
- && arrow_literal_p)
- {
- ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
- ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
- }
- }
-
- SCM_SETCAR (expr, SCM_IM_COND);
- return expr;
-}
-
-static SCM
-unmemoize_cond (const SCM expr, const SCM env)
-{
- SCM um_clauses = SCM_EOL;
- SCM clause_idx;
+ return apply (proc, args);
- for (clause_idx = SCM_CDR (expr);
- !scm_is_null (clause_idx);
- clause_idx = SCM_CDR (clause_idx))
- {
- const SCM clause = SCM_CAR (clause_idx);
- const SCM sequence = SCM_CDR (clause);
- const SCM test = SCM_CAR (clause);
- SCM um_test;
- SCM um_sequence;
- SCM um_clause;
-
- if (scm_is_eq (test, SCM_IM_ELSE))
- um_test = scm_sym_else;
- else
- um_test = unmemoize_expression (test, env);
+ case SCM_M_CALL:
+ /* Evaluate the procedure to be applied. */
+ proc = eval (CAR (mx), env);
+
+ mx = CDR (mx);
- if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence),
- SCM_IM_ARROW))
+ if (SCM_CLOSUREP (proc))
{
- const SCM target = SCM_CADR (sequence);
- const SCM um_target = unmemoize_expression (target, env);
- um_sequence = scm_list_2 (scm_sym_arrow, um_target);
+ int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = SCM_ENV (proc);
+ if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ {
+ if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, mx = CDR (mx))
+ new_env = scm_cons (eval (CAR (mx), env), new_env);
+ {
+ SCM rest = SCM_EOL;
+ for (; scm_is_pair (mx); mx = CDR (mx))
+ rest = scm_cons (eval (CAR (mx), env), rest);
+ new_env = scm_cons (scm_reverse (rest),
+ new_env);
+ }
+ }
+ else
+ {
+ for (; scm_is_pair (mx); mx = CDR (mx), nreq--)
+ new_env = scm_cons (eval (CAR (mx), env), new_env);
+ if (SCM_UNLIKELY (nreq != 0))
+ scm_wrong_num_args (proc);
+ }
+ x = SCM_CLOSURE_BODY (proc);
+ env = new_env;
+ goto loop;
}
else
{
- um_sequence = unmemoize_exprs (sequence, env);
+ SCM rest = SCM_EOL;
+ for (; scm_is_pair (mx); mx = CDR (mx))
+ rest = scm_cons (eval (CAR (mx), env), rest);
+ return apply (proc, scm_reverse (rest));
}
+
+ case SCM_M_CONT:
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
- um_clause = scm_cons (um_test, um_sequence);
- um_clauses = scm_cons (um_clause, um_clauses);
- }
- um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
-
- return scm_cons (scm_sym_cond, um_clauses);
-}
-
-
-SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
-SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
-
-/* Guile provides an extension to R5RS' define syntax to represent function
- * currying in a compact way. With this extension, it is allowed to write
- * (define <nested-variable> <body>), where <nested-variable> has of one of
- * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
- * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
- * should be either a sequence of zero or more variables, or a sequence of one
- * or more variables followed by a space-delimited period and another
- * variable. Each level of argument nesting wraps the <body> within another
- * lambda expression. For example, the following forms are allowed, each one
- * followed by an equivalent, more explicit implementation.
- * Example 1:
- * (define ((a b . c) . d) <body>) is equivalent to
- * (define a (lambda (b . c) (lambda d <body>)))
- * Example 2:
- * (define (((a) b) c . d) <body>) is equivalent to
- * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
- */
-/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
- * module that does not implement this extension. */
-static SCM
-canonicalize_define (const SCM expr)
-{
- SCM body;
- SCM variable;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- body = SCM_CDR (cdr_expr);
- variable = SCM_CAR (cdr_expr);
- while (scm_is_pair (variable))
- {
- /* This while loop realizes function currying by variable nesting.
- * Variable is known to be a nested-variable. In every iteration of the
- * loop another level of lambda expression is created, starting with the
- * innermost one. Note that we don't check for duplicate formals here:
- * This will be done by the memoizer of the lambda expression. */
- const SCM formals = SCM_CDR (variable);
- const SCM tail = scm_cons (formals, body);
-
- /* Add source properties to each new lambda expression: */
- const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
-
- body = scm_list_1 (lambda);
- variable = SCM_CAR (variable);
- }
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
-
- SCM_SETCAR (cdr_expr, variable);
- SCM_SETCDR (cdr_expr, body);
- return expr;
-}
-
-/* According to Section 5.2.1 of R5RS we first have to make sure that the
- variable is bound, and then perform the `(set! variable expression)'
- operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
- bound. This means that EXPRESSION won't necessarily be able to assign
- values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-static SCM
-scm_m_define (SCM expr, SCM env)
-{
- ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
+ if (!first)
+ return val;
+ else
+ {
+ proc = eval (mx, env);
+ args = scm_list_1 (val);
+ goto apply_proc;
+ }
+ }
- {
- const SCM canonical_definition = canonicalize_define (expr);
- const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
- const SCM variable = SCM_CAR (cdr_canonical_definition);
- const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
- const SCM location
- = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
-
- if (SCM_REC_PROCNAMES_P)
+ case SCM_M_CALL_WITH_VALUES:
{
- SCM tmp = value;
- while (SCM_MACROP (tmp))
- tmp = SCM_MACRO_CODE (tmp);
- if (scm_is_true (scm_procedure_p (tmp))
- /* Only the first definition determines the name. */
- && scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
- scm_set_procedure_property_x (tmp, scm_sym_name, variable);
+ SCM producer;
+ SCM v;
+
+ producer = eval (CAR (mx), env);
+ proc = eval (CDR (mx), env); /* proc is the consumer. */
+ v = apply (producer, SCM_EOL);
+ if (SCM_VALUESP (v))
+ args = scm_struct_ref (v, SCM_INUM0);
+ else
+ args = scm_list_1 (v);
+ goto apply_proc;
}
- SCM_VARIABLE_SET (location, value);
-
- return SCM_UNSPECIFIED;
- }
-}
-
-
-/* This is a helper function for forms (<keyword> <expression>) that are
- * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
- * for easy creation of a thunk (i. e. a closure without arguments) using the
- * ('() <memoized_expression>) tail of the memoized form. */
-static SCM
-memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
-
- return expr;
-}
-
-
-SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
-SCM_GLOBAL_SYMBOL (scm_sym_delay, "delay");
-
-/* Promises are implemented as closures with an empty parameter list. Thus,
- * (delay <expression>) is transformed into (#@delay '() <expression>), where
- * the empty list represents the empty parameter list. This representation
- * allows for easy creation of the closure during evaluation. */
-static SCM
-scm_m_delay (SCM expr, SCM env)
-{
- const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_DELAY);
- return new_expr;
-}
-
-static SCM
-unmemoize_delay (const SCM expr, const SCM env)
-{
- const SCM thunk_expr = SCM_CADDR (expr);
- /* A promise is implemented as a closure, and when applying a
- closure the evaluator adds a new frame to the environment - even
- though, in the case of a promise, the added frame is always
- empty. We need to extend the environment here in the same way,
- so that any ILOCs in thunk_expr can be unmemoized correctly. */
- const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, new_env));
-}
-
-
-SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
-SCM_GLOBAL_SYMBOL(scm_sym_do, "do");
-
-/* DO gets the most radically altered syntax. The order of the vars is
- * reversed here. During the evaluation this allows for simple consing of the
- * results of the inits and steps:
-
- (do ((<var1> <init1> <step1>)
- (<var2> <init2>)
- ... )
- (<test> <return>)
- <body>)
-
- ;; becomes
-
- (#@do (<init1> <init2> ... <initn>)
- (varn ... var2 var1)
- (<test> <return>)
- (<body>)
- <step1> <step2> ... <stepn>) ;; missing steps replaced by var
- */
-static SCM
-scm_m_do (SCM expr, SCM env SCM_UNUSED)
-{
- SCM variables = SCM_EOL;
- SCM init_forms = SCM_EOL;
- SCM step_forms = SCM_EOL;
- SCM binding_idx;
- SCM cddr_expr;
- SCM exit_clause;
- SCM commands;
- SCM tail;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- /* Collect variables, init and step forms. */
- binding_idx = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
- s_bad_bindings, binding_idx, expr);
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- const SCM binding = SCM_CAR (binding_idx);
- const long length = scm_ilength (binding);
- ASSERT_SYNTAX_2 (length == 2 || length == 3,
- s_bad_binding, binding, expr);
-
+ case SCM_M_LEXICAL_REF:
{
- const SCM name = SCM_CAR (binding);
- const SCM init = SCM_CADR (binding);
- const SCM step = (length == 2) ? name : SCM_CADDR (binding);
- ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)),
- s_duplicate_binding, name, expr);
-
- variables = scm_cons (name, variables);
- init_forms = scm_cons (init, init_forms);
- step_forms = scm_cons (step, step_forms);
+ int n;
+ SCM ret;
+ for (n = SCM_I_INUM (mx); n; n--)
+ env = CDR (env);
+ ret = CAR (env);
+ if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
+ /* we don't know what variable, though, because we don't have its
+ name */
+ error_used_before_defined ();
+ return ret;
}
- }
- init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
- step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
-
- /* Memoize the test form and the exit sequence. */
- cddr_expr = SCM_CDR (cdr_expr);
- exit_clause = SCM_CAR (cddr_expr);
- ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
- s_bad_exit_clause, exit_clause, expr);
-
- commands = SCM_CDR (cddr_expr);
- tail = scm_cons2 (exit_clause, commands, step_forms);
- tail = scm_cons2 (init_forms, variables, tail);
- SCM_SETCAR (expr, SCM_IM_DO);
- SCM_SETCDR (expr, tail);
- return expr;
-}
-
-static SCM
-unmemoize_do (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM rnames = SCM_CAR (cddr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
- const SCM exit_sequence = SCM_CAR (cdddr_expr);
- const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
- const SCM cddddr_expr = SCM_CDR (cdddr_expr);
- const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
-
- /* build transformed binding list */
- SCM um_names = scm_reverse (rnames);
- SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
- SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
- SCM um_bindings = SCM_EOL;
- while (!scm_is_null (um_names))
- {
- const SCM name = SCM_CAR (um_names);
- const SCM init = SCM_CAR (um_inits);
- SCM step = SCM_CAR (um_steps);
- step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step);
-
- um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
-
- um_names = SCM_CDR (um_names);
- um_inits = SCM_CDR (um_inits);
- um_steps = SCM_CDR (um_steps);
- }
- um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
-
- return scm_cons (scm_sym_do,
- scm_cons2 (um_bindings, um_exit_sequence, um_body));
-}
-
-
-SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
-SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
-
-static SCM
-scm_m_if (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_IF);
- return expr;
-}
-
-static SCM
-unmemoize_if (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
-
- if (scm_is_null (cdddr_expr))
- {
- return scm_list_3 (scm_sym_if, um_condition, um_then);
- }
- else
- {
- const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
- return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
- }
-}
-
-
-SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
-
-/* A helper function for memoize_lambda to support checking for duplicate
- * formal arguments: Return true if OBJ is `eq?' to one of the elements of
- * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
- * forms that a formal argument can have:
- * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
-static int
-c_improper_memq (SCM obj, SCM list)
-{
- for (; scm_is_pair (list); list = SCM_CDR (list))
- {
- if (scm_is_eq (SCM_CAR (list), obj))
- return 1;
- }
- return scm_is_eq (list, obj);
-}
-
-static SCM
-scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
-{
- SCM formals;
- SCM formals_idx;
- SCM cddr_expr;
- int documentation;
- SCM body;
- SCM new_body;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- /* Before iterating the list of formal arguments, make sure the formals
- * actually are given as either a symbol or a non-cyclic list. */
- formals = SCM_CAR (cdr_expr);
- if (scm_is_pair (formals))
- {
- /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
- * detected, report a 'Bad formals' error. */
- }
- else
- {
- ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
- s_bad_formals, formals, expr);
- }
-
- /* Now iterate the list of formal arguments to check if all formals are
- * symbols, and that there are no duplicates. */
- formals_idx = formals;
- while (scm_is_pair (formals_idx))
- {
- const SCM formal = SCM_CAR (formals_idx);
- const SCM next_idx = SCM_CDR (formals_idx);
- ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
- ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
- s_duplicate_formal, formal, expr);
- formals_idx = next_idx;
- }
- ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
- s_bad_formal, formals_idx, expr);
-
- /* Memoize the body. Keep a potential documentation string. */
- /* Dirk:FIXME:: We should probably extract the documentation string to
- * some external database. Otherwise it will slow down execution, since
- * the documentation string will have to be skipped with every execution
- * of the closure. */
- cddr_expr = SCM_CDR (cdr_expr);
- documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr)));
- body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
- new_body = m_body (SCM_IM_LAMBDA, body);
-
- SCM_SETCAR (expr, SCM_IM_LAMBDA);
- if (documentation)
- SCM_SETCDR (cddr_expr, new_body);
- else
- SCM_SETCDR (cdr_expr, new_body);
- return expr;
-}
-
-static SCM
-unmemoize_lambda (const SCM expr, const SCM env)
-{
- const SCM formals = SCM_CADR (expr);
- const SCM body = SCM_CDDR (expr);
-
- const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
- const SCM um_formals = scm_i_finite_list_copy (formals);
- const SCM um_body = unmemoize_exprs (body, new_env);
-
- return scm_cons2 (scm_sym_lambda, um_formals, um_body);
-}
-
-
-/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
-static void
-check_bindings (const SCM bindings, const SCM expr)
-{
- SCM binding_idx;
-
- ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
- s_bad_bindings, bindings, expr);
-
- binding_idx = bindings;
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- SCM name; /* const */
-
- const SCM binding = SCM_CAR (binding_idx);
- ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
- s_bad_binding, binding, expr);
-
- name = SCM_CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
- }
-}
-
-
-/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
- * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
- * variables are returned in a list with their order reversed, and the init
- * forms are returned in a list in the same order as they are given in the
- * bindings. If a duplicate variable name is detected, an error is
- * signalled. */
-static void
-transform_bindings (
- const SCM bindings, const SCM expr,
- SCM *const rvarptr, SCM *const initptr )
-{
- SCM rvariables = SCM_EOL;
- SCM rinits = SCM_EOL;
- SCM binding_idx = bindings;
- for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
- {
- const SCM binding = SCM_CAR (binding_idx);
- const SCM cdr_binding = SCM_CDR (binding);
- const SCM name = SCM_CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
- s_duplicate_binding, name, expr);
- rvariables = scm_cons (name, rvariables);
- rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
- }
- *rvarptr = rvariables;
- *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
-}
-
-
-SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
-SCM_GLOBAL_SYMBOL(scm_sym_let, "let");
-
-/* This function is a helper function for memoize_let. It transforms
- * (let name ((var init) ...) body ...) into
- * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
- * and memoizes the expression. It is assumed that the caller has checked
- * that name is a symbol and that there are bindings and a body. */
-static SCM
-memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
-{
- SCM rvariables;
- SCM variables;
- SCM inits;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM name = SCM_CAR (cdr_expr);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM bindings = SCM_CAR (cddr_expr);
- check_bindings (bindings, expr);
-
- transform_bindings (bindings, expr, &rvariables, &inits);
- variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
-
- {
- const SCM let_body = SCM_CDR (cddr_expr);
- const SCM lambda_body = m_body (SCM_IM_LET, let_body);
- const SCM lambda_tail = scm_cons (variables, lambda_body);
- const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
-
- const SCM rvar = scm_list_1 (name);
- const SCM init = scm_list_1 (lambda_form);
- const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
- const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
- const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
- return scm_cons_source (expr, letrec_form, inits);
- }
-}
-
-/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
- * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-static SCM
-scm_m_let (SCM expr, SCM env)
-{
- SCM bindings;
-
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- bindings = SCM_CAR (cdr_expr);
- if (scm_is_symbol (bindings))
- {
- ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
- return memoize_named_let (expr, env);
- }
-
- check_bindings (bindings, expr);
- if (scm_is_null (bindings) || scm_is_null (SCM_CDR (bindings)))
- {
- /* Special case: no bindings or single binding => let* is faster. */
- const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
- return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
- }
- else
- {
- /* plain let */
- SCM rvariables;
- SCM inits;
- transform_bindings (bindings, expr, &rvariables, &inits);
+ case SCM_M_LEXICAL_SET:
{
- const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
- const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
- SCM_SETCAR (expr, SCM_IM_LET);
- SCM_SETCDR (expr, new_tail);
- return expr;
+ int n;
+ SCM val = eval (CDR (mx), env);
+ for (n = SCM_I_INUM (CAR (mx)); n; n--)
+ env = CDR (env);
+ SCM_SETCAR (env, val);
+ return SCM_UNSPECIFIED;
}
- }
-}
-
-static SCM
-build_binding_list (SCM rnames, SCM rinits)
-{
- SCM bindings = SCM_EOL;
- while (!scm_is_null (rnames))
- {
- const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
- bindings = scm_cons (binding, bindings);
- rnames = SCM_CDR (rnames);
- rinits = SCM_CDR (rinits);
- }
- return bindings;
-}
-
-static SCM
-unmemoize_let (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_rnames = SCM_CAR (cdr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
- const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
- const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
- const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
-
- return scm_cons2 (scm_sym_let, um_bindings, um_body);
-}
-
-
-SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, "letrec");
-
-static SCM
-scm_m_letrec (SCM expr, SCM env)
-{
- SCM bindings;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- bindings = SCM_CAR (cdr_expr);
- if (scm_is_null (bindings))
- {
- /* no bindings, let* is executed faster */
- SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
- }
- else
- {
- SCM rvariables;
- SCM inits;
- SCM new_body;
-
- check_bindings (bindings, expr);
- transform_bindings (bindings, expr, &rvariables, &inits);
- new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
- }
-}
-
-static SCM
-unmemoize_letrec (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM um_rnames = SCM_CAR (cdr_expr);
- const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
- const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
- const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
- const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
-
- return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
-}
-
-
-
-SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
-
-/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
- * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
-static SCM
-scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
-{
- SCM binding_idx;
- SCM new_body;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
-
- binding_idx = SCM_CAR (cdr_expr);
- check_bindings (binding_idx, expr);
-
- /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
- * transformation is done in place. At the beginning of one iteration of
- * the loop the variable binding_idx holds the form
- * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
- * where P1, P2 and P3 indicate the pairs, that are relevant for the
- * transformation. P1 and P2 are modified in the loop, P3 remains
- * untouched. After the execution of the loop, P1 will hold
- * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
- * and binding_idx will hold P3. */
- while (!scm_is_null (binding_idx))
- {
- const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
- const SCM binding = SCM_CAR (binding_idx);
- const SCM name = SCM_CAR (binding);
- const SCM cdr_binding = SCM_CDR (binding);
-
- SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
- SCM_SETCAR (binding_idx, name); /* update P1 */
- SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
-
- binding_idx = cdr_binding_idx; /* continue with P3 */
- }
-
- new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
- SCM_SETCAR (expr, SCM_IM_LETSTAR);
- /* the bindings have been changed in place */
- SCM_SETCDR (cdr_expr, new_body);
- return expr;
-}
-
-static SCM
-unmemoize_letstar (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM body = SCM_CDR (cdr_expr);
- SCM bindings = SCM_CAR (cdr_expr);
- SCM um_bindings = SCM_EOL;
- SCM extended_env = env;
- SCM um_body;
-
- while (!scm_is_null (bindings))
- {
- const SCM variable = SCM_CAR (bindings);
- const SCM init = SCM_CADR (bindings);
- const SCM um_init = unmemoize_expression (init, extended_env);
- um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
- extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
- bindings = SCM_CDDR (bindings);
- }
- um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
-
- um_body = unmemoize_exprs (body, extended_env);
-
- return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
-}
-
-
-SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
-SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
-static SCM
-scm_m_or (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const long length = scm_ilength (cdr_expr);
-
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
-
- if (length == 0)
- {
- /* Special case: (or) is replaced by #f. */
- return SCM_BOOL_F;
- }
- else
- {
- SCM_SETCAR (expr, SCM_IM_OR);
- return expr;
- }
-}
-
-static SCM
-unmemoize_or (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
-SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
-SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
-
-/* Internal function to handle a quasiquotation: 'form' is the parameter in
- * the call (quasiquotation form), 'env' is the environment where unquoted
- * expressions will be evaluated, and 'depth' is the current quasiquotation
- * nesting level and is known to be greater than zero. */
-static SCM
-iqq (SCM form, SCM env, unsigned long int depth)
-{
- if (scm_is_pair (form))
- {
- const SCM tmp = SCM_CAR (form);
- if (scm_is_eq (tmp, scm_sym_quasiquote))
- {
- const SCM args = SCM_CDR (form);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
- }
- else if (scm_is_eq (tmp, scm_sym_unquote))
- {
- const SCM args = SCM_CDR (form);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- if (depth - 1 == 0)
- return scm_eval_car (args, env);
- else
- return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
- }
- else if (scm_is_pair (tmp)
- && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing))
- {
- const SCM args = SCM_CDR (tmp);
- ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
- if (depth - 1 == 0)
- {
- const SCM list = scm_eval_car (args, env);
- const SCM rest = SCM_CDR (form);
- ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
- s_splicing, list, form);
- return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
- }
- else
- return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
- iqq (SCM_CDR (form), env, depth));
- }
+ case SCM_M_TOPLEVEL_REF:
+ if (SCM_VARIABLEP (mx))
+ return SCM_VARIABLE_REF (mx);
else
- return scm_cons (iqq (SCM_CAR (form), env, depth),
- iqq (SCM_CDR (form), env, depth));
- }
- else if (scm_is_vector (form))
- return scm_vector (iqq (scm_vector_to_list (form), env, depth));
- else
- return form;
-}
-
-static SCM
-scm_m_quasiquote (SCM expr, SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
- return iqq (SCM_CAR (cdr_expr), env, 1);
-}
-
-
-SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
-
-static SCM
-scm_m_quote (SCM expr, SCM env SCM_UNUSED)
-{
- SCM quotee;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
- quotee = SCM_CAR (cdr_expr);
- if (is_self_quoting_p (quotee))
- return quotee;
-
- SCM_SETCAR (expr, SCM_IM_QUOTE);
- SCM_SETCDR (expr, quotee);
- return expr;
-}
-
-static SCM
-unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
-{
- return scm_list_2 (scm_sym_quote, SCM_CDR (expr));
-}
-
-
-/* Will go into the RnRS module when Guile is factorized.
-SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
-SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
-
-static SCM
-scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
-{
- SCM variable;
- SCM new_variable;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- variable = SCM_CAR (cdr_expr);
-
- /* Memoize the variable form. */
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- new_variable = lookup_symbol (variable, env);
- /* Leave the memoization of unbound symbols to lazy memoization: */
- if (SCM_UNBNDP (new_variable))
- new_variable = variable;
-
- SCM_SETCAR (expr, SCM_IM_SET_X);
- SCM_SETCAR (cdr_expr, new_variable);
- return expr;
-}
-
-static SCM
-unmemoize_set_x (const SCM expr, const SCM env)
-{
- return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-
-/* Start of the memoizers for non-R5RS builtin macros. */
-
-
-SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
-SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
-
-static SCM
-scm_m_at (SCM expr, SCM env SCM_UNUSED)
-{
- SCM mod, var;
- ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
-
- mod = scm_resolve_module (scm_cadr (expr));
- if (scm_is_false (mod))
- error_unbound_variable (expr);
- var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr));
- if (scm_is_false (var))
- error_unbound_variable (expr);
-
- return var;
-}
-
-SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
-SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
-
-static SCM
-scm_m_atat (SCM expr, SCM env SCM_UNUSED)
-{
- SCM mod, var;
- ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
-
- mod = scm_resolve_module (scm_cadr (expr));
- if (scm_is_false (mod))
- error_unbound_variable (expr);
- var = scm_module_variable (mod, scm_caddr (expr));
- if (scm_is_false (var))
- error_unbound_variable (expr);
-
- return var;
-}
-
-SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
-SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
-
-static SCM
-scm_m_apply (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_APPLY);
- return expr;
-}
-
-static SCM
-unmemoize_apply (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
-
-/* FIXME: The following explanation should go into the documentation: */
-/* (@bind ((var init) ...) body ...) will assign the values of the `init's to
- * the global variables named by `var's (symbols, not evaluated), creating
- * them if they don't exist, executes body, and then restores the previous
- * values of the `var's. Additionally, whenever control leaves body, the
- * values of the `var's are saved and restored when control returns. It is an
- * error when a symbol appears more than once among the `var's. All `init's
- * are evaluated before any `var' is set.
- *
- * Think of this as `let' for dynamic scope.
- */
-
-/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
- * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
- *
- * FIXME - also implement `@bind*'.
- */
-static SCM
-scm_m_atbind (SCM expr, SCM env)
-{
- SCM bindings;
- SCM rvariables;
- SCM inits;
- SCM variable_idx;
-
- const SCM top_level = scm_env_top_level (env);
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
- bindings = SCM_CAR (cdr_expr);
- check_bindings (bindings, expr);
- transform_bindings (bindings, expr, &rvariables, &inits);
-
- for (variable_idx = rvariables;
- !scm_is_null (variable_idx);
- variable_idx = SCM_CDR (variable_idx))
- {
- /* The first call to scm_sym2var will look beyond the current module,
- * while the second call wont. */
- const SCM variable = SCM_CAR (variable_idx);
- SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
- if (scm_is_false (new_variable))
- new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
- SCM_SETCAR (variable_idx, new_variable);
- }
-
- SCM_SETCAR (expr, SCM_IM_BIND);
- SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
- return expr;
-}
-
-
-SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
-SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, "@call-with-current-continuation");
-
-static SCM
-scm_m_cont (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_CONT);
- return expr;
-}
-
-static SCM
-unmemoize_atcall_cc (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-
-SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
-SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, "@call-with-values");
-
-static SCM
-scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
- return expr;
-}
-
-static SCM
-unmemoize_at_call_with_values (const SCM expr, const SCM env)
-{
- return scm_list_2 (scm_sym_at_call_with_values,
- unmemoize_exprs (SCM_CDR (expr), env));
-}
-
-SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
-SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
-SCM_SYMBOL (sym_eval, "eval");
-SCM_SYMBOL (sym_load, "load");
-
-
-static SCM
-scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
-{
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
-
- if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
- || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
- return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
-
- return scm_list_1 (SCM_IM_BEGIN);
-}
-
-SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
-SCM_SYMBOL (scm_sym_setter, "setter");
-
-static SCM
-scm_m_generalized_set_x (SCM expr, SCM env)
-{
- SCM target, exp_target;
+ {
+ SCM var;
+ while (scm_is_pair (env))
+ env = scm_cdr (env);
+ var = scm_module_variable (CAPTURE_ENV (env), mx);
+ if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (mx);
+ SCM_SET_SMOB_OBJECT (x, var);
+ return SCM_VARIABLE_REF (var);
+ }
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ case SCM_M_TOPLEVEL_SET:
+ {
+ SCM var = CAR (mx);
+ SCM val = eval (CDR (mx), env);
+ if (SCM_VARIABLEP (var))
+ {
+ SCM_VARIABLE_SET (var, val);
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ while (scm_is_pair (env))
+ env = scm_cdr (env);
+ var = scm_module_variable (CAPTURE_ENV (env), var);
+ if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (CAR (mx));
+ SCM_SETCAR (mx, var);
+ SCM_VARIABLE_SET (var, val);
+ return SCM_UNSPECIFIED;
+ }
+ }
- target = SCM_CAR (cdr_expr);
- if (!scm_is_pair (target))
- {
- /* R5RS usage */
- return scm_m_set_x (expr, env);
- }
- else
- {
- /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
- /* Macroexpanding the target might return things of the form
- (begin <atom>). In that case, <atom> must be a symbol or a
- variable and we memoize to (set! <atom> ...).
- */
- exp_target = macroexp (target, env);
- if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN)
- && !scm_is_null (SCM_CDR (exp_target))
- && scm_is_null (SCM_CDDR (exp_target)))
- {
- exp_target= SCM_CADR (exp_target);
- ASSERT_SYNTAX_2 (scm_is_symbol (exp_target)
- || SCM_VARIABLEP (exp_target),
- s_bad_variable, exp_target, expr);
- return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
- SCM_CDR (cdr_expr)));
- }
+ case SCM_M_MODULE_REF:
+ if (SCM_VARIABLEP (mx))
+ return SCM_VARIABLE_REF (mx);
else
- {
- const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
- const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
- setter_proc_tail);
-
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
- cddr_expr));
-
- SCM_SETCAR (expr, setter_proc);
- SCM_SETCDR (expr, setter_args);
- return expr;
- }
- }
-}
-
-
-/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
- * soon as the module system allows us to more freely create bindings in
- * arbitrary modules during the startup phase, the code from goops.c should be
- * moved here. */
-
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
-SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
-
-static SCM
-scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
-{
- SCM slot_nr;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- slot_nr = SCM_CADR (cdr_expr);
- ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
-
- SCM_SETCAR (expr, SCM_IM_SLOT_REF);
- SCM_SETCDR (cdr_expr, slot_nr);
- return expr;
-}
-
-static SCM
-unmemoize_atslot_ref (const SCM expr, const SCM env)
-{
- const SCM instance = SCM_CADR (expr);
- const SCM um_instance = unmemoize_expression (instance, env);
- const SCM slot_nr = SCM_CDDR (expr);
- return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
-}
-
-
-/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
- * soon as the module system allows us to more freely create bindings in
- * arbitrary modules during the startup phase, the code from goops.c should be
- * moved here. */
-
-SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
-
-static SCM
-scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
-{
- SCM slot_nr;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
- slot_nr = SCM_CADR (cdr_expr);
- ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
-
- SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
- return expr;
-}
-
-static SCM
-unmemoize_atslot_set_x (const SCM expr, const SCM env)
-{
- const SCM cdr_expr = SCM_CDR (expr);
- const SCM instance = SCM_CAR (cdr_expr);
- const SCM um_instance = unmemoize_expression (instance, env);
- const SCM cddr_expr = SCM_CDR (cdr_expr);
- const SCM slot_nr = SCM_CAR (cddr_expr);
- const SCM cdddr_expr = SCM_CDR (cddr_expr);
- const SCM value = SCM_CAR (cdddr_expr);
- const SCM um_value = unmemoize_expression (value, env);
- return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
-}
-
-
-#if SCM_ENABLE_ELISP
-
-static const char s_defun[] = "Symbol's function definition is void";
-
-SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
-
-/* nil-cond expressions have the form
- * (nil-cond COND VAL COND VAL ... ELSEVAL) */
-static SCM
-scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
-{
- const long length = scm_ilength (SCM_CDR (expr));
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
-
- SCM_SETCAR (expr, SCM_IM_NIL_COND);
- return expr;
-}
-
-
-SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
-
-/* The @fop-macro handles procedure and macro applications for elisp. The
- * input expression must have the form
- * (@fop <var> (transformer-macro <expr> ...))
- * where <var> must be a symbol. The expression is transformed into the
- * memoized form of either
- * (apply <un-aliased var> (transformer-macro <expr> ...))
- * if the value of var (across all aliasing) is not a macro, or
- * (<un-aliased var> <expr> ...)
- * if var is a macro. */
-static SCM
-scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
-{
- SCM location;
- SCM symbol;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
-
- symbol = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr);
-
- location = scm_symbol_fref (symbol);
- ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
-
- /* The elisp function `defalias' allows to define aliases for symbols. To
- * look up such definitions, the chain of symbol definitions has to be
- * followed up to the terminal symbol. */
- while (scm_is_symbol (SCM_VARIABLE_REF (location)))
- {
- const SCM alias = SCM_VARIABLE_REF (location);
- location = scm_symbol_fref (alias);
- ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
- }
-
- /* Memoize the value location belonging to the terminal symbol. */
- SCM_SETCAR (cdr_expr, location);
-
- if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
- {
- /* Since the location does not contain a macro, the form is a procedure
- * application. Replace `@fop' by `@apply' and transform the expression
- * including the `transformer-macro'. */
- SCM_SETCAR (expr, SCM_IM_APPLY);
- return expr;
- }
- else
- {
- /* Since the location contains a macro, the arguments should not be
- * transformed, so the `transformer-macro' is cut out. The resulting
- * expression starts with the memoized variable, that is at the cdr of
- * the input expression. */
- SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
- return cdr_expr;
- }
-}
-
-#endif /* SCM_ENABLE_ELISP */
-
-
-static SCM
-unmemoize_builtin_macro (const SCM expr, const SCM env)
-{
- switch (ISYMNUM (SCM_CAR (expr)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- return unmemoize_and (expr, env);
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- return unmemoize_begin (expr, env);
-
- case (ISYMNUM (SCM_IM_CASE)):
- return unmemoize_case (expr, env);
-
- case (ISYMNUM (SCM_IM_COND)):
- return unmemoize_cond (expr, env);
-
- case (ISYMNUM (SCM_IM_DELAY)):
- return unmemoize_delay (expr, env);
-
- case (ISYMNUM (SCM_IM_DO)):
- return unmemoize_do (expr, env);
-
- case (ISYMNUM (SCM_IM_IF)):
- return unmemoize_if (expr, env);
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- return unmemoize_lambda (expr, env);
-
- case (ISYMNUM (SCM_IM_LET)):
- return unmemoize_let (expr, env);
-
- case (ISYMNUM (SCM_IM_LETREC)):
- return unmemoize_letrec (expr, env);
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- return unmemoize_letstar (expr, env);
-
- case (ISYMNUM (SCM_IM_OR)):
- return unmemoize_or (expr, env);
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- return unmemoize_quote (expr, env);
-
- case (ISYMNUM (SCM_IM_SET_X)):
- return unmemoize_set_x (expr, env);
-
- case (ISYMNUM (SCM_IM_APPLY)):
- return unmemoize_apply (expr, env);
-
- case (ISYMNUM (SCM_IM_BIND)):
- return unmemoize_exprs (expr, env); /* FIXME */
-
- case (ISYMNUM (SCM_IM_CONT)):
- return unmemoize_atcall_cc (expr, env);
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- return unmemoize_at_call_with_values (expr, env);
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- return unmemoize_atslot_ref (expr, env);
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- return unmemoize_atslot_set_x (expr, env);
+ {
+ SCM mod, var;
+ mod = scm_resolve_module (CAR (mx));
+ if (scm_is_true (CDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADR (mx));
+ if (scm_is_true (scm_variable_bound_p (var)))
+ SCM_SET_SMOB_OBJECT (x, var);
+ return scm_variable_ref (var);
+ }
- case (ISYMNUM (SCM_IM_NIL_COND)):
- return unmemoize_exprs (expr, env); /* FIXME */
+ case SCM_M_MODULE_SET:
+ if (SCM_VARIABLEP (CDR (mx)))
+ {
+ SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ SCM mod, var;
+ mod = scm_resolve_module (CADR (mx));
+ if (scm_is_true (CDDDR (mx)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, CADDR (mx));
+ SCM_SET_SMOB_OBJECT (x, var);
+ SCM_VARIABLE_SET (var, eval (CAR (mx), env));
+ return SCM_UNSPECIFIED;
+ }
default:
- return unmemoize_exprs (expr, env); /* FIXME */
+ abort ();
}
}
-
-/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
- * respectively a memoized body together with its environment and rewrite it
- * to its original form. Thus, these functions are the inversion of the
- * rewrite rules above. The procedure is not optimized for speed. It's used
- * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
- *
- * Unmemoizing is not a reliable process. You cannot in general expect to get
- * the original source back.
- *
- * However, GOOPS currently relies on this for method compilation. This ought
- * to change. */
-
-SCM
-scm_i_unmemocopy_expr (SCM expr, SCM env)
-{
- const SCM source_properties = scm_whash_lookup (scm_source_whash, expr);
- const SCM um_expr = unmemoize_expression (expr, env);
-
- if (scm_is_true (source_properties))
- scm_whash_insert (scm_source_whash, um_expr, source_properties);
-
- return um_expr;
-}
-
-SCM
-scm_i_unmemocopy_body (SCM forms, SCM env)
-{
- const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
- const SCM um_forms = unmemoize_exprs (forms, env);
-
- if (scm_is_true (source_properties))
- scm_whash_insert (scm_source_whash, um_forms, source_properties);
-
- return um_forms;
-}
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-static SCM scm_m_undefine (SCM expr, SCM env);
-
-SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
-
-static SCM
-scm_m_undefine (SCM expr, SCM env)
+static SCM
+apply (SCM proc, SCM args)
{
- SCM variable;
- SCM location;
-
- const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
-
- scm_c_issue_deprecation_warning
- ("`undefine' is deprecated.\n");
-
- variable = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
- location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
- ASSERT_SYNTAX_2 (scm_is_true (location)
- && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
- "variable already unbound ", variable, expr);
- SCM_VARIABLE_SET (location, SCM_UNDEFINED);
- return SCM_UNSPECIFIED;
-}
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
+ SCM arg1, arg2, arg3, rest;
+ unsigned int nargs;
-
-/*****************************************************************************/
-/*****************************************************************************/
-/* The definitions for execution start here. */
-/*****************************************************************************/
-/*****************************************************************************/
-
-SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
-SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol, "memoize-symbol");
-SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
-SCM_SYMBOL (sym_instead, "instead");
-
-/* A function object to implement "apply" for non-closure functions. */
-static SCM f_apply;
-/* An endless list consisting of #<undefined> objects: */
-static SCM undefineds;
+ SCM_ASRTGO (SCM_NIMP (proc), badproc);
+ /* Args contains a list of all args. */
+ {
+ int ilen = scm_ilength (args);
+ if (ilen < 0)
+ scm_wrong_num_args (proc);
+ nargs = ilen;
+ }
-int
-scm_badargsp (SCM formals, SCM args)
-{
- while (!scm_is_null (formals))
- {
- if (!scm_is_pair (formals))
- return 0;
- if (scm_is_null (args))
- return 1;
- formals = SCM_CDR (formals);
- args = SCM_CDR (args);
+ /* Parse args. */
+ switch (nargs)
+ {
+ case 0:
+ arg1 = SCM_UNDEFINED; arg2 = SCM_UNDEFINED;
+ arg3 = SCM_UNDEFINED; rest = SCM_EOL;
+ break;
+ case 1:
+ arg1 = CAR (args); arg2 = SCM_UNDEFINED;
+ arg3 = SCM_UNDEFINED; rest = SCM_EOL;
+ break;
+ case 2:
+ arg1 = CAR (args); arg2 = CADR (args);
+ arg3 = SCM_UNDEFINED; rest = SCM_EOL;
+ break;
+ default:
+ arg1 = CAR (args); arg2 = CADR (args);
+ arg3 = CADDR (args); rest = CDDDR (args);
+ break;
}
- return !scm_is_null (args) ? 1 : 0;
-}
-
-
-
-/* The evaluator contains a plethora of EVAL symbols.
- *
- *
- * EVALIM is used when it is known that the expression is an
- * immediate. (This macro never calls an evaluator.)
- *
- * EVAL evaluates an expression that is expected to have its symbols already
- * memoized. Expressions that are not of the form '(<form> <form> ...)' are
- * evaluated inline without calling an evaluator.
- *
- * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
- * potentially replacing a symbol at the position Y:<form> by its memoized
- * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
- * evaluation is performed inline without calling an evaluator.
- *
- */
-
-#define EVALIM2(x) \
- ((scm_is_eq ((x), SCM_EOL) \
- ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
- : 0), \
- (x))
-
-#define EVALIM(x, env) (SCM_ILOCP (x) \
- ? *scm_ilookup ((x), (env)) \
- : EVALIM2(x))
-
-#define EVAL(x, env) \
- (SCM_IMP (x) \
- ? EVALIM2 (x) \
- : (SCM_VARIABLEP (x) \
- ? SCM_VARIABLE_REF (x) \
- : (scm_is_pair (x) \
- ? eval ((x), (env)) \
- : (x))))
-
-#define EVALCAR(x, env) \
- (SCM_IMP (SCM_CAR (x)) \
- ? EVALIM (SCM_CAR (x), (env)) \
- : (SCM_VARIABLEP (SCM_CAR (x)) \
- ? SCM_VARIABLE_REF (SCM_CAR (x)) \
- : (scm_is_pair (SCM_CAR (x)) \
- ? eval (SCM_CAR (x), (env)) \
- : (!scm_is_symbol (SCM_CAR (x)) \
- ? SCM_CAR (x) \
- : *scm_lookupcar ((x), (env), 1)))))
-
-scm_i_pthread_mutex_t source_mutex;
-
-
-/* Lookup a given local variable in an environment. The local variable is
- * given as an iloc, that is a triple <frame, binding, last?>, where frame
- * indicates the relative number of the environment frame (counting upwards
- * from the innermost environment frame), binding indicates the number of the
- * binding within the frame, and last? (which is extracted from the iloc using
- * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
- * very end of the improper list of bindings. */
-SCM *
-scm_ilookup (SCM iloc, SCM env)
-{
- unsigned int frame_nr = SCM_IFRAME (iloc);
- unsigned int binding_nr = SCM_IDIST (iloc);
- SCM frames = env;
- SCM bindings;
-
- for (; 0 != frame_nr; --frame_nr)
- frames = SCM_CDR (frames);
-
- bindings = SCM_CAR (frames);
- for (; 0 != binding_nr; --binding_nr)
- bindings = SCM_CDR (bindings);
-
- if (SCM_ICDRP (iloc))
- return SCM_CDRLOC (bindings);
- return SCM_CARLOC (SCM_CDR (bindings));
-}
-
-
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-
-/* Call this for variables that are unfound.
- */
-static void
-error_unbound_variable (SCM symbol)
-{
- scm_error (scm_unbound_variable_key, NULL,
- "Unbound variable: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
-/* Call this for variables that are found but contain SCM_UNDEFINED.
- */
-static void
-error_defined_variable (SCM symbol)
-{
- /* We use the 'unbound-variable' key here as well, since it
- basically is the same kind of error, with a slight variation in
- the displayed message.
- */
- scm_error (scm_unbound_variable_key, NULL,
- "Variable used before given a value: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
-/* The Lookup Car Race
- - by Eva Luator
-
- Memoization of variables and special forms is done while executing
- the code for the first time. As long as there is only one thread
- everything is fine, but as soon as two threads execute the same
- code concurrently `for the first time' they can come into conflict.
-
- This memoization includes rewriting variable references into more
- efficient forms and expanding macros. Furthermore, macro expansion
- includes `compiling' special forms like `let', `cond', etc. into
- tree-code instructions.
-
- There shouldn't normally be a problem with memoizing local and
- global variable references (into ilocs and variables), because all
- threads will mutate the code in *exactly* the same way and (if I
- read the C code correctly) it is not possible to observe a half-way
- mutated cons cell. The lookup procedure can handle this
- transparently without any critical sections.
-
- It is different with macro expansion, because macro expansion
- happens outside of the lookup procedure and can't be
- undone. Therefore the lookup procedure can't cope with it. It has
- to indicate failure when it detects a lost race and hope that the
- caller can handle it. Luckily, it turns out that this is the case.
-
- An example to illustrate this: Suppose that the following form will
- be memoized concurrently by two threads
-
- (let ((x 12)) x)
-
- Let's first examine the lookup of X in the body. The first thread
- decides that it has to find the symbol "x" in the environment and
- starts to scan it. Then the other thread takes over and actually
- overtakes the first. It looks up "x" and substitutes an
- appropriate iloc for it. Now the first thread continues and
- completes its lookup. It comes to exactly the same conclusions as
- the second one and could - without much ado - just overwrite the
- iloc with the same iloc.
-
- But let's see what will happen when the race occurs while looking
- up the symbol "let" at the start of the form. It could happen that
- the second thread interrupts the lookup of the first thread and not
- only substitutes a variable for it but goes right ahead and
- replaces it with the compiled form (#@let* (x 12) x). Now, when
- the first thread completes its lookup, it would replace the #@let*
- with a variable containing the "let" binding, effectively reverting
- the form to (let (x 12) x). This is wrong. It has to detect that
- it has lost the race and the evaluator has to reconsider the
- changed form completely.
-
- This race condition could be resolved with some kind of traffic
- light (like mutexes) around scm_lookupcar, but I think that it is
- best to avoid them in this case. They would serialize memoization
- completely and because lookup involves calling arbitrary Scheme
- code (via the lookup-thunk), threads could be blocked for an
- arbitrary amount of time or even deadlock. But with the current
- solution a lot of unnecessary work is potentially done. */
-
-/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
- return NULL to indicate a failed lookup due to some race conditions
- between threads. This only happens when VLOC is the first cell of
- a special form that will eventually be memoized (like `let', etc.)
- In that case the whole lookup is bogus and the caller has to
- reconsider the complete special form.
-
- SCM_LOOKUPCAR is still there, of course. It just calls
- SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
- should only be called when it is known that VLOC is not the first
- pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
- for NULL. I think I've found the only places where this
- applies. */
-
-static SCM *
-scm_lookupcar1 (SCM vloc, SCM genv, int check)
-{
- SCM env = genv;
- register SCM *al, fl, var = SCM_CAR (vloc);
- register SCM iloc = SCM_ILOC00;
- for (; SCM_NIMP (env); env = SCM_CDR (env))
+ tail:
+ switch (SCM_TYP7 (proc))
{
- if (!scm_is_pair (SCM_CAR (env)))
- break;
- al = SCM_CARLOC (env);
- for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
- {
- if (!scm_is_pair (fl))
- {
- if (scm_is_eq (fl, var))
- {
- if (!scm_is_eq (SCM_CAR (vloc), var))
- goto race;
- SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
- return SCM_CDRLOC (*al);
- }
- else
- break;
- }
- al = SCM_CDRLOC (*al);
- if (scm_is_eq (SCM_CAR (fl), var))
- {
- if (SCM_UNBNDP (SCM_CAR (*al)))
- error_defined_variable (var);
- if (!scm_is_eq (SCM_CAR (vloc), var))
- goto race;
- SCM_SETCAR (vloc, iloc);
- return SCM_CARLOC (*al);
- }
- iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
- }
- iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
- }
- {
- SCM top_thunk, real_var;
- if (SCM_NIMP (env))
- {
- top_thunk = SCM_CAR (env); /* env now refers to a
- top level env thunk */
- env = SCM_CDR (env);
- }
- else
- top_thunk = SCM_BOOL_F;
- real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
- if (scm_is_false (real_var))
- goto errout;
-
- if (!scm_is_null (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
- {
- errout:
- if (check)
- {
- if (scm_is_null (env))
- error_unbound_variable (var);
- else
- scm_misc_error (NULL, "Damaged environment: ~S",
- scm_list_1 (var));
- }
- else
- {
- /* A variable could not be found, but we shall
- not throw an error. */
- static SCM undef_object = SCM_UNDEFINED;
- return &undef_object;
- }
- }
-
- if (!scm_is_eq (SCM_CAR (vloc), var))
+ case scm_tcs_closures:
{
- /* Some other thread has changed the very cell we are working
- on. In effect, it must have done our job or messed it up
- completely. */
- race:
- var = SCM_CAR (vloc);
- if (SCM_VARIABLEP (var))
- return SCM_VARIABLE_LOC (var);
- if (SCM_ILOCP (var))
- return scm_ilookup (var, genv);
- /* We can't cope with anything else than variables and ilocs. When
- a special form has been memoized (i.e. `let' into `#@let') we
- return NULL and expect the calling function to do the right
- thing. For the evaluator, this means going back and redoing
- the dispatch on the car of the form. */
- return NULL;
+ int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM env = SCM_ENV (proc);
+ if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, args = CDR (args))
+ env = scm_cons (CAR (args), env);
+ env = scm_cons (args, env);
+ }
+ else
+ {
+ for (; scm_is_pair (args); args = CDR (args), nreq--)
+ env = scm_cons (CAR (args), env);
+ if (SCM_UNLIKELY (nreq != 0))
+ scm_wrong_num_args (proc);
+ }
+ return eval (SCM_CLOSURE_BODY (proc), env);
}
-
- SCM_SETCAR (vloc, real_var);
- return SCM_VARIABLE_LOC (real_var);
- }
-}
-
-SCM *
-scm_lookupcar (SCM vloc, SCM genv, int check)
-{
- SCM *loc = scm_lookupcar1 (vloc, genv, check);
- if (loc == NULL)
- abort ();
- return loc;
-}
-
-
-/* During execution, look up a symbol in the top level of the given local
- * environment and return the corresponding variable object. If no binding
- * for the symbol can be found, an 'Unbound variable' error is signalled. */
-static SCM
-lazy_memoize_variable (const SCM symbol, const SCM environment)
-{
- const SCM top_level = scm_env_top_level (environment);
- const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
-
- if (scm_is_false (variable))
- error_unbound_variable (symbol);
- else
- return variable;
-}
-
-
-SCM
-scm_eval_car (SCM pair, SCM env)
-{
- return EVALCAR (pair, env);
-}
-
-
-SCM
-scm_eval_body (SCM code, SCM env)
-{
- SCM next;
-
- again:
- next = SCM_CDR (code);
- while (!scm_is_null (next))
- {
- if (SCM_IMP (SCM_CAR (code)))
- {
- if (SCM_ISYMP (SCM_CAR (code)))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (code)))
- m_expand_body (code, env);
- scm_dynwind_end ();
- goto again;
- }
- }
+ case scm_tc7_subr_2o:
+ if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2);
+ case scm_tc7_subr_2:
+ if (nargs != 2) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2);
+ case scm_tc7_subr_0:
+ if (nargs != 0) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) ();
+ case scm_tc7_subr_1:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1);
+ case scm_tc7_subr_1o:
+ if (nargs > 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1);
+ case scm_tc7_dsubr:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ if (SCM_I_INUMP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)));
+ else if (SCM_REALP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)));
+ else if (SCM_BIGP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)));
+ else if (SCM_FRACTIONP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+ case scm_tc7_cxr:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
+ case scm_tc7_subr_3:
+ if (nargs != 3) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2, arg3);
+ case scm_tc7_lsubr:
+ return SCM_SUBRF (proc) (args);
+ case scm_tc7_lsubr_2:
+ if (nargs < 2) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2, scm_cddr (args));
+ case scm_tc7_asubr:
+ if (nargs < 2)
+ return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+ for (args = CDR (args); nargs > 1; args = CDR (args), nargs--)
+ arg1 = SCM_SUBRF (proc) (arg1, CAR (args));
+ return arg1;
+ case scm_tc7_program:
+ return scm_vm_apply (scm_the_vm (), proc, args);
+ case scm_tc7_rpsubr:
+ if (nargs == 0)
+ return SCM_BOOL_T;
+ for (args = CDR (args); nargs > 1;
+ arg1 = CAR (args), args = CDR (args), nargs--)
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, CAR (args))))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ switch (nargs)
+ {
+ case 0:
+ return SCM_SMOB_APPLY_0 (proc);
+ case 1:
+ return SCM_SMOB_APPLY_1 (proc, arg1);
+ case 2:
+ return SCM_SMOB_APPLY_2 (proc, arg1, arg2);
+ default:
+ return SCM_SMOB_APPLY_3 (proc, arg1, arg2, scm_cddr (args));
+ }
+ case scm_tc7_gsubr:
+ return scm_i_gsubr_apply_list (proc, args);
+ case scm_tc7_pws:
+ return apply (SCM_PROCEDURE (proc), args);
+ case scm_tcs_struct:
+ if (SCM_STRUCT_APPLICABLE_P (proc))
+ {
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ goto tail;
+ }
else
- EVAL (SCM_CAR (code), env);
- code = next;
- next = SCM_CDR (code);
+ goto badproc;
+ default:
+ badproc:
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
}
- return EVALCAR (code, env);
}
-/* scm_last_debug_frame contains a pointer to the last debugging information
- * stack frame. It is accessed very often from the debugging evaluator, so it
- * should probably not be indirectly addressed. Better to save and restore it
- * from the current root at any stack swaps.
- */
-
-/* scm_debug_eframe_size is the number of slots available for pseudo
- * stack frames at each real stack frame.
- */
-
-long scm_debug_eframe_size;
-
-int scm_debug_mode_p;
-int scm_check_entry_p;
-int scm_check_apply_p;
-int scm_check_exit_p;
-int scm_check_memoize_p;
-
scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
{ 0 }
@@ -3033,7 +667,6 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
FUNC_NAME);
/* njrev: same again. */
- SCM_RESET_DEBUG_MODE;
SCM_CRITICAL_SECTION_END;
return ans;
}
@@ -3374,7 +1007,6 @@ SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
}
#undef FUNC_NAME
-
static int
promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
@@ -3421,86 +1053,17 @@ SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
}
#undef FUNC_NAME
-
-/* We have three levels of EVAL here:
-
- - scm_i_eval (exp, env)
-
- evaluates EXP in environment ENV. ENV is a lexical environment
- structure as used by the actual tree code evaluator. When ENV is
- a top-level environment, then changes to the current module are
- tracked by updating ENV so that it continues to be in sync with
- the current module.
-
- - scm_primitive_eval (exp)
-
- evaluates EXP in the top-level environment as determined by the
- current module. This is done by constructing a suitable
- environment and calling scm_i_eval. Thus, changes to the
- top-level module are tracked normally.
-
- - scm_eval (exp, mod_or_state)
-
- evaluates EXP while MOD_OR_STATE is the current module or current
- dynamic state (as appropriate). This is done by setting the
- current module (or dynamic state) to MOD_OR_STATE, invoking
- scm_primitive_eval on EXP, and then restoring the current module
- (or dynamic state) to the value it had previously. That is,
- while EXP is evaluated, changes to the current module (or dynamic
- state) are tracked, but these changes do not persist when
- scm_eval returns.
-
- For each level of evals, there are two variants, distinguished by a
- _x suffix: the ordinary variant does not modify EXP while the _x
- variant can destructively modify EXP into something completely
- unintelligible. A Scheme data structure passed as EXP to one of the
- _x variants should not ever be used again for anything. So when in
- doubt, use the ordinary variant.
-
-*/
-
-SCM
-scm_i_eval_x (SCM exp, SCM env)
-{
- if (scm_is_symbol (exp))
- return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
- else
- return EVAL (exp, env);
-}
-
-SCM
-scm_i_eval (SCM exp, SCM env)
-{
- exp = scm_copy_tree (exp);
- if (scm_is_symbol (exp))
- return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
- else
- return EVAL (exp, env);
-}
-
-SCM
-scm_primitive_eval_x (SCM exp)
-{
- SCM env;
- SCM transformer = scm_current_module_transformer ();
- if (SCM_NIMP (transformer))
- exp = scm_call_1 (transformer, exp);
- env = scm_top_level_env (scm_current_module_lookup_closure ());
- return scm_i_eval_x (exp, env);
-}
-
SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
(SCM exp),
"Evaluate @var{exp} in the top-level environment specified by\n"
"the current module.")
#define FUNC_NAME s_scm_primitive_eval
{
- SCM env;
SCM transformer = scm_current_module_transformer ();
if (scm_is_true (transformer))
exp = scm_call_1 (transformer, exp);
- env = scm_top_level_env (scm_current_module_lookup_closure ());
- return scm_i_eval (exp, env);
+ exp = scm_memoize_expression (exp);
+ return eval (exp, SCM_EOL);
}
#undef FUNC_NAME
@@ -3510,23 +1073,6 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
* system, where we would like to make the choice of evaluation
* environment explicit. */
-SCM
-scm_eval_x (SCM exp, SCM module_or_state)
-{
- SCM res;
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- if (scm_is_dynamic_state (module_or_state))
- scm_dynwind_current_dynamic_state (module_or_state);
- else
- scm_dynwind_current_module (module_or_state);
-
- res = scm_primitive_eval_x (exp);
-
- scm_dynwind_end ();
- return res;
-}
-
SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
(SCM exp, SCM module_or_state),
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
@@ -3559,1201 +1105,7 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
#undef FUNC_NAME
-/* At this point, eval and scm_apply are generated.
- */
-
-static void
-eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
-{
- SCM argv[10];
- int i = 0, imax = sizeof (argv) / sizeof (SCM);
-
- while (!scm_is_null (init_forms))
- {
- if (imax == i)
- {
- eval_letrec_inits (env, init_forms, init_values_eol);
- break;
- }
- argv[i++] = EVALCAR (init_forms, env);
- init_forms = SCM_CDR (init_forms);
- }
-
- for (i--; i >= 0; i--)
- {
- **init_values_eol = scm_list_1 (argv[i]);
- *init_values_eol = SCM_CDRLOC (**init_values_eol);
- }
-}
-
-#define PREP_APPLY(p, l) \
-{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
-
-#define ENTER_APPLY \
-do { \
- SCM_SET_ARGSREADY (debug);\
- if (scm_check_apply_p && SCM_TRAPS_P)\
- if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
- {\
- SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
- SCM_SET_TRACED_FRAME (debug); \
- SCM_TRAPS_P = 0;\
- tmp = scm_make_debugobj (&debug);\
- scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
- SCM_TRAPS_P = 1;\
- }\
-} while (0)
-
-#define RETURN(e) do { proc = (e); goto exit; } while (0)
-
-#ifdef STACK_CHECKING
-# ifndef EVAL_STACK_CHECKING
-# define EVAL_STACK_CHECKING
-# endif /* EVAL_STACK_CHECKING */
-#endif /* STACK_CHECKING */
-
-
-
-
-static SCM
-eval_args (SCM l, SCM env, SCM proc, SCM *lloc)
-{
- SCM *results = lloc;
- while (scm_is_pair (l))
- {
- const SCM res = EVALCAR (l, env);
-
- *lloc = scm_list_1 (res);
- lloc = SCM_CDRLOC (*lloc);
- l = SCM_CDR (l);
- }
- if (!scm_is_null (l))
- scm_wrong_num_args (proc);
- return *results;
-}
-
-
-
-
-/* Update the toplevel environment frame ENV so that it refers to the
- * current module. */
-#define UPDATE_TOPLEVEL_ENV(env) \
- do { \
- SCM p = scm_current_module_lookup_closure (); \
- if (p != SCM_CAR (env)) \
- env = scm_top_level_env (p); \
- } while (0)
-
-
-#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
- ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
-
-
-/* This is the evaluator.
- *
- * eval takes two input parameters, x and env: x is a single expression to be
- * evalutated. env is the environment in which bindings are searched.
- *
- * x is known to be a pair. Since x is a single expression, it is necessarily
- * in a tail position. If x is just a call to another function like in the
- * expression (foo exp1 exp2 ...), the realization of that call therefore
- * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
- * however, may do so). This is realized by making extensive use of 'goto'
- * statements within the evaluator: The gotos replace recursive calls to
- * `eval', thus re-using the same stack frame that `eval' was already using.
- * If, however, x represents some form that requires to evaluate a sequence of
- * expressions like (begin exp1 exp2 ...), then recursive calls to `eval' are
- * performed for all but the last expression of that sequence. */
-
-static SCM
-eval (SCM x, SCM env)
-{
- SCM proc, arg1;
- scm_t_debug_frame debug;
- scm_t_debug_info *debug_info_end;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = 0;
- /*
- * The debug.vect contains twice as much scm_t_debug_info frames as the
- * user has specified with (debug-set! frames <n>).
- *
- * Even frames are eval frames, odd frames are apply frames.
- */
- debug.vect = alloca (scm_debug_eframe_size * sizeof (scm_t_debug_info));
- debug.info = debug.vect;
- debug_info_end = debug.vect + scm_debug_eframe_size;
- scm_i_set_last_debug_frame (&debug);
-#ifdef EVAL_STACK_CHECKING
- if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
- {
- debug.info->e.exp = x;
- debug.info->e.env = env;
- scm_report_stack_overflow ();
- }
-#endif
-
- goto start;
-
-loop:
- SCM_CLEAR_ARGSREADY (debug);
- if (SCM_OVERFLOWP (debug))
- --debug.info;
- /*
- * In theory, this should be the only place where it is necessary to
- * check for space in debug.vect since both eval frames and
- * available space are even.
- *
- * For this to be the case, however, it is necessary that primitive
- * special forms which jump back to `loop', `begin' or some similar
- * label call PREP_APPLY.
- */
- else if (++debug.info >= debug_info_end)
- {
- SCM_SET_OVERFLOW (debug);
- debug.info -= 2;
- }
-
-start:
- debug.info->e.exp = x;
- debug.info->e.env = env;
- if (scm_check_entry_p && SCM_TRAPS_P)
- {
- if (SCM_ENTER_FRAME_P
- || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
- {
- SCM stackrep;
- SCM tail = scm_from_bool (SCM_TAILRECP (debug));
- SCM_SET_TAILREC (debug);
- stackrep = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
- scm_sym_enter_frame,
- stackrep,
- tail,
- unmemoize_expression (x, env));
- SCM_TRAPS_P = 1;
- if (scm_is_pair (stackrep) &&
- scm_is_eq (SCM_CAR (stackrep), sym_instead))
- {
- /* This gives the possibility for the debugger to modify
- the source expression before evaluation. */
- x = SCM_CDR (stackrep);
- if (SCM_IMP (x))
- RETURN (x);
- }
- }
- }
-dispatch:
- SCM_TICK;
- if (SCM_ISYMP (SCM_CAR (x)))
- {
- switch (ISYMNUM (SCM_CAR (x)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM test_result = EVALCAR (x, env);
- if (scm_is_false_or_nil (test_result))
- RETURN (SCM_BOOL_F);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- x = SCM_CDR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
-
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
-
- begin:
- /* If we are on toplevel with a lookup closure, we need to sync
- with the current module. */
- if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
- {
- UPDATE_TOPLEVEL_ENV (env);
- while (!scm_is_null (SCM_CDR (x)))
- {
- EVALCAR (x, env);
- UPDATE_TOPLEVEL_ENV (env);
- x = SCM_CDR (x);
- }
- goto carloop;
- }
- else
- goto nontoplevel_begin;
-
- nontoplevel_begin:
- while (!scm_is_null (SCM_CDR (x)))
- {
- const SCM form = SCM_CAR (x);
- if (SCM_IMP (form))
- {
- if (SCM_ISYMP (form))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (x)))
- m_expand_body (x, env);
- scm_dynwind_end ();
- goto nontoplevel_begin;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
- }
- else
- (void) EVAL (form, env);
- x = SCM_CDR (x);
- }
-
- carloop:
- {
- /* scm_eval last form in list */
- const SCM last_form = SCM_CAR (x);
-
- if (scm_is_pair (last_form))
- {
- /* This is by far the most frequent case. */
- x = last_form;
- goto loop; /* tail recurse */
- }
- else if (SCM_IMP (last_form))
- RETURN (EVALIM (last_form, env));
- else if (SCM_VARIABLEP (last_form))
- RETURN (SCM_VARIABLE_REF (last_form));
- else if (scm_is_symbol (last_form))
- RETURN (*scm_lookupcar (x, env, 1));
- else
- RETURN (last_form);
- }
-
-
- case (ISYMNUM (SCM_IM_CASE)):
- x = SCM_CDR (x);
- {
- const SCM key = EVALCAR (x, env);
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- SCM labels = SCM_CAR (clause);
- if (scm_is_eq (labels, SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- while (!scm_is_null (labels))
- {
- const SCM label = SCM_CAR (labels);
- if (scm_is_eq (label, key)
- || scm_is_true (scm_eqv_p (label, key)))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- labels = SCM_CDR (labels);
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_COND)):
- x = SCM_CDR (x);
- while (!scm_is_null (x))
- {
- const SCM clause = SCM_CAR (x);
- if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- arg1 = EVALCAR (clause, env);
- /* SRFI 61 extended cond */
- if (!scm_is_null (SCM_CDR (clause))
- && !scm_is_null (SCM_CDDR (clause))
- && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
- {
- SCM xx, guard_result;
- if (SCM_VALUESP (arg1))
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- else
- arg1 = scm_list_1 (arg1);
- xx = SCM_CDR (clause);
- proc = EVALCAR (xx, env);
- guard_result = scm_apply (proc, arg1, SCM_EOL);
- if (scm_is_true_and_not_nil (guard_result))
- {
- proc = SCM_CDDR (xx);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
- }
- else if (scm_is_true_and_not_nil (arg1))
- {
- x = SCM_CDR (clause);
- if (scm_is_null (x))
- RETURN (arg1);
- else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_DO)):
- x = SCM_CDR (x);
- {
- /* Compute the initialization values and the initial environment. */
- SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- while (!scm_is_null (init_forms))
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDR (x);
- {
- SCM test_form = SCM_CAR (x);
- SCM body_forms = SCM_CADR (x);
- SCM step_forms = SCM_CDDR (x);
-
- SCM test_result = EVALCAR (test_form, env);
-
- while (scm_is_false_or_nil (test_result))
- {
- {
- /* Evaluate body forms. */
- SCM temp_forms;
- for (temp_forms = body_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- SCM form = SCM_CAR (temp_forms);
- /* Dirk:FIXME: We only need to eval forms that may have
- * a side effect here. This is only true for forms that
- * start with a pair. All others are just constants.
- * Since with the current memoizer 'form' may hold a
- * constant, we call EVAL here to handle the constant
- * cases. In the long run it would make sense to have
- * the macro transformer of 'do' eliminate all forms
- * that have no sideeffect. Then instead of EVAL we
- * could call CEVAL directly here. */
- (void) EVAL (form, env);
- }
- }
-
- {
- /* Evaluate the step expressions. */
- SCM temp_forms;
- SCM step_values = SCM_EOL;
- for (temp_forms = step_forms;
- !scm_is_null (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- const SCM value = EVALCAR (temp_forms, env);
- step_values = scm_cons (value, step_values);
- }
- env = SCM_EXTEND_ENV (SCM_CAAR (env),
- step_values,
- SCM_CDR (env));
- }
-
- test_result = EVALCAR (test_form, env);
- }
- }
- x = SCM_CDAR (x);
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_IF)):
- x = SCM_CDR (x);
- {
- SCM test_result = EVALCAR (x, env);
- x = SCM_CDR (x); /* then expression */
- if (scm_is_false_or_nil (test_result))
- {
- x = SCM_CDR (x); /* else expression */
- if (scm_is_null (x))
- RETURN (SCM_UNSPECIFIED);
- }
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LET)):
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CADR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!scm_is_null (init_forms));
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETREC)):
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CAR (x);
- SCM init_values = scm_list_1 (SCM_BOOL_T);
- SCM *init_values_eol = SCM_CDRLOC (init_values);
- eval_letrec_inits (env, init_forms, &init_values_eol);
- SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- x = SCM_CDR (x);
- {
- SCM bindings = SCM_CAR (x);
- if (!scm_is_null (bindings))
- {
- do
- {
- SCM name = SCM_CAR (bindings);
- SCM init = SCM_CDR (bindings);
- env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
- bindings = SCM_CDR (init);
- }
- while (!scm_is_null (bindings));
- }
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
-
-
- case (ISYMNUM (SCM_IM_OR)):
- x = SCM_CDR (x);
- while (!scm_is_null (SCM_CDR (x)))
- {
- SCM val = EVALCAR (x, env);
- if (scm_is_true_and_not_nil (val))
- RETURN (val);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- RETURN (scm_closure (SCM_CDR (x), env));
-
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- RETURN (SCM_CDR (x));
-
-
- case (ISYMNUM (SCM_IM_SET_X)):
- x = SCM_CDR (x);
- {
- SCM *location;
- SCM variable = SCM_CAR (x);
- if (SCM_ILOCP (variable))
- location = scm_ilookup (variable, env);
- else if (SCM_VARIABLEP (variable))
- location = SCM_VARIABLE_LOC (variable);
- else
- {
- /* (scm_is_symbol (variable)) is known to be true */
- variable = lazy_memoize_variable (variable, env);
- SCM_SETCAR (x, variable);
- location = SCM_VARIABLE_LOC (variable);
- }
- x = SCM_CDR (x);
- *location = EVALCAR (x, env);
- }
- RETURN (SCM_UNSPECIFIED);
-
-
- case (ISYMNUM (SCM_IM_APPLY)):
- /* Evaluate the procedure to be applied. */
- x = SCM_CDR (x);
- proc = EVALCAR (x, env);
- PREP_APPLY (proc, SCM_EOL);
-
- /* Evaluate the argument holding the list of arguments */
- x = SCM_CDR (x);
- arg1 = EVALCAR (x, env);
-
- apply_proc:
- /* Go here to tail-apply a procedure. PROC is the procedure and
- * ARG1 is the list of arguments. PREP_APPLY must have been called
- * before jumping to apply_proc. */
- if (SCM_CLOSUREP (proc))
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- debug.info->a.args = arg1;
- if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
- scm_wrong_num_args (proc);
- ENTER_APPLY;
- /* Copy argument list */
- if (SCM_NULL_OR_NIL_P (arg1))
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- else
- {
- SCM args = scm_list_1 (SCM_CAR (arg1));
- SCM tail = args;
- arg1 = SCM_CDR (arg1);
- while (!SCM_NULL_OR_NIL_P (arg1))
- {
- SCM new_tail = scm_list_1 (SCM_CAR (arg1));
- SCM_SETCDR (tail, new_tail);
- tail = new_tail;
- arg1 = SCM_CDR (arg1);
- }
- env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
- }
-
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- else
- {
- ENTER_APPLY;
- RETURN (scm_apply (proc, arg1, SCM_EOL));
- }
-
-
- case (ISYMNUM (SCM_IM_CONT)):
- {
- int first;
- SCM val = scm_make_continuation (&first);
-
- if (!first)
- RETURN (val);
- else
- {
- arg1 = val;
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
-
-
- case (ISYMNUM (SCM_IM_DELAY)):
- RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
- }
-
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- x = SCM_CDR (x);
- {
- SCM instance = EVALCAR (x, env);
- unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
- SCM value = EVALCAR (SCM_CDDR (x), env);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
- RETURN (SCM_UNSPECIFIED);
- }
-
-
-#if SCM_ENABLE_ELISP
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
- {
- SCM test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- while (!SCM_NULL_OR_NIL_P (x))
- {
- SCM test_result = EVALCAR (test_form, env);
- if (!(scm_is_false (test_result)
- || SCM_NULL_OR_NIL_P (test_result)))
- {
- if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (test_result);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- else
- {
- test_form = SCM_CDR (x);
- x = SCM_CDR (test_form);
- }
- }
- x = test_form;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
-
-#endif /* SCM_ENABLE_ELISP */
-
- case (ISYMNUM (SCM_IM_BIND)):
- {
- SCM vars, exps, vals;
-
- x = SCM_CDR (x);
- vars = SCM_CAAR (x);
- exps = SCM_CDAR (x);
- vals = SCM_EOL;
- while (!scm_is_null (exps))
- {
- vals = scm_cons (EVALCAR (exps, env), vals);
- exps = SCM_CDR (exps);
- }
-
- scm_swap_bindings (vars, vals);
- scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
-
- /* Ignore all but the last evaluation result. */
- for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
- {
- if (scm_is_pair (SCM_CAR (x)))
- eval (SCM_CAR (x), env);
- }
- proc = EVALCAR (x, env);
-
- scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
- scm_swap_bindings (vars, vals);
-
- RETURN (proc);
- }
-
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- {
- SCM producer;
-
- x = SCM_CDR (x);
- producer = EVALCAR (x, env);
- x = SCM_CDR (x);
- proc = EVALCAR (x, env); /* proc is the consumer. */
- arg1 = scm_apply (producer, SCM_EOL, SCM_EOL);
- if (SCM_VALUESP (arg1))
- {
- /* The list of arguments is not copied. Rather, it is assumed
- * that this has been done by the 'values' procedure. */
- arg1 = scm_struct_ref (arg1, SCM_INUM0);
- }
- else
- {
- arg1 = scm_list_1 (arg1);
- }
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
-
-
- default:
- break;
- }
- }
- else
- {
- if (SCM_VARIABLEP (SCM_CAR (x)))
- proc = SCM_VARIABLE_REF (SCM_CAR (x));
- else if (SCM_ILOCP (SCM_CAR (x)))
- proc = *scm_ilookup (SCM_CAR (x), env);
- else if (scm_is_pair (SCM_CAR (x)))
- proc = eval (SCM_CAR (x), env);
- else if (scm_is_symbol (SCM_CAR (x)))
- {
- SCM orig_sym = SCM_CAR (x);
- {
- SCM *location = scm_lookupcar1 (x, env, 1);
- if (location == NULL)
- {
- /* we have lost the race, start again. */
- goto dispatch;
- }
- proc = *location;
- if (scm_check_memoize_p && SCM_TRAPS_P)
- {
- SCM arg1, retval;
-
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- retval = SCM_BOOL_T;
- SCM_TRAPS_P = 0;
- retval = scm_call_4 (SCM_MEMOIZE_HDLR,
- scm_sym_memoize_symbol,
- arg1, x, env);
-
- /*
- do something with retval?
- */
- SCM_TRAPS_P = 1;
- }
- }
-
- if (SCM_MACROP (proc))
- {
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
- lookupcar */
- handle_a_macro: /* inputs: x, env, proc */
- /* Set a flag during macro expansion so that macro
- application frames can be deleted from the backtrace. */
- SCM_SET_MACROEXP (debug);
- arg1 = scm_apply (SCM_MACRO_CODE (proc), x,
- scm_cons (env, scm_listofnull));
- SCM_CLEAR_MACROEXP (debug);
- switch (SCM_MACRO_TYPE (proc))
- {
- case 3:
- case 2:
- if (!scm_is_pair (arg1))
- arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
-
- assert (!scm_is_eq (x, SCM_CAR (arg1))
- && !scm_is_eq (x, SCM_CDR (arg1)));
-
- if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
- {
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- goto dispatch;
- }
- /* Prevent memoizing of debug info expression. */
- debug.info->e.exp = scm_cons_source (debug.info->e.exp,
- SCM_CAR (x),
- SCM_CDR (x));
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (arg1));
- SCM_SETCDR (x, SCM_CDR (arg1));
- SCM_CRITICAL_SECTION_END;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
-#if SCM_ENABLE_DEPRECATED == 1
- case 1:
- x = arg1;
- if (SCM_NIMP (x))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto loop;
- }
- else
- RETURN (arg1);
-#endif
- case 0:
- RETURN (arg1);
- }
- }
- }
- else
- proc = SCM_CAR (x);
-
- if (SCM_MACROP (proc))
- goto handle_a_macro;
- }
-
-
- /* When reaching this part of the code, the following is granted: Variable x
- * holds the first pair of an expression of the form (<function> arg ...).
- * Variable proc holds the object that resulted from the evaluation of
- * <function>. In the following, the arguments (if any) will be evaluated,
- * and proc will be applied to them. If proc does not really hold a
- * function object, this will be signalled as an error on the scheme
- * level. If the number of arguments does not match the number of arguments
- * that are allowed to be passed to proc, also an error on the scheme level
- * will be signalled. */
-
- PREP_APPLY (proc, SCM_EOL);
- if (scm_is_null (SCM_CDR (x))) {
- ENTER_APPLY;
- evap0:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* no arguments given */
- case scm_tc7_subr_0:
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (SCM_EOL));
- case scm_tc7_rpsubr:
- 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;
- RETURN (SCM_SMOB_APPLY_0 (proc));
- case scm_tc7_gsubr:
- debug.info->a.proc = proc;
- debug.info->a.args = SCM_EOL;
- RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap0;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (SCM_UNLIKELY (scm_is_pair (formals)))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
- env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- proc = SCM_STRUCT_PROCEDURE (proc);
- debug.info->a.proc = proc;
- goto evap0;
- }
- else
- goto badfun;
- case scm_tc7_subr_1:
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- wrongnumargs:
- scm_wrong_num_args (proc);
- default:
- badfun:
- scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
- }
- }
-
- /* must handle macros by here */
- x = SCM_CDR (x);
- if (SCM_LIKELY (scm_is_pair (x)))
- arg1 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
- debug.info->a.args = scm_list_1 (arg1);
- x = SCM_CDR (x);
- {
- SCM arg2;
- if (scm_is_null (x))
- {
- ENTER_APPLY;
- evap1: /* inputs: proc, arg1 */
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have one argument in arg1 */
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
- case scm_tc7_cxr:
- 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:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- case scm_tc7_gsubr:
- debug.info->a.args = debug.info->a.args;
- debug.info->a.proc = proc;
- RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap1;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos1: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
- goto wrongnumargs;
- x = SCM_CLOSURE_BODY (proc);
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- proc = SCM_STRUCT_PROCEDURE (proc);
- debug.info->a.proc = proc;
- goto evap1;
- }
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_0:
- case scm_tc7_subr_3:
- case scm_tc7_lsubr_2:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- if (SCM_LIKELY (scm_is_pair (x)))
- arg2 = EVALCAR (x, env);
- else
- scm_wrong_num_args (proc);
-
- { /* have two or more arguments */
- debug.info->a.args = scm_list_2 (arg1, arg2);
- x = SCM_CDR (x);
- if (scm_is_null (x)) {
- ENTER_APPLY;
- evap2:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (arg1, arg2));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
- 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;
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
- case scm_tc7_gsubr:
- RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- operatorn:
- RETURN (scm_apply (SCM_STRUCT_PROCEDURE (proc),
- debug.info->a.args,
- SCM_EOL));
- }
- else
- goto badfun;
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_1:
- case scm_tc7_subr_3:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.info->a.proc = proc;
- if (!SCM_CLOSUREP (proc))
- goto evap2;
- /* fallthrough */
- case scm_tcs_closures:
- {
- /* clos2: */
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_is_pair (SCM_CDDR (formals))))))
- goto wrongnumargs;
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- }
- }
- if (SCM_UNLIKELY (!scm_is_pair (x)))
- scm_wrong_num_args (proc);
- debug.info->a.args = scm_cons2 (arg1, arg2,
- eval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
- ENTER_APPLY;
- evap3:
- SCM_ASRTGO (!SCM_IMP (proc), badfun);
- switch (SCM_TYP7 (proc))
- { /* have 3 or more arguments */
- case scm_tc7_subr_3:
- if (!scm_is_null (SCM_CDR (x)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CADDR (debug.info->a.args)));
- case scm_tc7_asubr:
- arg1 = SCM_SUBRF(proc)(arg1, arg2);
- arg2 = SCM_CDDR (debug.info->a.args);
- do
- {
- arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
- arg2 = SCM_CDR (arg2);
- }
- while (SCM_NIMP (arg2));
- RETURN (arg1);
- case scm_tc7_rpsubr:
- if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CDDR (debug.info->a.args);
- do
- {
- if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
- RETURN (SCM_BOOL_F);
- arg2 = SCM_CAR (arg1);
- arg1 = SCM_CDR (arg1);
- }
- while (SCM_NIMP (arg1));
- RETURN (SCM_BOOL_T);
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (arg1, arg2,
- SCM_CDDR (debug.info->a.args)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badfun;
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
- 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;
- if (!SCM_CLOSUREP (proc))
- goto evap3;
- /* fallthrough */
- case scm_tcs_closures:
- {
- const SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals)
- || (scm_is_pair (formals)
- && (scm_is_null (SCM_CDR (formals))
- || (scm_is_pair (SCM_CDR (formals))
- && scm_badargsp (SCM_CDDR (formals), x)))))
- goto wrongnumargs;
- SCM_SET_ARGSREADY (debug);
- env = SCM_EXTEND_ENV (formals,
- debug.info->a.args,
- SCM_ENV (proc));
- x = SCM_CLOSURE_BODY (proc);
- goto nontoplevel_begin;
- }
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- goto operatorn;
- else
- goto badfun;
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- scm_wrong_num_args (proc);
- default:
- goto badfun;
- }
- }
- }
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-}
-
-
-
+static SCM f_apply;
/* Apply a function to a list of arguments.
@@ -4768,271 +1120,19 @@ exit:
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-
- SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
- /* If ARGS is the empty list, then we're calling apply with only two
- arguments --- ARG1 is the list of arguments for PROC. Whatever
- the case, futz with things so that ARG1 is the first argument to
- give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
- rest.
-
- Setting the debug apply frame args this way is pretty messy.
- Perhaps we should store arg1 and args directly in the frame as
- received, and let scm_frame_arguments unpack them, because that's
- a relatively rare operation. This works for now; if the Guile
- developer archives are still around, see Mikael's post of
- 11-Apr-97. */
+ /* Fix things up so that args contains all args. */
if (scm_is_null (args))
- {
- if (scm_is_null (arg1))
- {
- arg1 = SCM_UNDEFINED;
- debug.vect[0].a.args = SCM_EOL;
- }
- else
- {
- debug.vect[0].a.args = arg1;
- args = SCM_CDR (arg1);
- arg1 = SCM_CAR (arg1);
- }
- }
+ args = arg1;
else
- {
- args = scm_nconc2last (args);
- debug.vect[0].a.args = scm_cons (arg1, args);
- }
- if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
- {
- SCM tmp = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
- SCM_TRAPS_P = 1;
- }
- ENTER_APPLY;
-tail:
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_2o:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- if (scm_is_null (args))
- args = SCM_UNDEFINED;
- else
- {
- if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- }
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_2:
- if (SCM_UNLIKELY (scm_is_null (args) ||
- !scm_is_null (SCM_CDR (args))))
- scm_wrong_num_args (proc);
- args = SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args));
- case scm_tc7_subr_0:
- if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) ());
- case scm_tc7_subr_1:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
- scm_wrong_num_args (proc);
- case scm_tc7_subr_1o:
- if (SCM_UNLIKELY (!scm_is_null (args)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1));
- case scm_tc7_dsubr:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
- scm_wrong_num_args (proc);
- if (SCM_I_INUMP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
- case scm_tc7_cxr:
- if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
- scm_wrong_num_args (proc);
- RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
- case scm_tc7_subr_3:
- if (SCM_UNLIKELY (scm_is_null (args)
- || scm_is_null (SCM_CDR (args))
- || !scm_is_null (SCM_CDDR (args))))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
- case scm_tc7_lsubr_2:
- if (SCM_UNLIKELY (!scm_is_pair (args)))
- scm_wrong_num_args (proc);
- else
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_asubr:
- if (scm_is_null (args))
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
- 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);
- while (SCM_NIMP (args))
- {
- SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
- if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
- RETURN (SCM_BOOL_F);
- arg1 = SCM_CAR (args);
- args = SCM_CDR (args);
- }
- RETURN (SCM_BOOL_T);
- case scm_tcs_closures:
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
- if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
- scm_wrong_num_args (proc);
-
- /* Copy argument list */
- if (SCM_IMP (arg1))
- args = arg1;
- else
- {
- SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
- for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
- {
- SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
- tl = SCM_CDR (tl);
- }
- SCM_SETCDR (tl, arg1);
- }
-
- args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- args,
- SCM_ENV (proc));
- proc = SCM_CLOSURE_BODY (proc);
- again:
- arg1 = SCM_CDR (proc);
- while (!scm_is_null (arg1))
- {
- if (SCM_IMP (SCM_CAR (proc)))
- {
- if (SCM_ISYMP (SCM_CAR (proc)))
- {
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (proc)))
- m_expand_body (proc, args);
- scm_dynwind_end ();
- goto again;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
- }
- else
- (void) EVAL (SCM_CAR (proc), args);
- proc = arg1;
- arg1 = SCM_CDR (proc);
- }
- RETURN (EVALCAR (proc, args));
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badproc;
- if (SCM_UNBNDP (arg1))
- RETURN (SCM_SMOB_APPLY_0 (proc));
- else if (scm_is_null (args))
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
- else if (scm_is_null (SCM_CDR (args)))
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
- else
- RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
- case scm_tc7_gsubr:
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = args;
- RETURN (scm_i_gsubr_apply_list (proc, args));
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- debug.vect[0].a.proc = proc;
- goto tail;
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- proc = SCM_STRUCT_PROCEDURE (proc);
- debug.vect[0].a.proc = proc;
- if (SCM_NIMP (proc))
- goto tail;
- else
- goto badproc;
- }
- else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
- RETURN (scm_apply_generic (proc, args));
- }
- else
- goto badproc;
- default:
- badproc:
- scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- }
-exit:
- if (scm_check_exit_p && SCM_TRAPS_P)
- if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
- {
- SCM_CLEAR_TRACED_FRAME (debug);
- arg1 = scm_make_debugobj (&debug);
- SCM_TRAPS_P = 0;
- arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
- SCM_TRAPS_P = 1;
- if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
- proc = SCM_CDR (arg1);
- }
- scm_i_set_last_debug_frame (debug.prev);
- return proc;
-}
+ args = scm_cons_star (arg1, args);
-#undef RETURN
-#undef ENTER_APPLY
-#undef PREP_APPLY
+ return apply (proc, args);
+}
void
scm_init_eval ()
{
- scm_i_pthread_mutex_init (&source_mutex,
- scm_i_pthread_mutexattr_recursive);
-
scm_init_opts (scm_evaluator_traps,
scm_evaluator_trap_table);
scm_init_opts (scm_eval_options_interface,
@@ -5041,10 +1141,6 @@ scm_init_eval ()
scm_tc16_promise = scm_make_smob_type ("promise", 0);
scm_set_smob_print (scm_tc16_promise, promise_print);
- undefineds = scm_list_1 (SCM_UNDEFINED);
- SCM_SETCDR (undefineds, undefineds);
- scm_permanent_object (undefineds);
-
scm_listofnull = scm_list_1 (SCM_EOL);
f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
diff --git a/libguile/eval.h b/libguile/eval.h
index 0e990cf26..fbb5bf512 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -27,6 +27,7 @@
#include "libguile/__scm.h"
#include "libguile/struct.h"
+#include "libguile/memoize.h"
@@ -79,42 +80,6 @@ typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM arg2);
-SCM_API SCM scm_sym_and;
-SCM_API SCM scm_sym_begin;
-SCM_API SCM scm_sym_case;
-SCM_API SCM scm_sym_cond;
-SCM_API SCM scm_sym_define;
-SCM_API SCM scm_sym_do;
-SCM_API SCM scm_sym_if;
-SCM_API SCM scm_sym_lambda;
-SCM_API SCM scm_sym_let;
-SCM_API SCM scm_sym_letstar;
-SCM_API SCM scm_sym_letrec;
-SCM_API SCM scm_sym_quote;
-SCM_API SCM scm_sym_quasiquote;
-SCM_API SCM scm_sym_unquote;
-SCM_API SCM scm_sym_uq_splicing;
-
-SCM_API SCM scm_sym_at;
-SCM_API SCM scm_sym_atat;
-SCM_API SCM scm_sym_atapply;
-SCM_API SCM scm_sym_atcall_cc;
-SCM_API SCM scm_sym_at_call_with_values;
-SCM_API SCM scm_sym_delay;
-SCM_API SCM scm_sym_eval_when;
-SCM_API SCM scm_sym_arrow;
-SCM_API SCM scm_sym_else;
-SCM_API SCM scm_sym_apply;
-SCM_API SCM scm_sym_set_x;
-SCM_API SCM scm_sym_args;
-
-
-
-SCM_API SCM * scm_ilookup (SCM iloc, SCM env);
-SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
-SCM_API SCM scm_eval_car (SCM pair, SCM env);
-SCM_API SCM scm_eval_body (SCM code, SCM env);
-SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
@@ -126,42 +91,23 @@ SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
-SCM_API scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
-SCM_API scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
-SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
-SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
+#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_closure (SCM code, SCM env);
SCM_API SCM scm_make_promise (SCM thunk);
SCM_API SCM scm_force (SCM x);
SCM_API SCM scm_promise_p (SCM x);
-SCM_API SCM scm_i_eval_x (SCM exp, SCM env) /* not internal */;
-SCM_INTERNAL SCM scm_i_eval (SCM exp, SCM env);
SCM_API SCM scm_primitive_eval (SCM exp);
-SCM_API SCM scm_primitive_eval_x (SCM exp);
+#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
-SCM_API SCM scm_eval_x (SCM exp, SCM module);
+#define scm_eval_x(exp, module) scm_eval (exp, module)
-SCM_INTERNAL void scm_i_print_iloc (SCM /*iloc*/, SCM /*port*/);
-SCM_INTERNAL void scm_i_print_isym (SCM /*isym*/, SCM /*port*/);
-SCM_INTERNAL SCM scm_i_unmemocopy_expr (SCM expr, SCM env);
-SCM_INTERNAL SCM scm_i_unmemocopy_body (SCM forms, SCM env);
SCM_INTERNAL void scm_init_eval (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM_DEPRECATED SCM scm_ceval (SCM x, SCM env);
-SCM_DEPRECATED SCM scm_deval (SCM x, SCM env);
-SCM_DEPRECATED SCM (*scm_ceval_ptr) (SCM x, SCM env);
-
-#endif
-
-
#endif /* SCM_EVAL_H */
/*
diff --git a/libguile/init.c b/libguile/init.c
index d6d9e9057..6c13a88ec 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -79,6 +79,7 @@
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
+#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
@@ -548,6 +549,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_weaks ();
scm_init_guardians ();
scm_init_vports ();
+ scm_init_memoize ();
scm_init_eval ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
diff --git a/libguile/memoize.c b/libguile/memoize.c
new file mode 100644
index 000000000..d37a72374
--- /dev/null
+++ b/libguile/memoize.c
@@ -0,0 +1,1141 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include "libguile/__scm.h"
+
+#include <assert.h>
+#include "libguile/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/memoize.h"
+#include "libguile/modules.h"
+#include "libguile/srcprop.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+
+
+
+
+
+#if 0
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#define CADDDR(x) SCM_CDDDR(x)
+#else
+#define CAR(x) scm_car(x)
+#define CDR(x) scm_cdr(x)
+#define CAAR(x) scm_caar(x)
+#define CADR(x) scm_cadr(x)
+#define CDAR(x) scm_cdar(x)
+#define CDDR(x) scm_cddr(x)
+#define CADDR(x) scm_caddr(x)
+#define CDDDR(x) scm_cdddr(x)
+#define CADDDR(x) scm_cadddr(x)
+#endif
+
+
+static const char s_bad_expression[] = "Bad expression";
+static const char s_expression[] = "Missing or extra expression in";
+static const char s_missing_expression[] = "Missing expression in";
+static const char s_extra_expression[] = "Extra expression in";
+static const char s_empty_combination[] = "Illegal empty combination";
+static const char s_missing_body_expression[] = "Missing body expression in";
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+static const char s_bad_define[] = "Bad define placement";
+static const char s_missing_clauses[] = "Missing clauses";
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+static const char s_bad_case_clause[] = "Bad case clause";
+static const char s_bad_case_labels[] = "Bad case labels";
+static const char s_duplicate_case_label[] = "Duplicate case label";
+static const char s_bad_cond_clause[] = "Bad cond clause";
+static const char s_missing_recipient[] = "Missing recipient in";
+static const char s_bad_variable[] = "Bad variable";
+static const char s_bad_bindings[] = "Bad bindings";
+static const char s_bad_binding[] = "Bad binding";
+static const char s_duplicate_binding[] = "Duplicate binding";
+static const char s_bad_exit_clause[] = "Bad exit clause";
+static const char s_bad_formals[] = "Bad formals";
+static const char s_bad_formal[] = "Bad formal";
+static const char s_duplicate_formal[] = "Duplicate formal";
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+static const char s_bad_slot_number[] = "Bad slot number";
+
+
+/* Signal a syntax error. We distinguish between the form that caused the
+ * error and the enclosing expression. The error message will print out as
+ * shown in the following pattern. The file name and line number are only
+ * given when they can be determined from the erroneous form or from the
+ * enclosing expression.
+ *
+ * <filename>: In procedure memoization:
+ * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* The prototype is needed to indicate that the function does not return. */
+static void
+syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+static void
+syntax_error (const char* const msg, const SCM form, const SCM expr)
+{
+ SCM msg_string = scm_from_locale_string (msg);
+ SCM filename = SCM_BOOL_F;
+ SCM linenr = SCM_BOOL_F;
+ const char *format;
+ SCM args;
+
+ if (scm_is_pair (form))
+ {
+ filename = scm_source_property (form, scm_sym_filename);
+ linenr = scm_source_property (form, scm_sym_line);
+ }
+
+ if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
+ {
+ filename = scm_source_property (expr, scm_sym_filename);
+ linenr = scm_source_property (expr, scm_sym_line);
+ }
+
+ if (!SCM_UNBNDP (expr))
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S in expression ~S.";
+ args = scm_list_5 (filename, linenr, msg_string, form, expr);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S in expression ~S.";
+ args = scm_list_4 (linenr, msg_string, form, expr);
+ }
+ else
+ {
+ format = "~A ~S in expression ~S.";
+ args = scm_list_3 (msg_string, form, expr);
+ }
+ }
+ else
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S.";
+ args = scm_list_4 (filename, linenr, msg_string, form);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S.";
+ args = scm_list_3 (linenr, msg_string, form);
+ }
+ else
+ {
+ format = "~A ~S.";
+ args = scm_list_2 (msg_string, form);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
+
+
+
+
+/* {Evaluator memoized expressions}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
+
+#define MAKMEMO_BEGIN(exps) \
+ MAKMEMO (SCM_M_BEGIN, exps)
+#define MAKMEMO_IF(test, then, else_) \
+ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
+#define MAKMEMO_LAMBDA(nreq, rest, body) \
+ MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
+#define MAKMEMO_LET(inits, body) \
+ MAKMEMO (SCM_M_LET, scm_cons (inits, body))
+#define MAKMEMO_QUOTE(exp) \
+ MAKMEMO (SCM_M_QUOTE, exp)
+#define MAKMEMO_DEFINE(var, val) \
+ MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_APPLY(exp) \
+ MAKMEMO (SCM_M_APPLY, exp)
+#define MAKMEMO_CONT(proc) \
+ MAKMEMO (SCM_M_CONT, proc)
+#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
+ MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
+#define MAKMEMO_CALL(proc, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
+#define MAKMEMO_LEX_REF(n) \
+ MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
+#define MAKMEMO_LEX_SET(n, val) \
+ MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
+#define MAKMEMO_TOP_REF(var) \
+ MAKMEMO (SCM_M_TOPLEVEL_REF, var)
+#define MAKMEMO_TOP_SET(var, val) \
+ MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
+#define MAKMEMO_MOD_REF(mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
+#define MAKMEMO_MOD_SET(val, mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
+
+
+
+/* This table must agree with the list of M_ constants in memoize.h */
+static const char *const memoized_tags[] =
+{
+ "begin",
+ "if",
+ "lambda",
+ "let",
+ "quote",
+ "define",
+ "apply",
+ "call-with-current-continuation",
+ "call-with-values",
+ "call",
+ "lexical-ref",
+ "lexical-set!",
+ "toplevel-ref",
+ "toplevel-set!",
+ "module-ref",
+ "module-set",
+};
+
+static int
+scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<memoized ", port);
+ scm_write (scm_unmemoize_expression (memoized), port);
+ scm_puts (">", port);
+ return 1;
+}
+
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_eval_when (SCM xorig, SCM env);
+static SCM scm_m_if (SCM xorig, SCM env);
+static SCM scm_m_lambda (SCM xorig, SCM env);
+static SCM scm_m_let (SCM xorig, SCM env);
+static SCM scm_m_letrec (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+
+
+
+
+
+typedef SCM (*t_syntax_transformer) (SCM, SCM);
+
+static t_syntax_transformer
+memoize_env_ref_transformer (SCM env, SCM x)
+{
+ SCM var;
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return NULL; /* lexical */
+
+ var = scm_module_variable (env, x);
+ if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
+ && SCM_MACROP (scm_variable_ref (var)))
+ {
+ SCM mac = scm_variable_ref (var);
+ if (SCM_IMP (SCM_MACRO_CODE (mac))
+ || SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_subr_2)
+ syntax_error ("bad macro", x, SCM_UNDEFINED);
+ else
+ return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
+ }
+ else
+ return NULL; /* anything else */
+}
+
+static int
+memoize_env_var_is_free (SCM env, SCM x)
+{
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return 0; /* bound */
+ return 1; /* free */
+}
+
+static int
+memoize_env_lexical_index (SCM env, SCM x)
+{
+ int i = 0;
+ for (; scm_is_pair (env); env = CDR (env), i++)
+ if (scm_is_eq (x, CAR (env)))
+ return i; /* bound */
+ return -1; /* free */
+}
+
+static SCM
+memoize_env_extend (SCM env, SCM vars)
+{
+ return scm_append (scm_list_2 (vars, env));
+}
+
+static SCM
+memoize (SCM exp, SCM env)
+{
+ if (scm_is_pair (exp))
+ {
+ SCM CAR;
+ t_syntax_transformer trans;
+
+ CAR = CAR (exp);
+ if (scm_is_symbol (CAR))
+ trans = memoize_env_ref_transformer (env, CAR);
+ else
+ trans = NULL;
+
+ if (trans)
+ return trans (exp, env);
+ else
+ {
+ SCM args = SCM_EOL;
+ for (; scm_is_pair (exp); exp = CDR (exp))
+ args = scm_cons (memoize (CAR (exp), env), args);
+ if (scm_is_null (exp))
+ return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
+ else
+ syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+ }
+ }
+ else if (scm_is_symbol (exp))
+ {
+ int i = memoize_env_lexical_index (env, exp);
+ if (i < 0)
+ return MAKMEMO_TOP_REF (exp);
+ else
+ return MAKMEMO_LEX_REF (i);
+ }
+ else
+ return MAKMEMO_QUOTE (exp);
+}
+
+static SCM
+memoize_exprs (SCM forms, const SCM env)
+{
+ SCM ret = SCM_EOL;
+
+ for (; !scm_is_null (forms); forms = CDR (forms))
+ ret = scm_cons (memoize (CAR (forms), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+memoize_sequence (const SCM forms, const SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
+ scm_cons (scm_sym_begin, forms));
+ return MAKMEMO_BEGIN (memoize_exprs (forms, env));
+}
+
+
+
+/* Memoization. */
+
+/* bimacros (built-in macros) have isym codes.
+ mmacros don't exist at runtime, they just expand out to more primitive
+ forms. */
+SCM_SYNTAX (s_at, "@", scm_i_makbimacro, scm_m_at);
+SCM_SYNTAX (s_atat, "@@", scm_i_makbimacro, scm_m_atat);
+SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
+SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
+SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
+SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
+SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
+SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
+SCM_SYNTAX (s_let, "let", scm_i_makbimacro, scm_m_let);
+SCM_SYNTAX (s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
+SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x);
+SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
+SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
+SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
+SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
+SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
+SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
+SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
+SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
+SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
+SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
+SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
+SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
+SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
+SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+
+
+static SCM
+scm_m_at (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
+}
+
+static SCM
+scm_m_atat (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
+}
+
+static SCM
+scm_m_and (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+
+ if (scm_is_null (cdr_expr))
+ return MAKMEMO_QUOTE (SCM_BOOL_T);
+ ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
+
+ if (scm_is_null (CDR (cdr_expr)))
+ return memoize (CAR (cdr_expr), env);
+ else
+ return MAKMEMO_IF (memoize (CAR (cdr_expr), env),
+ scm_m_and (cdr_expr, env),
+ MAKMEMO_QUOTE (SCM_BOOL_F));
+}
+
+static SCM
+scm_m_apply (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
+
+ return MAKMEMO_APPLY (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_begin (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
+ return MAKMEMO_BEGIN (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_cont (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ return MAKMEMO_CONT (memoize (CADR (expr), env));
+}
+
+static SCM
+scm_m_at_call_with_values (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ return MAKMEMO_CALL_WITH_VALUES (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env));
+}
+
+static SCM
+scm_m_cond (SCM expr, SCM env)
+{
+ /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
+ const int else_literal_p = memoize_env_var_is_free (env, scm_sym_else);
+ const int arrow_literal_p = memoize_env_var_is_free (env, scm_sym_arrow);
+
+ const SCM clauses = CDR (expr);
+ SCM clause_idx;
+ SCM ret, loc;
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ loc = ret;
+
+ for (clause_idx = clauses;
+ !scm_is_null (clause_idx);
+ clause_idx = CDR (clause_idx))
+ {
+ SCM test;
+
+ const SCM clause = CAR (clause_idx);
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
+
+ test = CAR (clause);
+ if (scm_is_eq (test, scm_sym_else) && else_literal_p)
+ {
+ const int last_clause_p = scm_is_null (CDR (clause_idx));
+ ASSERT_SYNTAX_2 (length >= 2,
+ s_bad_cond_clause, clause, expr);
+ ASSERT_SYNTAX_2 (last_clause_p,
+ s_misplaced_else_clause, clause, expr);
+ SCM_SETCDR (loc,
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env));
+ }
+ else if (length >= 2
+ && scm_is_eq (CADR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM i;
+ SCM new_env = scm_cons (tmp, env);
+ ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
+ i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_CALL (memoize (CADDR (clause),
+ scm_cons (tmp, new_env)),
+ scm_list_1 (MAKMEMO_LEX_REF (0))),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc,
+ MAKMEMO_LET (scm_list_1 (memoize (CAR (clause), env)),
+ i));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ /* FIXME length == 1 case */
+ else
+ {
+ SCM i = MAKMEMO_IF (memoize (CAR (clause), env),
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, i);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ }
+
+ return CDR (ret);
+}
+
+/* According to Section 5.2.1 of R5RS we first have to make sure that the
+ variable is bound, and then perform the `(set! variable expression)'
+ operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
+ bound. This means that EXPRESSION won't necessarily be able to assign
+ values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
+static SCM
+scm_m_define (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ SCM body;
+ SCM variable;
+
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
+
+ body = CDR (cdr_expr);
+ variable = CAR (cdr_expr);
+
+ if (scm_is_pair (variable))
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
+ return MAKMEMO_DEFINE (CAR (variable),
+ memoize (scm_cons (scm_sym_lambda,
+ scm_cons (CDR (variable), body)),
+ env));
+ }
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
+ return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
+}
+
+static SCM
+scm_m_eval_when (SCM expr, SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
+ || scm_is_true (scm_memq (sym_load, CADR (expr))))
+ return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr), env));
+ else
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+}
+
+static SCM
+scm_m_if (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
+ return MAKMEMO_IF (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ ((length == 3)
+ ? memoize (CADDDR (expr), env)
+ : MAKMEMO_QUOTE (SCM_UNSPECIFIED)));
+}
+
+/* A helper function for memoize_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
+static int
+c_improper_memq (SCM obj, SCM list)
+{
+ for (; scm_is_pair (list); list = CDR (list))
+ {
+ if (scm_is_eq (CAR (list), obj))
+ return 1;
+ }
+ return scm_is_eq (list, obj);
+}
+
+static SCM
+scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM formals;
+ SCM formals_idx;
+ SCM formal_vars = SCM_EOL;
+ int nreq = 0;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = CAR (cdr_expr);
+ if (scm_is_pair (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
+ s_bad_formals, formals, expr);
+ }
+
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ formals_idx = formals;
+ while (scm_is_pair (formals_idx))
+ {
+ const SCM formal = CAR (formals_idx);
+ const SCM next_idx = CDR (formals_idx);
+ ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
+ s_duplicate_formal, formal, expr);
+ nreq++;
+ formal_vars = scm_cons (formal, formal_vars);
+ formals_idx = next_idx;
+ }
+ ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
+ s_bad_formal, formals_idx, expr);
+ if (scm_is_symbol (formals_idx))
+ formal_vars = scm_cons (formals_idx, formal_vars);
+ return MAKMEMO_LAMBDA (nreq, scm_symbol_p (formals_idx),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, formal_vars)));
+}
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
+
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ SCM name; /* const */
+
+ const SCM binding = CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ }
+}
+
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
+ * variable name is detected, an error is signalled. */
+static int
+transform_bindings (const SCM bindings, const SCM expr,
+ SCM *const rvarptr, SCM *const initptr)
+{
+ SCM rvariables = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ int n = 0;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ const SCM binding = CAR (binding_idx);
+ const SCM CDR_binding = CDR (binding);
+ const SCM name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
+ s_duplicate_binding, name, expr);
+ rvariables = scm_cons (name, rvariables);
+ rinits = scm_cons (CAR (CDR_binding), rinits);
+ n++;
+ }
+ *rvarptr = rvariables;
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
+ return n;
+}
+
+/* This function is a helper function for memoize_let. It transforms
+ * (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
+ * and memoizes the expression. It is assumed that the caller has checked
+ * that name is a symbol and that there are bindings and a body. */
+static SCM
+memoize_named_let (const SCM expr, SCM env)
+{
+ SCM rvariables;
+ SCM inits;
+ int nreq;
+
+ const SCM cdr_expr = CDR (expr);
+ const SCM name = CAR (cdr_expr);
+ const SCM cddr_expr = CDR (cdr_expr);
+ const SCM bindings = CAR (cddr_expr);
+ check_bindings (bindings, expr);
+
+ nreq = transform_bindings (bindings, expr, &rvariables, &inits);
+
+ env = scm_cons (name, env);
+ return MAKMEMO_LET
+ (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED)),
+ MAKMEMO_BEGIN
+ (scm_list_2 (MAKMEMO_LEX_SET
+ (0,
+ MAKMEMO_LAMBDA
+ (nreq, SCM_BOOL_F,
+ memoize_sequence (CDDDR (expr),
+ memoize_env_extend (env, rvariables)))),
+ MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
+ memoize_exprs (inits, env)))));
+}
+
+/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
+static SCM
+scm_m_let (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_symbol (bindings))
+ {
+ ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
+ return memoize_named_let (expr, env);
+ }
+
+ check_bindings (bindings, expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ return MAKMEMO_LET (memoize_exprs (inits, env),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, rvariables)));
+ }
+}
+
+static SCM
+scm_m_letrec (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM v, i;
+ SCM undefs = SCM_EOL;
+ SCM vals = SCM_EOL;
+ SCM sets = SCM_EOL;
+ SCM new_env;
+ int offset;
+ int n = transform_bindings (bindings, expr, &rvariables, &inits);
+ offset = n;
+ new_env = memoize_env_extend (env, rvariables);
+ for (v = scm_reverse (rvariables), i = inits; scm_is_pair (v);
+ v = CDR (v), i = CDR (i), n--)
+ {
+ undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
+ vals = scm_cons (memoize (CAR (i), new_env), vals);
+ sets = scm_cons (MAKMEMO_LEX_SET ((n-1) + offset,
+ MAKMEMO_LEX_REF (n-1)),
+ sets);
+ }
+ return MAKMEMO_LET
+ (undefs,
+ MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals),
+ MAKMEMO_BEGIN (sets)),
+ memoize_sequence (CDDR (expr),
+ new_env))));
+ }
+}
+
+static SCM
+scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM variables;
+ SCM inits;
+ SCM ret, loc;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ variables = scm_reverse (rvariables);
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (variables);
+ variables = CDR (variables), inits = CDR (inits))
+ { SCM x = MAKMEMO_LET (scm_list_1 (memoize (CAR (inits), env)),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, x);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ env = scm_cons (CAR (variables), env);
+ }
+ SCM_SETCDR (loc, memoize_sequence (CDDR (expr), env));
+ return CDR (ret);
+ }
+}
+
+static SCM
+scm_m_or (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM tail = CDR (expr);
+ SCM ret, loc;
+ const long length = scm_ilength (tail);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (tail); tail = CDR (tail))
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM x = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_LEX_REF (0),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM new_env = scm_cons (tmp, env);
+ SCM_SETCDR (loc, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail),
+ env)),
+ x));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ }
+ SCM_SETCDR (loc, MAKMEMO_QUOTE (SCM_BOOL_F));
+ return CDR (ret);
+}
+
+static SCM
+scm_m_quote (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM quotee;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ quotee = CAR (cdr_expr);
+ return MAKMEMO_QUOTE (quotee);
+}
+
+static SCM
+scm_m_set_x (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM vmem;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = CAR (cdr_expr);
+ vmem = memoize (variable, env);
+
+ switch (SCM_MEMOIZED_TAG (vmem))
+ {
+ case SCM_M_LEXICAL_REF:
+ return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem)),
+ memoize (CADDR (expr), env));
+ case SCM_M_TOPLEVEL_REF:
+ return MAKMEMO_TOP_SET (variable,
+ memoize (CADDR (expr), env));
+ case SCM_M_MODULE_REF:
+ return MAKMEMO_MOD_SET (memoize (CADDR (expr), env),
+ CAR (SCM_MEMOIZED_ARGS (vmem)),
+ CADR (SCM_MEMOIZED_ARGS (vmem)),
+ CDDR (SCM_MEMOIZED_ARGS (vmem)));
+ default:
+ syntax_error (s_bad_variable, variable, expr);
+ }
+}
+
+
+
+
+SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
+ (SCM exp),
+ "Memoize the expression @var{exp}.")
+#define FUNC_NAME s_scm_memoize_expression
+{
+ return memoize (exp, scm_current_module ());
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_SYMBOL (sym_placeholder, "_");
+
+static SCM unmemoize (SCM expr);
+
+static SCM
+unmemoize_exprs (SCM exprs)
+{
+ SCM ret, tail;
+ if (scm_is_null (exprs))
+ return SCM_EOL;
+ ret = scm_list_1 (unmemoize (CAR (exprs)));
+ tail = ret;
+ for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
+ {
+ SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_bindings (SCM inits)
+{
+ SCM ret, tail;
+ if (scm_is_null (inits))
+ return SCM_EOL;
+ ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
+ tail = ret;
+ for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
+ {
+ SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
+ unmemoize (CAR (inits)))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_lexical (SCM n)
+{
+ char buf[16];
+ buf[15] = 0;
+ snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
+ return scm_from_locale_symbol (buf);
+}
+
+static SCM
+unmemoize (const SCM expr)
+{
+ SCM args;
+
+ if (!SCM_MEMOIZED_P (expr))
+ abort ();
+
+ args = SCM_MEMOIZED_ARGS (expr);
+ switch (SCM_MEMOIZED_TAG (expr))
+ {
+ case SCM_M_APPLY:
+ return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
+ case SCM_M_BEGIN:
+ return scm_cons (scm_sym_begin, unmemoize_exprs (args));
+ case SCM_M_CALL:
+ return unmemoize_exprs (args);
+ case SCM_M_CONT:
+ return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
+ case SCM_M_CALL_WITH_VALUES:
+ return scm_list_3 (scm_sym_at_call_with_values,
+ unmemoize (CAR (args)), unmemoize (CDR (args)));
+ case SCM_M_DEFINE:
+ return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_IF:
+ return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
+ unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
+ case SCM_M_LAMBDA:
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (args), sym_placeholder),
+ unmemoize (CDDR (args)));
+ case SCM_M_LET:
+ return scm_list_3 (scm_sym_let,
+ unmemoize_bindings (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_QUOTE:
+ return scm_list_2 (scm_sym_quote, args);
+ case SCM_M_LEXICAL_REF:
+ return unmemoize_lexical (args);
+ case SCM_M_LEXICAL_SET:
+ return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_TOPLEVEL_REF:
+ return args;
+ case SCM_M_TOPLEVEL_SET:
+ return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_MODULE_REF:
+ return scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CAR (args)),
+ CADR (args));
+ case SCM_M_MODULE_SET:
+ return scm_list_3 (scm_sym_set_x,
+ scm_list_3 (scm_is_true (CDDDR (args))
+ ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args)),
+ unmemoize (CAR (args)));
+ default:
+ abort ();
+ }
+}
+
+SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is memoized.")
+#define FUNC_NAME s_scm_memoized_p
+{
+ return scm_from_bool (SCM_MEMOIZED_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
+ (SCM m),
+ "Unmemoize the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_unmemoize_expression
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return unmemoize (m);
+}
+#undef FUNC_NAME
+
+
+
+
+void
+scm_init_memoize ()
+{
+ scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
+ scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
+ scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
+
+#include "libguile/memoize.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/memoize.h b/libguile/memoize.h
new file mode 100644
index 000000000..5a96ef6bf
--- /dev/null
+++ b/libguile/memoize.h
@@ -0,0 +1,106 @@
+/* classes: h_files */
+
+#ifndef SCM_MEMOIZE_H
+#define SCM_MEMOIZE_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+
+
+SCM_API SCM scm_sym_and;
+SCM_API SCM scm_sym_begin;
+SCM_API SCM scm_sym_case;
+SCM_API SCM scm_sym_cond;
+SCM_API SCM scm_sym_define;
+SCM_API SCM scm_sym_do;
+SCM_API SCM scm_sym_if;
+SCM_API SCM scm_sym_lambda;
+SCM_API SCM scm_sym_let;
+SCM_API SCM scm_sym_letstar;
+SCM_API SCM scm_sym_letrec;
+SCM_API SCM scm_sym_quote;
+SCM_API SCM scm_sym_quasiquote;
+SCM_API SCM scm_sym_unquote;
+SCM_API SCM scm_sym_uq_splicing;
+
+SCM_API SCM scm_sym_at;
+SCM_API SCM scm_sym_atat;
+SCM_API SCM scm_sym_atapply;
+SCM_API SCM scm_sym_atcall_cc;
+SCM_API SCM scm_sym_at_call_with_values;
+SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_eval_when;
+SCM_API SCM scm_sym_arrow;
+SCM_API SCM scm_sym_else;
+SCM_API SCM scm_sym_apply;
+SCM_API SCM scm_sym_set_x;
+SCM_API SCM scm_sym_args;
+
+/* {Memoized Source}
+ */
+
+SCM_INTERNAL scm_t_bits scm_tc16_memoized;
+
+#define SCM_MEMOIZED_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoized, (x)))
+#define SCM_MEMOIZED_TAG(x) (SCM_SMOB_FLAGS (x))
+#define SCM_MEMOIZED_ARGS(x) (SCM_SMOB_OBJECT (x))
+
+enum
+ {
+ SCM_M_BEGIN,
+ SCM_M_IF,
+ SCM_M_LAMBDA,
+ SCM_M_LET,
+ SCM_M_QUOTE,
+ SCM_M_DEFINE,
+ SCM_M_APPLY,
+ SCM_M_CONT,
+ SCM_M_CALL_WITH_VALUES,
+ SCM_M_CALL,
+ SCM_M_LEXICAL_REF,
+ SCM_M_LEXICAL_SET,
+ SCM_M_TOPLEVEL_REF,
+ SCM_M_TOPLEVEL_SET,
+ SCM_M_MODULE_REF,
+ SCM_M_MODULE_SET
+ };
+
+
+
+
+SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
+SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
+SCM_API SCM scm_memoized_p (SCM obj);
+
+SCM_INTERNAL void scm_init_memoize (void);
+
+
+#endif /* SCM_MEMOIZE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/modules.c b/libguile/modules.c
index db2ce73f8..f0576e924 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -229,28 +229,6 @@ scm_c_export (const char *name, ...)
/* Environments */
-SCM
-scm_top_level_env (SCM thunk)
-{
- if (SCM_IMP (thunk))
- return SCM_EOL;
- else
- return scm_cons (thunk, SCM_EOL);
-}
-
-SCM
-scm_env_top_level (SCM env)
-{
- while (scm_is_pair (env))
- {
- SCM car_env = SCM_CAR (env);
- if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
- return car_env;
- env = SCM_CDR (env);
- }
- return SCM_BOOL_F;
-}
-
SCM_SYMBOL (sym_module, "module");
SCM
@@ -275,15 +253,6 @@ scm_lookup_closure_module (SCM proc)
}
}
-SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
- (SCM env),
- "Return the module of @var{ENV}, a lexical environment.")
-#define FUNC_NAME s_scm_env_module
-{
- return scm_lookup_closure_module (scm_env_top_level (env));
-}
-#undef FUNC_NAME
-
/*
* C level implementation of the standard eval closure
*
@@ -878,18 +847,6 @@ SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
SCM_SYMBOL (scm_sym_system_module, "system-module");
-SCM
-scm_system_module_env_p (SCM env)
-{
- SCM proc = scm_env_top_level (env);
- if (scm_is_false (proc))
- return SCM_BOOL_T;
- return ((scm_is_true (scm_procedure_property (proc,
- scm_sym_system_module)))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
void
scm_modules_prehistory ()
{
diff --git a/libguile/modules.h b/libguile/modules.h
index 3ff8c98e6..aef7d3beb 100644
--- a/libguile/modules.h
+++ b/libguile/modules.h
@@ -115,11 +115,6 @@ SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);
-SCM_API SCM scm_env_top_level (SCM env);
-SCM_API SCM scm_env_module (SCM env);
-SCM_API SCM scm_top_level_env (SCM thunk);
-SCM_API SCM scm_system_module_env_p (SCM env);
-
SCM_INTERNAL void scm_modules_prehistory (void);
SCM_INTERNAL void scm_init_modules (void);
diff --git a/libguile/print.c b/libguile/print.c
index fd984d3e8..3069edcb7 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -523,14 +523,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
}
- else if (SCM_ISYMP (exp))
- {
- scm_i_print_isym (exp, port);
- }
- else if (SCM_ILOCP (exp))
- {
- scm_i_print_iloc (exp, port);
- }
else
{
/* unknown immediate value */
@@ -574,22 +566,14 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
exp, port, pstate)))
{
- SCM formals = SCM_CLOSURE_FORMALS (exp);
scm_puts ("#<procedure", port);
scm_putc (' ', port);
scm_iprin1 (scm_procedure_name (exp), port, pstate);
scm_putc (' ', port);
- if (SCM_PRINT_SOURCE_P)
- {
- SCM env = SCM_ENV (exp);
- SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
- SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
- ENTER_NESTED_DATA (pstate, exp, circref);
- scm_iprin1 (src, port, pstate);
- EXIT_NESTED_DATA (pstate);
- }
- else
- scm_iprin1 (formals, port, pstate);
+ scm_iprin1
+ (scm_cons (SCM_I_MAKINUM (SCM_CLOSURE_NUM_REQUIRED_ARGS (exp)),
+ scm_from_bool (SCM_CLOSURE_HAS_REST_ARGS (exp))),
+ port, pstate);
scm_putc ('>', port);
}
break;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index c1a37895b..cce800f2b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -109,16 +109,8 @@ scm_i_procedure_arity (SCM proc)
proc = SCM_PROCEDURE (proc);
goto loop;
case scm_tcs_closures:
- proc = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (proc))
- break;
- while (scm_is_pair (proc))
- {
- ++a;
- proc = SCM_CDR (proc);
- }
- if (!scm_is_null (proc))
- r = 1;
+ a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0;
break;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
diff --git a/libguile/procs.c b/libguile/procs.c
index dc4375554..898a3710b 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -134,7 +134,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_closures:
- return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
+ return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
case scm_tc7_subr_0:
case scm_tc7_subr_1o:
case scm_tc7_lsubr:
diff --git a/libguile/procs.h b/libguile/procs.h
index 7e445ad11..dc764edf8 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -86,8 +86,9 @@
#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
-#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
-#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
+#define SCM_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (SCM_CAR (SCM_CODE (x)))
+#define SCM_CLOSURE_HAS_REST_ARGS(x) scm_is_true (SCM_CADR (SCM_CODE (x)))
+#define SCM_CLOSURE_BODY(x) SCM_CDDR (SCM_CODE (x))
#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index a7a655598..110386465 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -180,10 +180,6 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
@@ -217,10 +213,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
{
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (!SRCPROPSP (p))
goto alist;
@@ -248,10 +240,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_whash_handle h;
SCM p;
SCM_VALIDATE_NIM (1, obj);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
- else if (!scm_is_pair (obj))
- SCM_WRONG_TYPE_ARG (1, obj);
h = scm_whash_get_handle (scm_source_whash, obj);
if (SCM_WHASHFOUNDP (h))
p = SCM_WHASHREF (scm_source_whash, h);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index a70186371..79fe2bda6 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -212,7 +212,6 @@ read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
flags |= SCM_FRAMEF_EVAL_ARGS;
}
}
- iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
}
else
{
@@ -239,16 +238,6 @@ get_applybody ()
#define NEXT_FRAME(iframe, n, quit) \
do { \
- if (SCM_MEMOIZEDP (iframe->source) \
- && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
- { \
- iframe->source = SCM_BOOL_F; \
- if (scm_is_false (iframe->proc)) \
- { \
- --iframe; \
- ++n; \
- } \
- } \
++iframe; \
if (--n == 0) \
goto quit; \
@@ -316,8 +305,7 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
}
else
iframe->flags = SCM_UNPACK (SCM_INUM0);
- iframe->source = scm_make_memoized (info[0].e.exp,
- info[0].e.env);
+ iframe->source = SCM_BOOL_F;
info -= 2;
NEXT_FRAME (iframe, n, quit);
}
@@ -395,31 +383,7 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
/* Cut all frames up to user module code */
for (i = 0; inner; ++i, --inner)
- {
- SCM m = s->frames[i].source;
- if (SCM_MEMOIZEDP (m)
- && !SCM_IMP (SCM_MEMOIZED_ENV (m))
- && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
- {
- /* Back up in order to include any non-source frames */
- while (i > 0)
- {
- m = s->frames[i - 1].source;
- if (SCM_MEMOIZEDP (m))
- break;
-
- m = s->frames[i - 1].proc;
- if (scm_is_true (scm_procedure_p (m))
- && scm_is_true (scm_procedure_property
- (m, scm_sym_system_procedure)))
- break;
-
- --i;
- ++inner;
- }
- break;
- }
- }
+ ;
}
else
/* Use standard cutting procedure. */
diff --git a/libguile/tags.h b/libguile/tags.h
index 210a82b73..92d0bb800 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -307,8 +307,8 @@ typedef scm_t_uintptr scm_t_bits;
* tc8 (for objects with tc3==100):
* 00000-100: special objects ('flags')
* 00001-100: characters
- * 00010-100: evaluator byte codes ('isyms')
- * 00011-100: evaluator byte codes ('ilocs')
+ * 00010-100: unused
+ * 00011-100: unused
*
*
* Summary of type codes on the heap
@@ -464,8 +464,8 @@ enum scm_tc8_tags
{
scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
- scm_tc8_isym = scm_tc3_imm24 + 0x10, /* evaluator byte codes ('isyms') */
- scm_tc8_iloc = scm_tc3_imm24 + 0x18 /* evaluator byte codes ('ilocs') */
+ scm_tc8_unused_0 = scm_tc3_imm24 + 0x10,
+ scm_tc8_unused_1 = scm_tc3_imm24 + 0x18
};
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
@@ -586,42 +586,6 @@ enum scm_tc8_tags
#endif /* BUILDING_LIBGUILE */
-/* Evaluator byte codes ('immediate symbols'). These constants are used only
- * in eval but their values have to be allocated here. The indices of the
- * SCM_IM_ symbols must agree with the declarations in eval.c:
- * scm_isymnames. */
-
-#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
-#define SCM_MAKISYM(n) SCM_MAKE_ITAG8 ((n), scm_tc8_isym)
-
-#define SCM_IM_AND SCM_MAKISYM (0)
-#define SCM_IM_BEGIN SCM_MAKISYM (1)
-#define SCM_IM_CASE SCM_MAKISYM (2)
-#define SCM_IM_COND SCM_MAKISYM (3)
-#define SCM_IM_DO SCM_MAKISYM (4)
-#define SCM_IM_IF SCM_MAKISYM (5)
-#define SCM_IM_LAMBDA SCM_MAKISYM (6)
-#define SCM_IM_LET SCM_MAKISYM (7)
-#define SCM_IM_LETSTAR SCM_MAKISYM (8)
-#define SCM_IM_LETREC SCM_MAKISYM (9)
-#define SCM_IM_OR SCM_MAKISYM (10)
-#define SCM_IM_QUOTE SCM_MAKISYM (11)
-#define SCM_IM_SET_X SCM_MAKISYM (12)
-#define SCM_IM_DEFINE SCM_MAKISYM (13)
-#define SCM_IM_APPLY SCM_MAKISYM (14)
-#define SCM_IM_CONT SCM_MAKISYM (15)
-#define SCM_IM_DISPATCH SCM_MAKISYM (16)
-#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
-#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
-#define SCM_IM_DELAY SCM_MAKISYM (19)
-#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (20)
-#define SCM_IM_ELSE SCM_MAKISYM (21)
-#define SCM_IM_ARROW SCM_MAKISYM (22)
-#define SCM_IM_NIL_COND SCM_MAKISYM (23) /* Multi-language support */
-#define SCM_IM_BIND SCM_MAKISYM (24) /* Multi-language support */
-
-
-
/* Dispatching aids:
When switching on SCM_TYP7 of a SCM value, use these fake case
diff --git a/libguile/validate.h b/libguile/validate.h
index ec32aa6c2..be4ed484b 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -294,7 +294,7 @@
#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
-#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZEDP, "memoized code")
+#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code")
#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, CLOSUREP, "closure")
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index ed7a4c864..c271ffe9c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -68,6 +68,7 @@
(define pk peek)
+
(define (warn . stuff)
(with-output-to-port (current-error-port)
(lambda ()
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index c55e13b28..a48edb7ef 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -202,3 +202,8 @@
x)))
(else
(error "#y needs to be followed by a list" x))))))
+
+(define (unmemoize-expr . args)
+ (issue-deprecation-warning
+ "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
+ (apply unmemoize-expression args))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7ebc3821e..62699672a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -11741,8 +11741,7 @@
#{x\ 4298}#))))
(define do
- (make-extended-syncase-macro
- (module-ref (current-module) (quote do))
+ (make-syncase-macro
'macro
(lambda (#{orig-x\ 4321}#)
((lambda (#{tmp\ 4322}#)
@@ -12351,8 +12350,7 @@
#{orig-x\ 4321}#))))
(define quasiquote
- (make-extended-syncase-macro
- (module-ref (current-module) (quote quasiquote))
+ (make-syncase-macro
'macro
(letrec ((#{quasicons\ 4358}#
(lambda (#{x\ 4362}# #{y\ 4363}#)
@@ -13506,8 +13504,7 @@
#{x\ 4458}#))))
(define case
- (make-extended-syncase-macro
- (module-ref (current-module) (quote case))
+ (make-syncase-macro
'macro
(lambda (#{x\ 4463}#)
((lambda (#{tmp\ 4464}#)
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index 7dc719ce7..67e72a6f1 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -36,7 +36,7 @@
;; The following test makes sure that the evaluator distinguishes between
;; evaluator-internal instruction codes and characters.
(pass-if-exception "evaluating chars"
- exception:wrong-type-to-apply
+ exception:wrong-type-arg
(eval '(#\0) (interaction-environment))))
(with-test-prefix "comparisons"
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 074b9b136..c253b2d09 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -228,10 +228,10 @@
(with-test-prefix "define set procedure-name"
- (pass-if "closure"
+ (expect-fail "closure"
(eq? 'foo-closure (procedure-name bar-closure)))
- (pass-if "procedure-with-setter"
+ (expect-fail "procedure-with-setter"
(eq? 'foo-pws (procedure-name bar-pws))))
(if old-procnames-flag
@@ -343,6 +343,7 @@
;; The subr involving the error must appear exactly once on the stack.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@@ -367,6 +368,7 @@
;; application.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
@@ -389,6 +391,7 @@
;; correct.
(catch 'result
(lambda ()
+ (throw 'unresolved)
(start-stack 'foo
(lazy-catch 'wrong-type-arg
(lambda ()
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index ec5528070..927e50ad5 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -129,30 +129,6 @@
(pass-if "legal (begin)"
(eval '(begin (begin) #t) (interaction-environment)))
- (with-test-prefix "unmemoization"
-
- ;; FIXME. I have no idea why, but the expander is filling in (if #f
- ;; #f) as the second arm of the if, if the second arm is missing. I
- ;; thought I made it not do that. But in the meantime, let's adapt,
- ;; since that's not what we're testing.
-
- (pass-if "normal begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
-
- (pass-if "redundant nested begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))))
-
- (pass-if "redundant begin at start of body"
- (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (begin (+ 1) (+ 2)))))))
-
(pass-if-exception "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
@@ -170,18 +146,6 @@
(with-test-prefix "lambda"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal lambda"
- (let ((foo (lambda () (lambda (x y) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) (+ _ _))))))
-
- (pass-if "lambda with documentation"
- (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (lambda (_ _) "docstring" (+ _ _)))))))
-
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
@@ -247,13 +211,6 @@
(with-test-prefix "let"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let"
- (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "late binding"
@@ -350,21 +307,6 @@
(with-test-prefix "let*"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal let*"
- (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
-
- (pass-if "let* without bindings"
- (let ((foo (lambda () (let ((x 1) (y 2))
- (let* ()
- (and (= x 1) (= y 2)))))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ 1) (_ 2))
- (if (= _ 1) (= _ 2) #f)))))))
-
(with-test-prefix "bindings"
(pass-if "(let* ((x 1) (x 2)) ...)"
@@ -441,13 +383,6 @@
(with-test-prefix "letrec"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal letrec"
- (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
- (matches? (procedure-source foo)
- (lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
-
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
@@ -523,28 +458,6 @@
(with-test-prefix "if"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal if"
- (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (if _ (+ 1) (+ 2))))))
-
- (expect-fail "if without else"
- (let ((foo (lambda (x) (if x (+ 1)))))
- (foo #t) ; make sure, memoization has been performed
- (foo #f) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (if x (+ 1))))))
-
- (expect-fail "if #f without else"
- (let ((foo (lambda () (if #f #f))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- `(lambda () (if #f #f))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
@@ -622,26 +535,6 @@
'(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
- (with-test-prefix "unmemoization"
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "normal clauses"
- (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
- (equal? (procedure-source foo)
- '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
-
- (pass-if "else"
- (let ((foo (lambda () (cond (else 'bar)))))
- (equal? (procedure-source foo)
- '(lambda () 'bar))))
-
- ;; FIXME: the (if #f #f) is a hack!
- (pass-if "=>"
- (let ((foo (lambda () (cond (#t => identity)))))
- (matches? (procedure-source foo)
- (lambda () (let ((_ #t))
- (if _ (identity _) (if #f #f))))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
@@ -707,28 +600,6 @@
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
- (with-test-prefix "unmemoization"
-
- (pass-if "normal clauses"
- (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '(2))
- 'baz
- 'foobar))))))
-
- (pass-if "empty labels"
- (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
- (matches? (procedure-source foo)
- (lambda (_)
- (if ((@@ (guile) memv) _ '(1))
- 'bar
- (if ((@@ (guile) memv) _ '())
- 'baz
- 'foobar)))))))
-
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
@@ -804,23 +675,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
- (with-test-prefix "unmemoization"
-
- (pass-if "definition unmemoized without prior execution"
- (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"
- (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)"
@@ -892,29 +746,10 @@
(pass-if-exception "missing body expression"
exception:missing-body-expr
(eval '(let () (define x #t))
- (interaction-environment)))
-
- (pass-if "unmemoization"
- (primitive-eval '(begin
- (define (foo)
- (define (bar)
- 'ok)
- (bar))
- (foo)
- (matches?
- (procedure-source foo)
- (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))))))
+ (interaction-environment))))
(with-test-prefix "set!"
- (with-test-prefix "unmemoization"
-
- (pass-if "normal set!"
- (let ((foo (lambda (x) (set! x (+ 1 x)))))
- (foo 1) ; make sure, memoization has been performed
- (matches? (procedure-source foo)
- (lambda (_) (set! _ (+ 1 _)))))))
-
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"