X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/26ecfa393d846177d5189fa43c758b80667d951a..c367c4b44eb9a20137930ec8771c69da9cec50a3:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 62f6ce3a5..9fe419137 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -13,11 +13,13 @@ * * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#define _GNU_SOURCE + /* This file is read twice in order to produce debugging versions of ceval and * scm_apply. These functions, deval and scm_dapply, are produced when we * define the preprocessor macro DEVAL. The file is divided into sections @@ -51,6 +53,9 @@ char *alloca (); # endif # endif #endif +#if HAVE_MALLOC_H +#include /* alloca on mingw */ +#endif #include #include "libguile/_scm.h" @@ -80,6 +85,7 @@ char *alloca (); #include "libguile/srcprop.h" #include "libguile/stackchk.h" #include "libguile/strings.h" +#include "libguile/threads.h" #include "libguile/throw.h" #include "libguile/validate.h" #include "libguile/values.h" @@ -89,11 +95,11 @@ char *alloca (); +static SCM unmemoize_exprs (SCM expr, SCM env); static SCM canonicalize_define (SCM expr); static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check); - -/* prototype in eval.h is not given under --disable-deprecated */ -SCM_API SCM scm_macroexp (SCM x, SCM env); +static SCM unmemoize_builtin_macro (SCM expr, SCM env); +static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); @@ -255,19 +261,19 @@ 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) { - const SCM msg_string = scm_makfrom0str (msg); + 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_CONSP (form)) + if (scm_is_pair (form)) { filename = scm_source_property (form, scm_sym_filename); linenr = scm_source_property (form, scm_sym_line); } - if (SCM_FALSEP (filename) && SCM_FALSEP (linenr) && SCM_CONSP (expr)) + 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); @@ -275,12 +281,12 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) if (!SCM_UNBNDP (expr)) { - if (!SCM_FALSEP (filename)) + 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_FALSEP (linenr)) + else if (scm_is_true (linenr)) { format = "In line ~S: ~A ~S in expression ~S."; args = scm_list_4 (linenr, msg_string, form, expr); @@ -293,12 +299,12 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) } else { - if (!SCM_FALSEP (filename)) + 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_FALSEP (linenr)) + else if (scm_is_true (linenr)) { format = "In line ~S: ~A ~S."; args = scm_list_3 (linenr, msg_string, form); @@ -329,6 +335,8 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) * 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. */ #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) @@ -340,6 +348,8 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) #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) \ @@ -359,27 +369,27 @@ scm_i_print_iloc (SCM iloc, SCM port) #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1) SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp); + 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 { - SCM_VALIDATE_INUM (1, frame); - SCM_VALIDATE_INUM (2, binding); - return SCM_MAKE_ILOC (SCM_INUM (frame), - SCM_INUM (binding), - !SCM_FALSEP (cdrp)); + 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 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_BOOL (SCM_ILOCP (obj)); + return scm_from_bool (SCM_ILOCP (obj)); } #undef FUNC_NAME @@ -437,31 +447,22 @@ scm_i_print_isym (SCM isym, SCM 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 syntactic keyword, the macro object to which - * the symbol is bound 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. */ + * 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, it returns a macro object if the symbol is a syntactic keyword - * and it returns a variable object if the symbol is a global variable. */ + * 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_FALSEP (variable)) - { - return SCM_UNDEFINED; - } + if (scm_is_false (variable)) + return SCM_UNDEFINED; else - { - const SCM value = SCM_VARIABLE_REF (variable); - if (SCM_MACROP (value)) - return value; - else - return variable; - } + return variable; } static SCM @@ -471,25 +472,25 @@ lookup_symbol (const SCM symbol, const SCM env) unsigned int frame_nr; for (frame_idx = env, frame_nr = 0; - !SCM_NULLP (frame_idx); + !scm_is_null (frame_idx); frame_idx = SCM_CDR (frame_idx), ++frame_nr) { const SCM frame = SCM_CAR (frame_idx); - if (SCM_CONSP (frame)) + 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_CONSP (symbol_idx); + scm_is_pair (symbol_idx); symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr) { - if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol)) + 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_EQ_P (symbol_idx, symbol)) + 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); } @@ -512,8 +513,10 @@ lookup_symbol (const SCM symbol, const SCM env) static int literal_p (const SCM symbol, const SCM env) { - const SCM value = lookup_symbol (symbol, env); - if (SCM_UNBNDP (value) || SCM_MACROP (value)) + 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; @@ -526,16 +529,107 @@ literal_p (const SCM symbol, const SCM env) static int is_self_quoting_p (const SCM expr) { - if (SCM_CONSP (expr)) + if (scm_is_pair (expr)) return 0; - else if (SCM_SYMBOLP (expr)) + else if (scm_is_symbol (expr)) return 0; - else if (SCM_NULLP (expr)) + else if (scm_is_null (expr)) return 0; else return 1; } +SCM_SYMBOL (sym_three_question_marks, "???"); + +static SCM +unmemoize_expression (const SCM expr, const SCM env) +{ + 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); + } +} + + +static SCM +unmemoize_exprs (const SCM exprs, const SCM env) +{ + 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 + { + return um_expr; + } +} + + /* Rewrite the body (which is given as the list of expressions forming the * body) into its internal form. The internal form of a body ( ...) is * just the body itself, but prefixed with an ISYM that denotes to what kind @@ -556,25 +650,29 @@ m_body (SCM op, SCM 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. */ +/* 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. It helps to figure out whether - * an expression denotes a syntactic keyword. */ +/* 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_SYMBOLP (expr)) + if (scm_is_symbol (expr)) { - const SCM value = lookup_symbol (expr, env); - return value; - } - else - { - return SCM_UNDEFINED; + 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; } /* This is a helper function for m_expand_body. It expands user macros, @@ -583,7 +681,7 @@ try_macro_lookup (const SCM expr, const SCM env) static SCM expand_user_macros (SCM expr, const SCM env) { - while (SCM_CONSP (expr)) + while (scm_is_pair (expr)) { const SCM car_expr = SCM_CAR (expr); const SCM new_car = expand_user_macros (car_expr, env); @@ -614,14 +712,14 @@ expand_user_macros (SCM expr, const SCM env) static int is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) { - if (SCM_CONSP (form)) + 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_EQ_P (macro_name, syntactic_keyword); + return scm_is_eq (macro_name, syntactic_keyword); } } @@ -645,7 +743,7 @@ m_expand_body (const SCM forms, const SCM env) * 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_NULLP (form_idx)) + while (!scm_is_null (form_idx)) { const SCM form = SCM_CAR (form_idx); const SCM new_form = expand_user_macros (form, env); @@ -664,7 +762,7 @@ m_expand_body (const SCM forms, const SCM env) unsigned int found_definition = 0; unsigned int found_expression = 0; SCM grouped_form_idx = grouped_forms; - while (!found_expression && !SCM_NULLP (grouped_form_idx)) + 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); @@ -716,9 +814,9 @@ m_expand_body (const SCM forms, const SCM env) } /* FIXME: forms does not hold information about the file location. */ - ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); + ASSERT_SYNTAX (scm_is_pair (sequence), s_missing_body_expression, cdr_forms); - if (!SCM_NULLP (definitions)) + if (!scm_is_null (definitions)) { SCM definition_idx; SCM letrec_tail; @@ -727,7 +825,7 @@ m_expand_body (const SCM forms, const SCM env) SCM bindings = SCM_EOL; for (definition_idx = definitions; - !SCM_NULLP (definition_idx); + !scm_is_null (definition_idx); definition_idx = SCM_CDR (definition_idx)) { const SCM definition = SCM_CAR (definition_idx); @@ -750,6 +848,59 @@ m_expand_body (const SCM forms, const SCM env) } } +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) + { + /* We have lost the race. */ + goto macro_tail; + } + 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; + + SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ + res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); + + if (scm_ilength (res) <= 0) + res = scm_list_2 (SCM_IM_BEGIN, res); + + /* 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. */ @@ -777,6 +928,12 @@ scm_m_and (SCM expr, SCM env SCM_UNUSED) } } +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, s_begin); @@ -794,6 +951,12 @@ scm_m_begin (SCM expr, SCM env SCM_UNUSED) 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, s_case); @@ -813,7 +976,7 @@ scm_m_case (SCM expr, SCM env) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr); clauses = SCM_CDR (cdr_expr); - while (!SCM_NULLP (clauses)) + while (!scm_is_null (clauses)) { SCM labels; @@ -822,13 +985,13 @@ scm_m_case (SCM expr, SCM env) s_bad_case_clause, clause, expr); labels = SCM_CAR (clause); - if (SCM_CONSP (labels)) + 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_NULLP (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. @@ -837,24 +1000,24 @@ scm_m_case (SCM expr, SCM env) } else { - ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, + ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p, s_bad_case_labels, labels, expr); - ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)), + ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)), s_misplaced_else_clause, clause, expr); } /* build the new clause */ - if (SCM_EQ_P (labels, scm_sym_else)) + 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_NULLP (all_labels); all_labels = SCM_CDR (all_labels)) + for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels)) { const SCM label = SCM_CAR (all_labels); - ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label, SCM_CDR (all_labels))), + ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))), s_duplicate_case_label, label, expr); } @@ -862,6 +1025,34 @@ scm_m_case (SCM expr, SCM env) 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, s_cond); @@ -881,7 +1072,7 @@ scm_m_cond (SCM expr, SCM env) ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr); for (clause_idx = clauses; - !SCM_NULLP (clause_idx); + !scm_is_null (clause_idx); clause_idx = SCM_CDR (clause_idx)) { SCM test; @@ -891,9 +1082,9 @@ scm_m_cond (SCM expr, SCM env) ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr); test = SCM_CAR (clause); - if (SCM_EQ_P (test, scm_sym_else) && else_literal_p) + if (scm_is_eq (test, scm_sym_else) && else_literal_p) { - const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx)); + 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, @@ -901,19 +1092,70 @@ scm_m_cond (SCM expr, SCM env) SCM_SETCAR (clause, SCM_IM_ELSE); } else if (length >= 2 - && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow) + && 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; + + 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); + + if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence), + SCM_IM_ARROW)) + { + const SCM target = SCM_CADR (sequence); + const SCM um_target = unmemoize_expression (target, env); + um_sequence = scm_list_2 (scm_sym_arrow, um_target); + } + else + { + um_sequence = unmemoize_exprs (sequence, env); + } + + 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, s_define); @@ -949,7 +1191,7 @@ canonicalize_define (const SCM expr) body = SCM_CDR (cdr_expr); variable = SCM_CAR (cdr_expr); - while (SCM_CONSP (variable)) + 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 @@ -965,7 +1207,7 @@ canonicalize_define (const SCM expr) body = scm_list_1 (lambda); variable = SCM_CAR (variable); } - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + 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); @@ -997,7 +1239,7 @@ scm_m_define (SCM expr, SCM env) tmp = SCM_MACRO_CODE (tmp); if (SCM_CLOSUREP (tmp) /* Only the first definition determines the name. */ - && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) + && scm_is_false (scm_procedure_property (tmp, scm_sym_name))) scm_set_procedure_property_x (tmp, scm_sym_name, variable); } @@ -1040,6 +1282,13 @@ scm_m_delay (SCM expr, SCM env) return new_expr; } +static SCM +unmemoize_delay (const SCM expr, const SCM env) +{ + const SCM thunk_expr = SCM_CADDR (expr); + return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env)); +} + SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); @@ -1082,7 +1331,7 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED) binding_idx = SCM_CAR (cdr_expr); ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0, s_bad_bindings, binding_idx, expr); - for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + 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); @@ -1093,8 +1342,8 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED) 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_SYMBOLP (name), s_bad_variable, name, expr); - ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, variables)), + 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); @@ -1119,6 +1368,43 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED) 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, s_if); @@ -1133,6 +1419,26 @@ scm_m_if (SCM expr, SCM env SCM_UNUSED) 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, s_lambda); @@ -1145,12 +1451,12 @@ SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); static int c_improper_memq (SCM obj, SCM list) { - for (; SCM_CONSP (list); list = SCM_CDR (list)) + for (; scm_is_pair (list); list = SCM_CDR (list)) { - if (SCM_EQ_P (SCM_CAR (list), obj)) + if (scm_is_eq (SCM_CAR (list), obj)) return 1; } - return SCM_EQ_P (list, obj); + return scm_is_eq (list, obj); } SCM @@ -1171,30 +1477,30 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) /* 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_CONSP (formals)) + 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_SYMBOLP (formals) || SCM_NULLP (formals), + 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_CONSP (formals_idx)) + 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_SYMBOLP (formal), s_bad_formal, formal, expr); + 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_NULLP (formals_idx) || SCM_SYMBOLP (formals_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. */ @@ -1203,7 +1509,7 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) * the documentation string will have to be skipped with every execution * of the closure. */ cddr_expr = SCM_CDR (cdr_expr); - documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_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); @@ -1215,6 +1521,19 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED) 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 (( ) ...). */ static void @@ -1226,7 +1545,7 @@ check_bindings (const SCM bindings, const SCM expr) s_bad_bindings, bindings, expr); binding_idx = bindings; - for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx)) { SCM name; /* const */ @@ -1235,7 +1554,7 @@ check_bindings (const SCM bindings, const SCM expr) s_bad_binding, binding, expr); name = SCM_CAR (binding); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr); } } @@ -1254,12 +1573,12 @@ transform_bindings ( SCM rvariables = SCM_EOL; SCM rinits = SCM_EOL; SCM binding_idx = bindings; - for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + 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_FALSEP (scm_c_memq (name, rvariables)), + 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); @@ -1321,14 +1640,14 @@ scm_m_let (SCM expr, SCM env) ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); bindings = SCM_CAR (cdr_expr); - if (SCM_SYMBOLP (bindings)) + 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_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) + 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)); @@ -1351,6 +1670,84 @@ scm_m_let (SCM expr, SCM env) } } +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, s_letrec); + +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, s_letstar); @@ -1379,7 +1776,7 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED) * 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_NULLP (binding_idx)) + while (!scm_is_null (binding_idx)) { const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */ const SCM binding = SCM_CAR (binding_idx); @@ -1400,37 +1797,30 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED) return expr; } - -SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); -SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); - -SCM -scm_m_letrec (SCM expr, SCM env) +static SCM +unmemoize_letstar (const SCM expr, const 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); + 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; - bindings = SCM_CAR (cdr_expr); - if (SCM_NULLP (bindings)) + while (!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); + 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); } - else - { - SCM rvariables; - SCM inits; - SCM new_body; + um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED); - 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)); - } + um_body = unmemoize_exprs (body, extended_env); + + return scm_cons2 (scm_sym_letstar, um_bindings, um_body); } @@ -1457,6 +1847,12 @@ scm_m_or (SCM expr, SCM env SCM_UNUSED) } } +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, s_quasiquote); @@ -1470,16 +1866,16 @@ SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); static SCM iqq (SCM form, SCM env, unsigned long int depth) { - if (SCM_CONSP (form)) + if (scm_is_pair (form)) { const SCM tmp = SCM_CAR (form); - if (SCM_EQ_P (tmp, scm_sym_quasiquote)) + 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_EQ_P (tmp, scm_sym_unquote)) + else if (scm_is_eq (tmp, scm_sym_unquote)) { const SCM args = SCM_CDR (form); ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); @@ -1488,8 +1884,8 @@ iqq (SCM form, SCM env, unsigned long int depth) else return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); } - else if (SCM_CONSP (tmp) - && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) + 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); @@ -1509,16 +1905,8 @@ iqq (SCM form, SCM env, unsigned long int depth) return scm_cons (iqq (SCM_CAR (form), env, depth), iqq (SCM_CDR (form), env, depth)); } - else if (SCM_VECTORP (form)) - { - size_t i = SCM_VECTOR_LENGTH (form); - SCM const *const data = SCM_VELTS (form); - SCM tmp = SCM_EOL; - while (i != 0) - tmp = scm_cons (data[--i], tmp); - scm_remember_upto_here_1 (form); - return scm_vector (iqq (tmp, env, depth)); - } + else if (scm_is_vector (form)) + return scm_vector (iqq (scm_vector_to_list (form), env, depth)); else return form; } @@ -1577,7 +1965,7 @@ scm_m_set_x (SCM expr, SCM env SCM_UNUSED) variable = SCM_CAR (cdr_expr); /* Memoize the variable form. */ - ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + 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)) @@ -1588,6 +1976,12 @@ scm_m_set_x (SCM expr, SCM env SCM_UNUSED) 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. */ @@ -1607,6 +2001,12 @@ scm_m_apply (SCM expr, SCM env SCM_UNUSED) 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); @@ -1645,14 +2045,14 @@ scm_m_atbind (SCM expr, SCM env) transform_bindings (bindings, expr, &rvariables, &inits); for (variable_idx = rvariables; - !SCM_NULLP (variable_idx); + !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_FALSEP (new_variable)) + if (scm_is_false (new_variable)) new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); SCM_SETCAR (variable_idx, new_variable); } @@ -1677,6 +2077,12 @@ scm_m_cont (SCM expr, SCM env SCM_UNUSED) 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, s_at_call_with_values); @@ -1692,6 +2098,17 @@ scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED) 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)); +} + +#if 0 + +/* See futures.h for a comment why futures are not enabled. + */ SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future); SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); @@ -1709,6 +2126,14 @@ scm_m_future (SCM expr, SCM env) return new_expr; } +static SCM +unmemoize_future (const SCM expr, const SCM env) +{ + const SCM thunk_expr = SCM_CADDR (expr); + return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env)); +} + +#endif SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); SCM_SYMBOL (scm_sym_setter, "setter"); @@ -1723,7 +2148,7 @@ scm_m_generalized_set_x (SCM expr, SCM env) ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); target = SCM_CAR (cdr_expr); - if (!SCM_CONSP (target)) + if (!scm_is_pair (target)) { /* R5RS usage */ return scm_m_set_x (expr, env); @@ -1735,13 +2160,13 @@ scm_m_generalized_set_x (SCM expr, SCM env) (begin ). In that case, must be a symbol or a variable and we memoize to (set! ...). */ - exp_target = scm_macroexp (target, env); - if (SCM_EQ_P (SCM_CAR (exp_target), SCM_IM_BEGIN) - && !SCM_NULLP (SCM_CDR (exp_target)) - && SCM_NULLP (SCM_CDDR (exp_target))) + 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_SYMBOLP (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, @@ -1769,6 +2194,9 @@ scm_m_generalized_set_x (SCM expr, SCM env) * 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_ref, "@slot-ref"); + SCM scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) { @@ -1778,18 +2206,30 @@ scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) 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_INUMP (slot_nr), s_bad_slot_number, slot_nr, 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!"); + SCM scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) { @@ -1799,12 +2239,26 @@ scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) 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_INUMP (slot_nr), s_bad_slot_number, slot_nr, 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 @@ -1848,7 +2302,7 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr); symbol = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, 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); @@ -1856,7 +2310,7 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED) /* 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_SYMBOLP (SCM_VARIABLE_REF (location))) + while (scm_is_symbol (SCM_VARIABLE_REF (location))) { const SCM alias = SCM_VARIABLE_REF (location); location = scm_symbol_fref (alias); @@ -1888,6 +2342,124 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED) #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); + +#if 0 + /* See futures.h for a comment why futures are not enabled. + */ + case (ISYMNUM (SCM_IM_FUTURE)): + return unmemoize_future (expr, env); +#endif + + 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); + + case (ISYMNUM (SCM_IM_NIL_COND)): + return unmemoize_exprs (expr, env); /* FIXME */ + + default: + return unmemoize_exprs (expr, env); /* FIXME */ + } +} + + +/* 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) /* Deprecated in guile 1.7.0 on 2003-11-09. */ @@ -1914,108 +2486,39 @@ scm_m_undefine (SCM expr, SCM env) 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_SYMBOLP (variable), s_bad_variable, variable, 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_FALSEP (location) + 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; -} - - -SCM -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_SYMBOLP (orig_sym)) - return x; - - { - SCM *proc_ptr = scm_lookupcar1 (x, env, 0); - if (proc_ptr == NULL) - { - /* We have lost the race. */ - goto macro_tail; - } - 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; - - SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ - res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); - - if (scm_ilength (res) <= 0) - res = scm_list_2 (SCM_IM_BEGIN, res); - - SCM_DEFER_INTS; - SCM_SETCAR (x, SCM_CAR (res)); - SCM_SETCDR (x, SCM_CDR (res)); - SCM_ALLOW_INTS; - - goto macro_tail; -} - -#endif - -/*****************************************************************************/ -/*****************************************************************************/ -/* The definitions for unmemoization start here. */ -/*****************************************************************************/ -/*****************************************************************************/ +} -#define SCM_BIT7(x) (127 & SCM_UNPACK (x)) +SCM +scm_macroexp (SCM x, SCM env) +{ + scm_c_issue_deprecation_warning + ("`scm_macroexp' is deprecated."); + return macroexp (x, env); +} -SCM_SYMBOL (sym_three_question_marks, "???"); +#endif -/* scm_unmemocopy takes a memoized expression together with its - * environment and rewrites it to its original form. Thus, it is the - * inversion of the rewrite rules above. The procedure is not - * optimized for speed. It's used in scm_iprin1 when printing the - * code of a closure, in scm_procedure_source, in display_frame when - * generating the source for a stackframe in a backtrace, and in - * display_expression. - * - * 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. - */ +#if (SCM_ENABLE_DEPRECATED == 1) -static SCM -build_binding_list (SCM rnames, SCM rinits) +SCM +scm_unmemocar (SCM form, SCM env) { - SCM bindings = SCM_EOL; - while (!SCM_NULLP (rnames)) - { - 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; -} - + scm_c_issue_deprecation_warning + ("`scm_unmemocar' is deprecated."); -static SCM -unmemocar (SCM form, SCM env) -{ - if (!SCM_CONSP (form)) + if (!scm_is_pair (form)) return form; else { @@ -2023,7 +2526,7 @@ unmemocar (SCM form, SCM env) if (SCM_VARIABLEP (c)) { SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); - if (SCM_FALSEP (sym)) + if (scm_is_false (sym)) sym = sym_three_question_marks; SCM_SETCAR (form, sym); } @@ -2043,241 +2546,6 @@ unmemocar (SCM form, SCM env) } } - -SCM -scm_unmemocopy (SCM x, SCM env) -{ - SCM ls, z; - SCM p; - - if (SCM_VECTORP (x)) - { - return scm_list_2 (scm_sym_quote, x); - } - else if (!SCM_CONSP (x)) - return x; - - p = scm_whash_lookup (scm_source_whash, x); - if (SCM_ISYMP (SCM_CAR (x))) - { - switch (ISYMNUM (SCM_CAR (x))) - { - case (ISYMNUM (SCM_IM_AND)): - ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_BEGIN)): - ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_CASE)): - ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_COND)): - ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_DO)): - { - /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk), - * where ix is an initializer for a local variable, nx is the name - * of the local variable, test is the test clause of the do loop, - * body is the body of the do loop and sx are the step clauses for - * the local variables. */ - SCM names, inits, test, memoized_body, steps, bindings; - - x = SCM_CDR (x); - inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); - x = SCM_CDR (x); - names = SCM_CAR (x); - env = SCM_EXTEND_ENV (names, SCM_EOL, env); - x = SCM_CDR (x); - test = scm_unmemocopy (SCM_CAR (x), env); - x = SCM_CDR (x); - memoized_body = SCM_CAR (x); - x = SCM_CDR (x); - steps = scm_reverse (scm_unmemocopy (x, env)); - - /* build transformed binding list */ - bindings = SCM_EOL; - while (!SCM_NULLP (names)) - { - SCM name = SCM_CAR (names); - SCM init = SCM_CAR (inits); - SCM step = SCM_CAR (steps); - step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step); - - bindings = scm_cons (scm_cons2 (name, init, step), bindings); - - names = SCM_CDR (names); - inits = SCM_CDR (inits); - steps = SCM_CDR (steps); - } - z = scm_cons (test, SCM_UNSPECIFIED); - ls = scm_cons2 (scm_sym_do, bindings, z); - - x = scm_cons (SCM_BOOL_F, memoized_body); - break; - } - case (ISYMNUM (SCM_IM_IF)): - ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_LET)): - { - /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...), - * where nx is the name of a local variable, ix is an initializer - * for the local variable and by are the body clauses. */ - SCM rnames, rinits, bindings; - - x = SCM_CDR (x); - rnames = SCM_CAR (x); - x = SCM_CDR (x); - rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); - env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); - - bindings = build_binding_list (rnames, rinits); - z = scm_cons (bindings, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_let, z); - break; - } - case (ISYMNUM (SCM_IM_LETREC)): - { - /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...), - * where vx is the name of a local variable, ix is an initializer - * for the local variable and by are the body clauses. */ - SCM rnames, rinits, bindings; - - x = SCM_CDR (x); - rnames = SCM_CAR (x); - env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); - x = SCM_CDR (x); - rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); - - bindings = build_binding_list (rnames, rinits); - z = scm_cons (bindings, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_letrec, z); - break; - } - case (ISYMNUM (SCM_IM_LETSTAR)): - { - SCM b, y; - x = SCM_CDR (x); - b = SCM_CAR (x); - y = SCM_EOL; - if (SCM_NULLP (b)) - { - env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env); - } - else - { - SCM copy = scm_unmemocopy (SCM_CADR (b), env); - SCM initializer = unmemocar (scm_list_1 (copy), env); - y = z = scm_acons (SCM_CAR (b), initializer, SCM_UNSPECIFIED); - env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); - b = SCM_CDDR (b); - if (SCM_NULLP (b)) - { - SCM_SETCDR (y, SCM_EOL); - z = scm_cons (y, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_let, z); - break; - } - do - { - copy = scm_unmemocopy (SCM_CADR (b), env); - initializer = unmemocar (scm_list_1 (copy), env); - SCM_SETCDR (z, scm_acons (SCM_CAR (b), - initializer, - SCM_UNSPECIFIED)); - z = SCM_CDR (z); - env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); - b = SCM_CDDR (b); - } - while (!SCM_NULLP (b)); - SCM_SETCDR (z, SCM_EOL); - } - z = scm_cons (y, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_letstar, z); - break; - } - case (ISYMNUM (SCM_IM_OR)): - ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_LAMBDA)): - x = SCM_CDR (x); - z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_lambda, z); - env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); - break; - - case (ISYMNUM (SCM_IM_QUOTE)): - return unmemoize_quote (x, env); - - case (ISYMNUM (SCM_IM_SET_X)): - ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_APPLY)): - ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_CONT)): - ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_DELAY)): - ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); - x = SCM_CDR (x); - break; - case (ISYMNUM (SCM_IM_FUTURE)): - ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED); - x = SCM_CDR (x); - break; - case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): - ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); - break; - case (ISYMNUM (SCM_IM_ELSE)): - ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED); - break; - default: - ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env), - SCM_UNSPECIFIED), - env); - } - } - else - { - ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env), - SCM_UNSPECIFIED), - env); - } - - x = SCM_CDR (x); - while (SCM_CONSP (x)) - { - SCM form = SCM_CAR (x); - if (!SCM_ISYMP (form)) - { - SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED); - SCM_SETCDR (z, unmemocar (copy, env)); - z = SCM_CDR (z); - } - else if (SCM_EQ_P (form, SCM_IM_ARROW)) - { - SCM_SETCDR (z, scm_cons (scm_sym_arrow, SCM_UNSPECIFIED)); - z = SCM_CDR (z); - } - x = SCM_CDR (x); - } - SCM_SETCDR (z, x); - if (!SCM_FALSEP (p)) - scm_whash_insert (scm_source_whash, ls, p); - return ls; -} - - -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM -scm_unmemocar (SCM form, SCM env) -{ - return unmemocar (form, env); -} - #endif /*****************************************************************************/ @@ -2290,6 +2558,7 @@ 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_trace, "trace"); +SCM_SYMBOL (sym_instead, "instead"); /* A function object to implement "apply" for non-closure functions. */ static SCM f_apply; @@ -2300,16 +2569,16 @@ static SCM undefineds; int scm_badargsp (SCM formals, SCM args) { - while (!SCM_NULLP (formals)) + while (!scm_is_null (formals)) { - if (!SCM_CONSP (formals)) + if (!scm_is_pair (formals)) return 0; - if (SCM_NULLP (args)) + if (scm_is_null (args)) return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); } - return !SCM_NULLP (args) ? 1 : 0; + return !scm_is_null (args) ? 1 : 0; } @@ -2324,7 +2593,7 @@ scm_badargsp (SCM formals, SCM args) * Originally, it is defined to ceval, but is redefined to deval during the * second pass. * - * SCM_EVALIM is used when it is known that the expression is an + * SCM_I_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 @@ -2339,10 +2608,10 @@ scm_badargsp (SCM formals, SCM args) * The following macros should be used in code which is read once * (where the choice of evaluator is dynamic): * - * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the + * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the * debugging mode. * - * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending + * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending * on the debugging mode. * * The main motivation for keeping this plethora is efficiency @@ -2354,61 +2623,61 @@ static SCM deval (SCM x, SCM env); #define CEVAL ceval -#define SCM_EVALIM2(x) \ - ((SCM_EQ_P ((x), SCM_EOL) \ +#define SCM_I_EVALIM2(x) \ + ((scm_is_eq ((x), SCM_EOL) \ ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \ : 0), \ (x)) -#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ +#define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \ ? *scm_ilookup ((x), (env)) \ - : SCM_EVALIM2(x)) + : SCM_I_EVALIM2(x)) -#define SCM_XEVAL(x, env) \ +#define SCM_I_XEVAL(x, env) \ (SCM_IMP (x) \ - ? SCM_EVALIM2 (x) \ + ? SCM_I_EVALIM2 (x) \ : (SCM_VARIABLEP (x) \ ? SCM_VARIABLE_REF (x) \ - : (SCM_CONSP (x) \ + : (scm_is_pair (x) \ ? (scm_debug_mode_p \ ? deval ((x), (env)) \ : ceval ((x), (env))) \ : (x)))) -#define SCM_XEVALCAR(x, env) \ +#define SCM_I_XEVALCAR(x, env) \ (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), (env)) \ + ? SCM_I_EVALIM (SCM_CAR (x), (env)) \ : (SCM_VARIABLEP (SCM_CAR (x)) \ ? SCM_VARIABLE_REF (SCM_CAR (x)) \ - : (SCM_CONSP (SCM_CAR (x)) \ + : (scm_is_pair (SCM_CAR (x)) \ ? (scm_debug_mode_p \ ? deval (SCM_CAR (x), (env)) \ : ceval (SCM_CAR (x), (env))) \ - : (!SCM_SYMBOLP (SCM_CAR (x)) \ + : (!scm_is_symbol (SCM_CAR (x)) \ ? SCM_CAR (x) \ : *scm_lookupcar ((x), (env), 1))))) #define EVAL(x, env) \ (SCM_IMP (x) \ - ? SCM_EVALIM ((x), (env)) \ + ? SCM_I_EVALIM ((x), (env)) \ : (SCM_VARIABLEP (x) \ ? SCM_VARIABLE_REF (x) \ - : (SCM_CONSP (x) \ + : (scm_is_pair (x) \ ? CEVAL ((x), (env)) \ : (x)))) #define EVALCAR(x, env) \ (SCM_IMP (SCM_CAR (x)) \ - ? SCM_EVALIM (SCM_CAR (x), (env)) \ + ? SCM_I_EVALIM (SCM_CAR (x), (env)) \ : (SCM_VARIABLEP (SCM_CAR (x)) \ ? SCM_VARIABLE_REF (SCM_CAR (x)) \ - : (SCM_CONSP (SCM_CAR (x)) \ + : (scm_is_pair (SCM_CAR (x)) \ ? CEVAL (SCM_CAR (x), (env)) \ - : (!SCM_SYMBOLP (SCM_CAR (x)) \ + : (!scm_is_symbol (SCM_CAR (x)) \ ? SCM_CAR (x) \ : *scm_lookupcar ((x), (env), 1))))) -SCM_REC_MUTEX (source_mutex); +scm_i_pthread_mutex_t source_mutex; /* Lookup a given local variable in an environment. The local variable is @@ -2442,6 +2711,10 @@ scm_ilookup (SCM iloc, SCM env) SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void error_defined_variable (SCM symbol) SCM_NORETURN; + +/* Call this for variables that are unfound. + */ static void error_unbound_variable (SCM symbol) { @@ -2450,6 +2723,20 @@ error_unbound_variable (SCM symbol) 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 @@ -2532,16 +2819,16 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) register SCM iloc = SCM_ILOC00; for (; SCM_NIMP (env); env = SCM_CDR (env)) { - if (!SCM_CONSP (SCM_CAR (env))) + 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_CONSP (fl)) + if (!scm_is_pair (fl)) { - if (SCM_EQ_P (fl, var)) + if (scm_is_eq (fl, var)) { - if (! SCM_EQ_P (SCM_CAR (vloc), 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); @@ -2550,14 +2837,11 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) break; } al = SCM_CDRLOC (*al); - if (SCM_EQ_P (SCM_CAR (fl), var)) + if (scm_is_eq (SCM_CAR (fl), var)) { if (SCM_UNBNDP (SCM_CAR (*al))) - { - env = SCM_EOL; - goto errout; - } - if (!SCM_EQ_P (SCM_CAR (vloc), var)) + error_defined_variable (var); + if (!scm_is_eq (SCM_CAR (vloc), var)) goto race; SCM_SETCAR (vloc, iloc); return SCM_CARLOC (*al); @@ -2577,15 +2861,15 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) else top_thunk = SCM_BOOL_F; real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F); - if (SCM_FALSEP (real_var)) + if (scm_is_false (real_var)) goto errout; - if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) + if (!scm_is_null (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) { errout: if (check) { - if (SCM_NULLP (env)) + if (scm_is_null (env)) error_unbound_variable (var); else scm_misc_error (NULL, "Damaged environment: ~S", @@ -2600,7 +2884,7 @@ scm_lookupcar1 (SCM vloc, SCM genv, int check) } } - if (!SCM_EQ_P (SCM_CAR (vloc), var)) + if (!scm_is_eq (SCM_CAR (vloc), var)) { /* Some other thread has changed the very cell we are working on. In effect, it must have done our job or messed it up @@ -2643,7 +2927,7 @@ 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_FALSEP (variable)) + if (scm_is_false (variable)) error_unbound_variable (symbol); else return variable; @@ -2653,7 +2937,7 @@ lazy_memoize_variable (const SCM symbol, const SCM environment) SCM scm_eval_car (SCM pair, SCM env) { - return SCM_XEVALCAR (pair, env); + return SCM_I_XEVALCAR (pair, env); } @@ -2661,7 +2945,7 @@ SCM scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; - while (SCM_CONSP (l)) + while (scm_is_pair (l)) { res = EVALCAR (l, env); @@ -2669,7 +2953,7 @@ scm_eval_args (SCM l, SCM env, SCM proc) lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } - if (!SCM_NULLP (l)) + if (!scm_is_null (l)) scm_wrong_num_args (proc); return results; } @@ -2682,26 +2966,27 @@ scm_eval_body (SCM code, SCM env) again: next = SCM_CDR (code); - while (!SCM_NULLP (next)) + while (!scm_is_null (next)) { if (SCM_IMP (SCM_CAR (code))) { if (SCM_ISYMP (SCM_CAR (code))) { - scm_rec_mutex_lock (&source_mutex); + 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_rec_mutex_unlock (&source_mutex); + scm_dynwind_end (); goto again; } } else - SCM_XEVAL (SCM_CAR (code), env); + SCM_I_XEVAL (SCM_CAR (code), env); code = next; next = SCM_CDR (code); } - return SCM_XEVALCAR (code, env); + return SCM_I_XEVALCAR (code, env); } #endif /* !DEVAL */ @@ -2743,21 +3028,11 @@ do { \ if (scm_check_apply_p && SCM_TRAPS_P)\ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\ {\ - SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \ + SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ SCM_SET_TRACED_FRAME (debug); \ SCM_TRAPS_P = 0;\ - if (SCM_CHEAPTRAPS_P)\ - {\ - tmp = scm_make_debugobj (&debug);\ - scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ - }\ - else\ - {\ - int first;\ - tmp = scm_make_continuation (&first);\ - if (first)\ - scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ - }\ + tmp = scm_make_debugobj (&debug);\ + scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ SCM_TRAPS_P = 1;\ }\ } while (0) @@ -2797,7 +3072,7 @@ scm_t_option scm_eval_opts[] = { scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "cheap", 1, - "*Flyweight representation of the stack at traps." }, + "*This option is now obsolete. Setting it has no effect." }, { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." }, { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." }, { SCM_OPTION_BOOLEAN, "procnames", 1, @@ -2814,7 +3089,8 @@ scm_t_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }, - { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."} + { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}, + { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." } }; scm_t_option scm_evaluator_trap_table[] = { @@ -2835,13 +3111,16 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, #define FUNC_NAME s_scm_eval_options_interface { SCM ans; - SCM_DEFER_INTS; + + scm_dynwind_begin (0); + scm_dynwind_critical_section (SCM_BOOL_F); ans = scm_options (setting, scm_eval_opts, SCM_N_EVAL_OPTIONS, FUNC_NAME); scm_eval_stack = SCM_EVAL_STACK * sizeof (void *); - SCM_ALLOW_INTS; + scm_dynwind_end (); + return ans; } #undef FUNC_NAME @@ -2853,13 +3132,14 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, #define FUNC_NAME s_scm_evaluator_traps { SCM ans; - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; ans = scm_options (setting, scm_evaluator_trap_table, SCM_N_EVALUATOR_TRAPS, FUNC_NAME); + /* njrev: same again. */ SCM_RESET_DEBUG_MODE; - SCM_ALLOW_INTS; + SCM_CRITICAL_SECTION_END; return ans; } #undef FUNC_NAME @@ -2869,7 +3149,7 @@ static SCM deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc; - while (SCM_CONSP (l)) + while (scm_is_pair (l)) { const SCM res = EVALCAR (l, env); @@ -2877,11 +3157,35 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } - if (!SCM_NULLP (l)) + if (!scm_is_null (l)) scm_wrong_num_args (proc); return *results; } +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); + } +} + #endif /* !DEVAL */ @@ -2900,7 +3204,7 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) + ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) /* This is the evaluator. Like any real monster, it has three heads: @@ -2936,7 +3240,7 @@ CEVAL (SCM x, SCM env) #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info *debug_info_end; - debug.prev = scm_last_debug_frame; + debug.prev = scm_i_last_debug_frame (); debug.status = 0; /* * The debug.vect contains twice as much scm_t_debug_info frames as the @@ -2948,7 +3252,7 @@ CEVAL (SCM x, SCM env) * sizeof (scm_t_debug_info)); debug.info = debug.vect; debug_info_end = debug.vect + scm_debug_eframe_size; - scm_last_debug_frame = &debug; + scm_i_set_last_debug_frame (&debug); #endif #ifdef EVAL_STACK_CHECKING if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) @@ -2994,35 +3298,25 @@ start: || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) { SCM stackrep; - SCM tail = SCM_BOOL (SCM_TAILRECP (debug)); + SCM tail = scm_from_bool (SCM_TAILRECP (debug)); SCM_SET_TAILREC (debug); - if (SCM_CHEAPTRAPS_P) - stackrep = scm_make_debugobj (&debug); - else - { - int first; - SCM val = scm_make_continuation (&first); - - if (first) - stackrep = val; - else - { - x = val; - if (SCM_IMP (x)) - RETURN (x); - else - /* This gives the possibility for the debugger to - modify the source expression before evaluation. */ - goto dispatch; - } - } + stackrep = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; - scm_call_4 (SCM_ENTER_FRAME_HDLR, - scm_sym_enter_frame, - stackrep, - tail, - scm_unmemocopy (x, env)); + 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); + } } } #endif @@ -3034,10 +3328,10 @@ dispatch: { case (ISYMNUM (SCM_IM_AND)): x = SCM_CDR (x); - while (!SCM_NULLP (SCM_CDR (x))) + while (!scm_is_null (SCM_CDR (x))) { SCM test_result = EVALCAR (x, env); - if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) + if (scm_is_false (test_result) || SCM_NILP (test_result)) RETURN (SCM_BOOL_F); else x = SCM_CDR (x); @@ -3047,7 +3341,7 @@ dispatch: case (ISYMNUM (SCM_IM_BEGIN)): x = SCM_CDR (x); - if (SCM_NULLP (x)) + if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -3055,10 +3349,10 @@ dispatch: begin: /* If we are on toplevel with a lookup closure, we need to sync with the current module. */ - if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env))) + if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env))) { UPDATE_TOPLEVEL_ENV (env); - while (!SCM_NULLP (SCM_CDR (x))) + while (!scm_is_null (SCM_CDR (x))) { EVALCAR (x, env); UPDATE_TOPLEVEL_ENV (env); @@ -3070,18 +3364,19 @@ dispatch: goto nontoplevel_begin; nontoplevel_begin: - while (!SCM_NULLP (SCM_CDR (x))) + while (!scm_is_null (SCM_CDR (x))) { const SCM form = SCM_CAR (x); if (SCM_IMP (form)) { if (SCM_ISYMP (form)) { - scm_rec_mutex_lock (&source_mutex); + 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_rec_mutex_unlock (&source_mutex); + scm_dynwind_end (); goto nontoplevel_begin; } else @@ -3097,17 +3392,17 @@ dispatch: /* scm_eval last form in list */ const SCM last_form = SCM_CAR (x); - if (SCM_CONSP (last_form)) + 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 (SCM_EVALIM (last_form, env)); + RETURN (SCM_I_EVALIM (last_form, env)); else if (SCM_VARIABLEP (last_form)) RETURN (SCM_VARIABLE_REF (last_form)); - else if (SCM_SYMBOLP (last_form)) + else if (scm_is_symbol (last_form)) RETURN (*scm_lookupcar (x, env, 1)); else RETURN (last_form); @@ -3119,21 +3414,21 @@ dispatch: { const SCM key = EVALCAR (x, env); x = SCM_CDR (x); - while (!SCM_NULLP (x)) + while (!scm_is_null (x)) { const SCM clause = SCM_CAR (x); SCM labels = SCM_CAR (clause); - if (SCM_EQ_P (labels, SCM_IM_ELSE)) + if (scm_is_eq (labels, SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } - while (!SCM_NULLP (labels)) + while (!scm_is_null (labels)) { const SCM label = SCM_CAR (labels); - if (SCM_EQ_P (label, key) - || !SCM_FALSEP (scm_eqv_p (label, key))) + if (scm_is_eq (label, key) + || scm_is_true (scm_eqv_p (label, key))) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -3149,10 +3444,10 @@ dispatch: case (ISYMNUM (SCM_IM_COND)): x = SCM_CDR (x); - while (!SCM_NULLP (x)) + while (!scm_is_null (x)) { const SCM clause = SCM_CAR (x); - if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE)) + if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -3161,12 +3456,34 @@ dispatch: else { arg1 = EVALCAR (clause, env); - if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1)) + /* 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 (guard_result) + && !SCM_NILP (guard_result)) + { + proc = SCM_CDDR (xx); + proc = EVALCAR (proc, env); + PREP_APPLY (proc, arg1); + goto apply_proc; + } + } + else if (scm_is_true (arg1) && !SCM_NILP (arg1)) { x = SCM_CDR (clause); - if (SCM_NULLP (x)) + if (scm_is_null (x)) RETURN (arg1); - else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW)) + else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -3192,7 +3509,7 @@ dispatch: /* Compute the initialization values and the initial environment. */ SCM init_forms = SCM_CAR (x); SCM init_values = SCM_EOL; - while (!SCM_NULLP (init_forms)) + while (!scm_is_null (init_forms)) { init_values = scm_cons (EVALCAR (init_forms, env), init_values); init_forms = SCM_CDR (init_forms); @@ -3208,13 +3525,13 @@ dispatch: SCM test_result = EVALCAR (test_form, env); - while (SCM_FALSEP (test_result) || SCM_NILP (test_result)) + while (scm_is_false (test_result) || SCM_NILP (test_result)) { { /* Evaluate body forms. */ SCM temp_forms; for (temp_forms = body_forms; - !SCM_NULLP (temp_forms); + !scm_is_null (temp_forms); temp_forms = SCM_CDR (temp_forms)) { SCM form = SCM_CAR (temp_forms); @@ -3236,7 +3553,7 @@ dispatch: SCM temp_forms; SCM step_values = SCM_EOL; for (temp_forms = step_forms; - !SCM_NULLP (temp_forms); + !scm_is_null (temp_forms); temp_forms = SCM_CDR (temp_forms)) { const SCM value = EVALCAR (temp_forms, env); @@ -3251,7 +3568,7 @@ dispatch: } } x = SCM_CDAR (x); - if (SCM_NULLP (x)) + if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; @@ -3262,10 +3579,10 @@ dispatch: { SCM test_result = EVALCAR (x, env); x = SCM_CDR (x); /* then expression */ - if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) + if (scm_is_false (test_result) || SCM_NILP (test_result)) { x = SCM_CDR (x); /* else expression */ - if (SCM_NULLP (x)) + if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); } } @@ -3283,7 +3600,7 @@ dispatch: init_values = scm_cons (EVALCAR (init_forms, env), init_values); init_forms = SCM_CDR (init_forms); } - while (!SCM_NULLP (init_forms)); + while (!scm_is_null (init_forms)); env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); } x = SCM_CDDR (x); @@ -3297,14 +3614,10 @@ dispatch: x = SCM_CDR (x); { SCM init_forms = SCM_CAR (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_NULLP (init_forms)); - SCM_SETCDR (SCM_CAR (env), init_values); + 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); @@ -3315,9 +3628,7 @@ dispatch: x = SCM_CDR (x); { SCM bindings = SCM_CAR (x); - if (SCM_NULLP (bindings)) - env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env); - else + if (!scm_is_null (bindings)) { do { @@ -3326,7 +3637,7 @@ dispatch: env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); bindings = SCM_CDR (init); } - while (!SCM_NULLP (bindings)); + while (!scm_is_null (bindings)); } } x = SCM_CDR (x); @@ -3336,10 +3647,10 @@ dispatch: case (ISYMNUM (SCM_IM_OR)): x = SCM_CDR (x); - while (!SCM_NULLP (SCM_CDR (x))) + while (!scm_is_null (SCM_CDR (x))) { SCM val = EVALCAR (x, env); - if (!SCM_FALSEP (val) && !SCM_NILP (val)) + if (scm_is_true (val) && !SCM_NILP (val)) RETURN (val); else x = SCM_CDR (x); @@ -3367,7 +3678,7 @@ dispatch: location = SCM_VARIABLE_LOC (variable); else { - /* (SCM_SYMBOLP (variable)) is known to be true */ + /* (scm_is_symbol (variable)) is known to be true */ variable = lazy_memoize_variable (variable, env); SCM_SETCAR (x, variable); location = SCM_VARIABLE_LOC (variable); @@ -3451,10 +3762,12 @@ dispatch: case (ISYMNUM (SCM_IM_DELAY)): RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); - +#if 0 + /* See futures.h for a comment why futures are not enabled. + */ case (ISYMNUM (SCM_IM_FUTURE)): RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); - +#endif /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following code (type_dispatch) is intended to be the tail of the case @@ -3494,14 +3807,24 @@ dispatch: { SCM z = SCM_CDDR (x); SCM tmp = SCM_CADR (z); - specializers = SCM_INUM (SCM_CAR (z)); + specializers = scm_to_ulong (SCM_CAR (z)); /* Compute a hash value for searching the method cache. There * are two variants for computing the hash value, a (rather) * complicated one, and a simple one. For the complicated one * explained below, tmp holds a number that is used in the * computation. */ - if (SCM_INUMP (tmp)) + if (scm_is_simple_vector (tmp)) + { + /* This method of determining the hash value is much + * simpler: Set the hash value to zero and just perform a + * linear search through the method cache. */ + method_cache = tmp; + mask = (unsigned long int) ((long) -1); + hash_value = 0; + cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache); + } + else { /* Use the signature of the actual arguments to determine * the hash value. This is done as follows: Each class has @@ -3518,11 +3841,11 @@ dispatch: * where dispatch is called, such that hopefully the hash * value that is computed will directly point to the right * method in the method cache. */ - unsigned long int hashset = SCM_INUM (tmp); + unsigned long int hashset = scm_to_ulong (tmp); unsigned long int counter = specializers + 1; SCM tmp_arg = arg1; hash_value = 0; - while (!SCM_NULLP (tmp_arg) && counter != 0) + while (!scm_is_null (tmp_arg) && counter != 0) { SCM class = scm_class_of (SCM_CAR (tmp_arg)); hash_value += SCM_INSTANCE_HASH (class, hashset); @@ -3531,20 +3854,10 @@ dispatch: } z = SCM_CDDR (z); method_cache = SCM_CADR (z); - mask = SCM_INUM (SCM_CAR (z)); + mask = scm_to_ulong (SCM_CAR (z)); hash_value &= mask; cache_end_pos = hash_value; } - else - { - /* This method of determining the hash value is much - * simpler: Set the hash value to zero and just perform a - * linear search through the method cache. */ - method_cache = tmp; - mask = (unsigned long int) ((long) -1); - hash_value = 0; - cache_end_pos = SCM_VECTOR_LENGTH (method_cache); - } } { @@ -3560,18 +3873,18 @@ dispatch: do { SCM args = arg1; /* list of arguments */ - z = SCM_VELTS (method_cache)[hash_value]; - while (!SCM_NULLP (args)) + z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value); + while (!scm_is_null (args)) { /* More arguments than specifiers => CLASS != ENV */ SCM class_of_arg = scm_class_of (SCM_CAR (args)); - if (!SCM_EQ_P (class_of_arg, SCM_CAR (z))) + if (!scm_is_eq (class_of_arg, SCM_CAR (z))) goto next_method; args = SCM_CDR (args); z = SCM_CDR (z); } /* Fewer arguments than specifiers => CAR != ENV */ - if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) + if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) goto apply_cmethod; next_method: hash_value = (hash_value + 1) & mask; @@ -3595,7 +3908,7 @@ dispatch: x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_INUM (SCM_CDR (x)); + unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } @@ -3604,7 +3917,7 @@ dispatch: x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); - unsigned long int slot = SCM_INUM (SCM_CADR (x)); + 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); @@ -3620,10 +3933,10 @@ dispatch: while (!SCM_NULL_OR_NIL_P (x)) { SCM test_result = EVALCAR (test_form, env); - if (!(SCM_FALSEP (test_result) + if (!(scm_is_false (test_result) || SCM_NULL_OR_NIL_P (test_result))) { - if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) + if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (test_result); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -3649,24 +3962,24 @@ dispatch: vars = SCM_CAAR (x); exps = SCM_CDAR (x); vals = SCM_EOL; - while (!SCM_NULLP (exps)) + while (!scm_is_null (exps)) { vals = scm_cons (EVALCAR (exps, env), vals); exps = SCM_CDR (exps); } scm_swap_bindings (vars, vals); - scm_dynwinds = scm_acons (vars, vals, scm_dynwinds); + scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ())); /* Ignore all but the last evaluation result. */ - for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x)) + for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x)) { - if (SCM_CONSP (SCM_CAR (x))) + if (scm_is_pair (SCM_CAR (x))) CEVAL (SCM_CAR (x), env); } proc = EVALCAR (x, env); - scm_dynwinds = SCM_CDR (scm_dynwinds); + scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); scm_swap_bindings (vars, vals); RETURN (proc); @@ -3707,9 +4020,9 @@ dispatch: proc = SCM_VARIABLE_REF (SCM_CAR (x)); else if (SCM_ILOCP (SCM_CAR (x))) proc = *scm_ilookup (SCM_CAR (x), env); - else if (SCM_CONSP (SCM_CAR (x))) + else if (scm_is_pair (SCM_CAR (x))) proc = CEVAL (SCM_CAR (x), env); - else if (SCM_SYMBOLP (SCM_CAR (x))) + else if (scm_is_symbol (SCM_CAR (x))) { SCM orig_sym = SCM_CAR (x); { @@ -3741,19 +4054,19 @@ dispatch: { case 3: case 2: - if (!SCM_CONSP (arg1)) + if (!scm_is_pair (arg1)) arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); - assert (!SCM_EQ_P (x, SCM_CAR (arg1)) - && !SCM_EQ_P (x, SCM_CDR (arg1))); + assert (!scm_is_eq (x, SCM_CAR (arg1)) + && !scm_is_eq (x, SCM_CDR (arg1))); #ifdef DEVAL if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) { - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; SCM_SETCAR (x, SCM_CAR (arg1)); SCM_SETCDR (x, SCM_CDR (arg1)); - SCM_ALLOW_INTS; + SCM_CRITICAL_SECTION_END; goto dispatch; } /* Prevent memoizing of debug info expression. */ @@ -3761,10 +4074,10 @@ dispatch: SCM_CAR (x), SCM_CDR (x)); #endif - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; SCM_SETCAR (x, SCM_CAR (arg1)); SCM_SETCDR (x, SCM_CDR (arg1)); - SCM_ALLOW_INTS; + SCM_CRITICAL_SECTION_END; PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto loop; #if SCM_ENABLE_DEPRECATED == 1 @@ -3801,7 +4114,7 @@ dispatch: * 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_NULLP (SCM_CDR (x))) { + if (scm_is_null (SCM_CDR (x))) { ENTER_APPLY; evap0: SCM_ASRTGO (!SCM_IMP (proc), badfun); @@ -3840,8 +4153,8 @@ dispatch: case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_CONSP (formals)) - goto umwrongnumargs; + if (scm_is_pair (formals)) + goto wrongnumargs; x = SCM_CLOSURE_BODY (proc); env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); goto nontoplevel_begin; @@ -3874,8 +4187,7 @@ dispatch: case scm_tc7_cxr: case scm_tc7_subr_3: case scm_tc7_lsubr_2: - umwrongnumargs: - unmemocar (x, env); + wrongnumargs: scm_wrong_num_args (proc); default: badfun: @@ -3885,7 +4197,7 @@ dispatch: /* must handle macros by here */ x = SCM_CDR (x); - if (SCM_CONSP (x)) + if (scm_is_pair (x)) arg1 = EVALCAR (x, env); else scm_wrong_num_args (proc); @@ -3895,7 +4207,7 @@ dispatch: x = SCM_CDR (x); { SCM arg2; - if (SCM_NULLP (x)) + if (scm_is_null (x)) { ENTER_APPLY; evap1: /* inputs: proc, arg1 */ @@ -3908,36 +4220,27 @@ dispatch: case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_dsubr: - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, + scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: - { - unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); - do - { - SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); - arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); - pattern >>= 2; - } while (pattern); - RETURN (arg1); - } + RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_rpsubr: RETURN (SCM_BOOL_T); case scm_tc7_asubr: @@ -3973,9 +4276,9 @@ dispatch: { /* clos1: */ const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals)))) - goto umwrongnumargs; + if (scm_is_null (formals) + || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals)))) + goto wrongnumargs; x = SCM_CLOSURE_BODY (proc); #ifdef DEVAL env = SCM_EXTEND_ENV (formals, @@ -4023,7 +4326,7 @@ dispatch: goto badfun; } } - if (SCM_CONSP (x)) + if (scm_is_pair (x)) arg2 = EVALCAR (x, env); else scm_wrong_num_args (proc); @@ -4033,7 +4336,7 @@ dispatch: debug.info->a.args = scm_list_2 (arg1, arg2); #endif x = SCM_CDR (x); - if (SCM_NULLP (x)) { + if (scm_is_null (x)) { ENTER_APPLY; evap2: SCM_ASRTGO (!SCM_IMP (proc), badfun); @@ -4127,12 +4430,12 @@ dispatch: { /* clos2: */ const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) - && (SCM_NULLP (SCM_CDR (formals)) - || (SCM_CONSP (SCM_CDR (formals)) - && SCM_CONSP (SCM_CDDR (formals)))))) - goto umwrongnumargs; + 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; #ifdef DEVAL env = SCM_EXTEND_ENV (formals, debug.info->a.args, @@ -4147,7 +4450,7 @@ dispatch: } } } - if (!SCM_CONSP (x)) + if (!scm_is_pair (x)) scm_wrong_num_args (proc); #ifdef DEVAL debug.info->a.args = scm_cons2 (arg1, arg2, @@ -4161,7 +4464,7 @@ dispatch: { /* have 3 or more arguments */ #ifdef DEVAL case scm_tc7_subr_3: - if (!SCM_NULLP (SCM_CDR (x))) + if (!scm_is_null (SCM_CDR (x))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, arg2, @@ -4177,12 +4480,12 @@ dispatch: while (SCM_NIMP (arg2)); RETURN (arg1); case scm_tc7_rpsubr: - if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) RETURN (SCM_BOOL_F); arg1 = SCM_CDDR (debug.info->a.args); do { - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) + if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) RETURN (SCM_BOOL_F); arg2 = SCM_CAR (arg1); arg1 = SCM_CDR (arg1); @@ -4210,12 +4513,12 @@ dispatch: case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) - && (SCM_NULLP (SCM_CDR (formals)) - || (SCM_CONSP (SCM_CDR (formals)) + 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 umwrongnumargs; + goto wrongnumargs; SCM_SET_ARGSREADY (debug); env = SCM_EXTEND_ENV (formals, debug.info->a.args, @@ -4225,7 +4528,7 @@ dispatch: } #else /* DEVAL */ case scm_tc7_subr_3: - if (!SCM_NULLP (SCM_CDR (x))) + if (!scm_is_null (SCM_CDR (x))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); @@ -4236,20 +4539,20 @@ dispatch: arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); x = SCM_CDR(x); } - while (!SCM_NULLP (x)); + while (!scm_is_null (x)); RETURN (arg1); case scm_tc7_rpsubr: - if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) RETURN (SCM_BOOL_F); do { arg1 = EVALCAR (x, env); - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) + if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1))) RETURN (SCM_BOOL_F); arg2 = arg1; x = SCM_CDR (x); } - while (!SCM_NULLP (x)); + while (!scm_is_null (x)); RETURN (SCM_BOOL_T); case scm_tc7_lsubr_2: RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); @@ -4272,12 +4575,12 @@ dispatch: case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) - && (SCM_NULLP (SCM_CDR (formals)) - || (SCM_CONSP (SCM_CDR (formals)) + 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 umwrongnumargs; + goto wrongnumargs; env = SCM_EXTEND_ENV (formals, scm_cons2 (arg1, arg2, @@ -4321,27 +4624,14 @@ exit: if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); - if (SCM_CHEAPTRAPS_P) - arg1 = scm_make_debugobj (&debug); - else - { - int first; - SCM val = scm_make_continuation (&first); - - if (first) - arg1 = val; - else - { - proc = val; - goto ret; - } - } + arg1 = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; - scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); + 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); } -ret: - scm_last_debug_frame = debug.prev; + scm_i_set_last_debug_frame (debug.prev); return proc; #endif } @@ -4449,7 +4739,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, SCM *lloc; SCM_VALIDATE_NONEMPTYLIST (1, lst); lloc = &lst; - while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be + while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be SCM_NULL_OR_NIL_P, but not needed in 99.99% of cases, and it could seriously hurt @@ -4497,12 +4787,12 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info debug_vect_body; - debug.prev = scm_last_debug_frame; + 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_last_debug_frame = &debug; + scm_i_set_last_debug_frame (&debug); #else if (scm_debug_mode_p) return scm_dapply (proc, arg1, args); @@ -4522,9 +4812,9 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) a relatively rare operation. This works for now; if the Guile developer archives are still around, see Mikael's post of 11-Apr-97. */ - if (SCM_NULLP (args)) + if (scm_is_null (args)) { - if (SCM_NULLP (arg1)) + if (scm_is_null (arg1)) { arg1 = SCM_UNDEFINED; #ifdef DEVAL @@ -4550,32 +4840,21 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) #ifdef DEVAL if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) { - SCM tmp; - if (SCM_CHEAPTRAPS_P) - tmp = scm_make_debugobj (&debug); - else - { - int first; - - tmp = scm_make_continuation (&first); - if (!first) - goto entap; - } + 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; } -entap: ENTER_APPLY; #endif tail: switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2o: - args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); + args = scm_is_null (args) ? SCM_UNDEFINED : SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: - if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args))) + if (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)); @@ -4588,49 +4867,39 @@ tail: if (SCM_UNBNDP (arg1)) scm_wrong_num_args (proc); case scm_tc7_subr_1o: - if (!SCM_NULLP (args)) + if (!scm_is_null (args)) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_dsubr: - if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) + if (SCM_UNBNDP (arg1) || !scm_is_null (args)) scm_wrong_num_args (proc); - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: - if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) + if (SCM_UNBNDP (arg1) || !scm_is_null (args)) scm_wrong_num_args (proc); - { - unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); - do - { - SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); - arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); - pattern >>= 2; - } while (pattern); - RETURN (arg1); - } + RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_subr_3: - if (SCM_NULLP (args) - || SCM_NULLP (SCM_CDR (args)) - || !SCM_NULLP (SCM_CDDR (args))) + if (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))); @@ -4641,27 +4910,27 @@ tail: RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); #endif case scm_tc7_lsubr_2: - if (!SCM_CONSP (args)) + if (!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_NULLP (args)) + if (scm_is_null (args)) RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); while (SCM_NIMP (args)) { - SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); + 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_rpsubr: - if (SCM_NULLP (args)) + if (scm_is_null (args)) RETURN (SCM_BOOL_T); while (SCM_NIMP (args)) { - SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); - if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (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); @@ -4682,7 +4951,7 @@ tail: else { SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); - for (arg1 = SCM_CDR (arg1); SCM_CONSP (arg1); arg1 = SCM_CDR (arg1)) + 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); @@ -4696,17 +4965,18 @@ tail: proc = SCM_CLOSURE_BODY (proc); again: arg1 = SCM_CDR (proc); - while (!SCM_NULLP (arg1)) + while (!scm_is_null (arg1)) { if (SCM_IMP (SCM_CAR (proc))) { if (SCM_ISYMP (SCM_CAR (proc))) { - scm_rec_mutex_lock (&source_mutex); + 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_rec_mutex_unlock (&source_mutex); + scm_dynwind_end (); goto again; } else @@ -4723,9 +4993,9 @@ tail: goto badproc; if (SCM_UNBNDP (arg1)) RETURN (SCM_SMOB_APPLY_0 (proc)); - else if (SCM_NULLP (args)) + else if (scm_is_null (args)) RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); - else if (SCM_NULLP (SCM_CDR (args))) + 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))); @@ -4791,27 +5061,14 @@ exit: if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); - if (SCM_CHEAPTRAPS_P) - arg1 = scm_make_debugobj (&debug); - else - { - int first; - SCM val = scm_make_continuation (&first); - - if (first) - arg1 = val; - else - { - proc = val; - goto ret; - } - } + arg1 = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; - scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); + 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); } -ret: - scm_last_debug_frame = debug.prev; + scm_i_set_last_debug_frame (debug.prev); return proc; #endif } @@ -4887,7 +5144,7 @@ scm_trampoline_0 (SCM proc) case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) || !SCM_CONSP (formals)) + if (scm_is_null (formals) || !scm_is_pair (formals)) trampoline = scm_i_call_closure_0; else return NULL; @@ -4947,38 +5204,30 @@ call_lsubr_1 (SCM proc, SCM arg1) static SCM call_dsubr_1 (SCM proc, SCM arg1) { - if (SCM_INUMP (arg1)) + if (SCM_I_INUMP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); + RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); } static SCM call_cxr_1 (SCM proc, SCM arg1) { - unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); - do - { - SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, - SCM_SYMBOL_CHARS (SCM_SNAME (proc))); - arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); - pattern >>= 2; - } while (pattern); - return arg1; + return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)); } static SCM @@ -5020,8 +5269,8 @@ scm_trampoline_1 (SCM proc) case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); - if (!SCM_NULLP (formals) - && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) + if (!scm_is_null (formals) + && (!scm_is_pair (formals) || !scm_is_pair (SCM_CDR (formals)))) trampoline = call_closure_1; else return NULL; @@ -5113,11 +5362,11 @@ scm_trampoline_2 (SCM proc) case scm_tcs_closures: { SCM formals = SCM_CLOSURE_FORMALS (proc); - if (!SCM_NULLP (formals) - && (!SCM_CONSP (formals) - || (!SCM_NULLP (SCM_CDR (formals)) - && (!SCM_CONSP (SCM_CDR (formals)) - || !SCM_CONSP (SCM_CDDR (formals)))))) + 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)))))) trampoline = call_closure_2; else return NULL; @@ -5167,26 +5416,24 @@ check_map_args (SCM argv, SCM args, const char *who) { - SCM const *ve = SCM_VELTS (argv); long i; - for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) + for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--) { - long elt_len = scm_ilength (ve[i]); + SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i); + long elt_len = scm_ilength (elt); if (elt_len < 0) { if (gf) scm_apply_generic (gf, scm_cons (proc, args)); else - scm_wrong_type_arg (who, i + 2, ve[i]); + scm_wrong_type_arg (who, i + 2, elt); } if (elt_len != len) - scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2)); + scm_out_of_range_pos (who, elt, scm_from_long (i + 2)); } - - scm_remember_upto_here_1 (argv); } @@ -5206,13 +5453,12 @@ scm_map (SCM proc, SCM arg1, SCM args) long i, len; SCM res = SCM_EOL; SCM *pres = &res; - SCM const *ve = &args; /* Keep args from being optimized away. */ len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map); SCM_VALIDATE_REST_ARGUMENT (args); - if (SCM_NULLP (args)) + if (scm_is_null (args)) { scm_t_trampoline_1 call = scm_trampoline_1 (proc); SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map); @@ -5224,7 +5470,7 @@ scm_map (SCM proc, SCM arg1, SCM args) } return res; } - if (SCM_NULLP (SCM_CDR (args))) + if (scm_is_null (SCM_CDR (args))) { SCM arg2 = SCM_CAR (args); int len2 = scm_ilength (arg2); @@ -5246,17 +5492,17 @@ scm_map (SCM proc, SCM arg1, SCM args) } arg1 = scm_cons (arg1, args); args = scm_vector (arg1); - ve = SCM_VELTS (args); check_map_args (args, len, g_map, proc, arg1, s_map); while (1) { arg1 = SCM_EOL; - for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) + for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) { - if (SCM_IMP (ve[i])) + SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); + if (SCM_IMP (elt)) return res; - arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); + arg1 = scm_cons (SCM_CAR (elt), arg1); + SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt)); } *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL)); pres = SCM_CDRLOC (*pres); @@ -5271,13 +5517,12 @@ SCM scm_for_each (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_for_each { - SCM const *ve = &args; /* Keep args from being optimized away. */ long i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); SCM_VALIDATE_REST_ARGUMENT (args); - if (SCM_NULLP (args)) + if (scm_is_null (args)) { scm_t_trampoline_1 call = scm_trampoline_1 (proc); SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each); @@ -5288,7 +5533,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) } return SCM_UNSPECIFIED; } - if (SCM_NULLP (SCM_CDR (args))) + if (scm_is_null (SCM_CDR (args))) { SCM arg2 = SCM_CAR (args); int len2 = scm_ilength (arg2); @@ -5309,17 +5554,17 @@ scm_for_each (SCM proc, SCM arg1, SCM args) } arg1 = scm_cons (arg1, args); args = scm_vector (arg1); - ve = SCM_VELTS (args); check_map_args (args, len, g_for_each, proc, arg1, s_for_each); while (1) { arg1 = SCM_EOL; - for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) + for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) { - if (SCM_IMP (ve[i])) + SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); + if (SCM_IMP (elt)) return SCM_UNSPECIFIED; - arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); + arg1 = scm_cons (SCM_CAR (elt), arg1); + SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt)); } scm_apply (proc, arg1, SCM_EOL); } @@ -5345,13 +5590,19 @@ scm_makprom (SCM code) { SCM_RETURN_NEWSMOB2 (scm_tc16_promise, SCM_UNPACK (code), - scm_make_rec_mutex ()); + scm_make_recursive_mutex ()); +} + +static SCM +promise_mark (SCM promise) +{ + scm_gc_mark (SCM_PROMISE_MUTEX (promise)); + return SCM_PROMISE_DATA (promise); } static size_t promise_free (SCM promise) { - scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise)); return 0; } @@ -5375,7 +5626,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, #define FUNC_NAME s_scm_force { SCM_VALIDATE_SMOB (1, promise, promise); - scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise)); + scm_lock_mutex (SCM_PROMISE_MUTEX (promise)); if (!SCM_PROMISE_COMPUTED_P (promise)) { SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); @@ -5385,7 +5636,7 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, SCM_SET_PROMISE_COMPUTED (promise); } } - scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise)); + scm_unlock_mutex (SCM_PROMISE_MUTEX (promise)); return SCM_PROMISE_DATA (promise); } #undef FUNC_NAME @@ -5397,7 +5648,7 @@ SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).") #define FUNC_NAME s_scm_promise_p { - return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); + return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj)); } #undef FUNC_NAME @@ -5413,7 +5664,7 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, z = scm_cons (x, y); /* Copy source properties possibly associated with xorig. */ p = scm_whash_lookup (scm_source_whash, xorig); - if (!SCM_IMP (p)) + if (scm_is_true (p)) scm_whash_insert (scm_source_whash, z, p); return z; } @@ -5447,8 +5698,8 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, * hare-and-tortoise implementation, found several times in guile. */ struct t_trace { - struct t_trace *trace; // These pointers form a trace along the stack. - SCM obj; // The object handled at the respective stack frame. + struct t_trace *trace; /* These pointers form a trace along the stack. */ + SCM obj; /* The object handled at the respective stack frame.*/ }; static SCM @@ -5457,7 +5708,7 @@ copy_tree ( struct t_trace *tortoise, unsigned int tortoise_delay ) { - if (!SCM_CONSP (hare->obj) && !SCM_VECTORP (hare->obj)) + if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj)) { return hare->obj; } @@ -5477,7 +5728,7 @@ copy_tree ( { tortoise_delay = 1; tortoise = tortoise->trace; - ASSERT_SYNTAX (!SCM_EQ_P (hare->obj, tortoise->obj), + ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj), s_bad_expression, hare->obj); } else @@ -5485,10 +5736,10 @@ copy_tree ( --tortoise_delay; } - if (SCM_VECTORP (hare->obj)) + if (scm_is_simple_vector (hare->obj)) { - const unsigned long int length = SCM_VECTOR_LENGTH (hare->obj); - const SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED); + size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj); + SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED); /* Each vector element is copied by recursing into copy_tree, having * the tortoise follow the hare into the depths of the stack. */ @@ -5496,14 +5747,14 @@ copy_tree ( for (i = 0; i < length; ++i) { SCM new_element; - new_hare.obj = SCM_VECTOR_REF (hare->obj, i); + new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i); new_element = copy_tree (&new_hare, tortoise, tortoise_delay); - SCM_VECTOR_SET (new_vector, i, new_element); + SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element); } return new_vector; } - else // SCM_CONSP (hare->obj) + else /* scm_is_pair (hare->obj) */ { SCM result; SCM tail; @@ -5524,7 +5775,7 @@ copy_tree ( * having the turtle follow the rabbit, and, vertically, having the * tortoise follow the hare into the depths of the stack. */ rabbit = SCM_CDR (rabbit); - while (SCM_CONSP (rabbit)) + while (scm_is_pair (rabbit)) { new_hare.obj = SCM_CAR (rabbit); copy = copy_tree (&new_hare, tortoise, tortoise_delay); @@ -5532,7 +5783,7 @@ copy_tree ( tail = SCM_CDR (tail); rabbit = SCM_CDR (rabbit); - if (SCM_CONSP (rabbit)) + if (scm_is_pair (rabbit)) { new_hare.obj = SCM_CAR (rabbit); copy = copy_tree (&new_hare, tortoise, tortoise_delay); @@ -5541,7 +5792,7 @@ copy_tree ( rabbit = SCM_CDR (rabbit); turtle = SCM_CDR (turtle); - ASSERT_SYNTAX (!SCM_EQ_P (rabbit, turtle), + ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle), s_bad_expression, rabbit); } } @@ -5598,13 +5849,15 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, environment and calling scm_i_eval. Thus, changes to the top-level module are tracked normally. - - scm_eval (exp, mod) + - scm_eval (exp, mod_or_state) - evaluates EXP while MOD is the current module. This is done by - setting the current module to MOD, 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 are tracked, but these changes do not persist when + 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 @@ -5619,20 +5872,20 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, SCM scm_i_eval_x (SCM exp, SCM env) { - if (SCM_SYMBOLP (exp)) + if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else - return SCM_XEVAL (exp, env); + return SCM_I_XEVAL (exp, env); } SCM scm_i_eval (SCM exp, SCM env) { exp = scm_copy_tree (exp); - if (SCM_SYMBOLP (exp)) + if (scm_is_symbol (exp)) return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1); else - return SCM_XEVAL (exp, env); + return SCM_I_XEVAL (exp, env); } SCM @@ -5654,7 +5907,7 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, { SCM env; SCM transformer = scm_current_module_transformer (); - if (SCM_NIMP (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); @@ -5667,66 +5920,47 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0, * system, where we would like to make the choice of evaluation * environment explicit. */ -static void -change_environment (void *data) -{ - SCM pair = SCM_PACK (data); - SCM new_module = SCM_CAR (pair); - SCM old_module = scm_current_module (); - SCM_SETCDR (pair, old_module); - scm_set_current_module (new_module); -} - -static void -restore_environment (void *data) -{ - SCM pair = SCM_PACK (data); - SCM old_module = SCM_CDR (pair); - SCM new_module = scm_current_module (); - SCM_SETCAR (pair, new_module); - scm_set_current_module (old_module); -} - -static SCM -inner_eval_x (void *data) -{ - return scm_primitive_eval_x (SCM_PACK(data)); -} - SCM -scm_eval_x (SCM exp, SCM module) -#define FUNC_NAME "eval!" +scm_eval_x (SCM exp, SCM module_or_state) { - SCM_VALIDATE_MODULE (2, module); + SCM res; - return scm_internal_dynamic_wind - (change_environment, inner_eval_x, restore_environment, - (void *) SCM_UNPACK (exp), - (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F))); -} -#undef FUNC_NAME + 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); -static SCM -inner_eval (void *data) -{ - return scm_primitive_eval (SCM_PACK(data)); + res = scm_primitive_eval_x (exp); + + scm_dynwind_end (); + return res; } SCM_DEFINE (scm_eval, "eval", 2, 0, 0, - (SCM exp, SCM module), + (SCM exp, SCM module_or_state), "Evaluate @var{exp}, a list representing a Scheme expression,\n" - "in the top-level environment specified by @var{module}.\n" + "in the top-level environment specified by\n" + "@var{module_or_state}.\n" "While @var{exp} is evaluated (using @code{primitive-eval}),\n" - "@var{module} is made the current module. The current module\n" - "is reset to its previous value when @var{eval} returns.") + "@var{module_or_state} is made the current module when\n" + "it is a module, or the current dynamic state when it is\n" + "a dynamic state." + "Example: (eval '(+ 1 2) (interaction-environment))") #define FUNC_NAME s_scm_eval { - SCM_VALIDATE_MODULE (2, module); + SCM res; - return scm_internal_dynamic_wind - (change_environment, inner_eval, restore_environment, - (void *) SCM_UNPACK (exp), - (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F))); + 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 (exp); + + scm_dynwind_end (); + return res; } #undef FUNC_NAME @@ -5743,23 +5977,23 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, /* Deprecated in guile 1.7.0 on 2004-03-29. */ SCM scm_ceval (SCM x, SCM env) { - if (SCM_CONSP (x)) + if (scm_is_pair (x)) return ceval (x, env); - else if (SCM_SYMBOLP (x)) + else if (scm_is_symbol (x)) return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); else - return SCM_XEVAL (x, env); + return SCM_I_XEVAL (x, env); } /* Deprecated in guile 1.7.0 on 2004-03-29. */ SCM scm_deval (SCM x, SCM env) { - if (SCM_CONSP (x)) + if (scm_is_pair (x)) return deval (x, env); - else if (SCM_SYMBOLP (x)) + else if (scm_is_symbol (x)) return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1); else - return SCM_XEVAL (x, env); + return SCM_I_XEVAL (x, env); } static SCM @@ -5780,6 +6014,9 @@ SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval; 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_N_EVALUATOR_TRAPS); @@ -5788,7 +6025,7 @@ scm_init_eval () SCM_N_EVAL_OPTIONS); scm_tc16_promise = scm_make_smob_type ("promise", 0); - scm_set_smob_mark (scm_tc16_promise, scm_markcdr); + scm_set_smob_mark (scm_tc16_promise, promise_mark); scm_set_smob_free (scm_tc16_promise, promise_free); scm_set_smob_print (scm_tc16_promise, promise_print);