diff options
-rw-r--r-- | libguile/Makefile.am | 4 | ||||
-rw-r--r-- | libguile/debug.c | 310 | ||||
-rw-r--r-- | libguile/debug.h | 41 | ||||
-rw-r--r-- | libguile/eval.c | 4746 | ||||
-rw-r--r-- | libguile/eval.h | 62 | ||||
-rw-r--r-- | libguile/init.c | 2 | ||||
-rw-r--r-- | libguile/memoize.c | 1141 | ||||
-rw-r--r-- | libguile/memoize.h | 106 | ||||
-rw-r--r-- | libguile/modules.c | 43 | ||||
-rw-r--r-- | libguile/modules.h | 5 | ||||
-rw-r--r-- | libguile/print.c | 24 | ||||
-rw-r--r-- | libguile/procprop.c | 12 | ||||
-rw-r--r-- | libguile/procs.c | 2 | ||||
-rw-r--r-- | libguile/procs.h | 5 | ||||
-rw-r--r-- | libguile/srcprop.c | 12 | ||||
-rw-r--r-- | libguile/stacks.c | 40 | ||||
-rw-r--r-- | libguile/tags.h | 44 | ||||
-rw-r--r-- | libguile/validate.h | 2 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 1 | ||||
-rw-r--r-- | module/ice-9/deprecated.scm | 5 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 9 | ||||
-rw-r--r-- | test-suite/tests/chars.test | 2 | ||||
-rw-r--r-- | test-suite/tests/eval.test | 7 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 167 |
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!)" |