/* * eval.i.c - actual evaluator code for GUILE * * Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of * the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA * 02110-1301 USA */ #undef RETURN #undef ENTER_APPLY #undef PREP_APPLY #undef CEVAL #undef SCM_APPLY #undef EVAL_DEBUGGING_P #ifdef DEVAL /* This code is specific for the debugging support. */ #define EVAL_DEBUGGING_P 1 #define CEVAL deval /* Substitute all uses of ceval */ #define SCM_APPLY scm_dapply #define PREP_APPLY(p, l) \ { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } #define ENTER_APPLY \ do { \ SCM_SET_ARGSREADY (debug);\ if (scm_check_apply_p && SCM_TRAPS_P)\ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\ {\ SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ SCM_SET_TRACED_FRAME (debug); \ SCM_TRAPS_P = 0;\ tmp = scm_make_debugobj (&debug);\ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ SCM_TRAPS_P = 1;\ }\ } while (0) #define RETURN(e) do { proc = (e); goto exit; } while (0) #ifdef STACK_CHECKING # ifndef EVAL_STACK_CHECKING # define EVAL_STACK_CHECKING # endif /* EVAL_STACK_CHECKING */ #endif /* STACK_CHECKING */ static SCM deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc; while (scm_is_pair (l)) { const SCM res = SCM_I_XEVALCAR (l, env, 1); *lloc = scm_list_1 (res); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } if (!scm_is_null (l)) scm_wrong_num_args (proc); return *results; } #else /* DEVAL */ /* Code is specific to debugging-less support. */ #define CEVAL ceval #define SCM_APPLY scm_apply #define PREP_APPLY(proc, args) #define ENTER_APPLY #define RETURN(x) do { return x; } while (0) #define EVAL_DEBUGGING_P 0 #ifdef STACK_CHECKING # ifndef NO_CEVAL_STACK_CHECKING # define EVAL_STACK_CHECKING # endif #endif static void ceval_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) { ceval_letrec_inits (env, init_forms, init_values_eol); break; } argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0); 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); } } static SCM scm_ceval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; while (scm_is_pair (l)) { res = EVALCAR (l, env); *lloc = scm_list_1 (res); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } if (!scm_is_null (l)) scm_wrong_num_args (proc); return results; } SCM scm_eval_args (SCM l, SCM env, SCM proc) { return scm_ceval_args (l, env, proc); } #endif #define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P) #define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P) /* Update the toplevel environment frame ENV so that it refers to the * current module. */ #define UPDATE_TOPLEVEL_ENV(env) \ do { \ SCM p = scm_current_module_lookup_closure (); \ if (p != SCM_CAR (env)) \ env = scm_top_level_env (p); \ } while (0) #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) /* This is the evaluator. Like any real monster, it has three heads: * * ceval is the non-debugging evaluator, deval is the debugging version. Both * are implemented using a common code base, using the following mechanism: * CEVAL is a macro, which is either defined to ceval or deval. Thus, there * is no function CEVAL, but the code for CEVAL actually compiles to either * ceval or deval. When CEVAL is defined to ceval, it is known that the macro * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL * is known to be defined. Thus, in CEVAL parts for the debugging evaluator * are enclosed within #ifdef DEVAL ... #endif. * * All three (ceval, deval and their common implementation CEVAL) take two * input parameters, x and env: x is a single expression to be evalutated. * env is the environment in which bindings are searched. * * x is known to be a pair. Since x is a single expression, it is necessarily * in a tail position. If x is just a call to another function like in the * expression (foo exp1 exp2 ...), the realization of that call therefore * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc., * however, may do so). This is realized by making extensive use of 'goto' * statements within the evaluator: The gotos replace recursive calls to * CEVAL, thus re-using the same stack frame that CEVAL was already using. * If, however, x represents some form that requires to evaluate a sequence of * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are * performed for all but the last expression of that sequence. */ static SCM CEVAL (SCM x, SCM env) { SCM proc, arg1; #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info *debug_info_end; debug.prev = scm_i_last_debug_frame (); debug.status = 0; /* * The debug.vect contains twice as much scm_t_debug_info frames as the * user has specified with (debug-set! frames ). * * Even frames are eval frames, odd frames are apply frames. */ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size * sizeof (scm_t_debug_info)); debug.info = debug.vect; debug_info_end = debug.vect + scm_debug_eframe_size; scm_i_set_last_debug_frame (&debug); #endif #ifdef EVAL_STACK_CHECKING if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) { #ifdef DEVAL debug.info->e.exp = x; debug.info->e.env = env; #endif scm_report_stack_overflow (); } #endif #ifdef DEVAL goto start; #endif loop: #ifdef DEVAL SCM_CLEAR_ARGSREADY (debug); if (SCM_OVERFLOWP (debug)) --debug.info; /* * In theory, this should be the only place where it is necessary to * check for space in debug.vect since both eval frames and * available space are even. * * For this to be the case, however, it is necessary that primitive * special forms which jump back to `loop', `begin' or some similar * label call PREP_APPLY. */ else if (++debug.info >= debug_info_end) { SCM_SET_OVERFLOW (debug); debug.info -= 2; } start: debug.info->e.exp = x; debug.info->e.env = env; if (scm_check_entry_p && SCM_TRAPS_P) { if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) { SCM stackrep; SCM tail = scm_from_bool (SCM_TAILRECP (debug)); SCM_SET_TAILREC (debug); stackrep = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, stackrep, tail, unmemoize_expression (x, env)); SCM_TRAPS_P = 1; if (scm_is_pair (stackrep) && scm_is_eq (SCM_CAR (stackrep), sym_instead)) { /* This gives the possibility for the debugger to modify the source expression before evaluation. */ x = SCM_CDR (stackrep); if (SCM_IMP (x)) RETURN (x); } } } #endif dispatch: SCM_TICK; if (SCM_ISYMP (SCM_CAR (x))) { switch (ISYMNUM (SCM_CAR (x))) { case (ISYMNUM (SCM_IM_AND)): x = SCM_CDR (x); while (!scm_is_null (SCM_CDR (x))) { SCM test_result = EVALCAR (x, env); if (scm_is_false (test_result) || SCM_NILP (test_result)) RETURN (SCM_BOOL_F); else x = SCM_CDR (x); } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; case (ISYMNUM (SCM_IM_BEGIN)): x = SCM_CDR (x); if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); begin: /* If we are on toplevel with a lookup closure, we need to sync with the current module. */ if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env))) { UPDATE_TOPLEVEL_ENV (env); while (!scm_is_null (SCM_CDR (x))) { EVALCAR (x, env); UPDATE_TOPLEVEL_ENV (env); x = SCM_CDR (x); } goto carloop; } else goto nontoplevel_begin; nontoplevel_begin: while (!scm_is_null (SCM_CDR (x))) { const SCM form = SCM_CAR (x); if (SCM_IMP (form)) { if (SCM_ISYMP (form)) { scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (x))) m_expand_body (x, env); scm_dynwind_end (); goto nontoplevel_begin; } else SCM_VALIDATE_NON_EMPTY_COMBINATION (form); } else (void) EVAL (form, env); x = SCM_CDR (x); } carloop: { /* scm_eval last form in list */ const SCM last_form = SCM_CAR (x); if (scm_is_pair (last_form)) { /* This is by far the most frequent case. */ x = last_form; goto loop; /* tail recurse */ } else if (SCM_IMP (last_form)) RETURN (SCM_I_EVALIM (last_form, env)); else if (SCM_VARIABLEP (last_form)) RETURN (SCM_VARIABLE_REF (last_form)); else if (scm_is_symbol (last_form)) RETURN (*scm_lookupcar (x, env, 1)); else RETURN (last_form); } case (ISYMNUM (SCM_IM_CASE)): x = SCM_CDR (x); { const SCM key = EVALCAR (x, env); x = SCM_CDR (x); while (!scm_is_null (x)) { const SCM clause = SCM_CAR (x); SCM labels = SCM_CAR (clause); if (scm_is_eq (labels, SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } while (!scm_is_null (labels)) { const SCM label = SCM_CAR (labels); if (scm_is_eq (label, key) || scm_is_true (scm_eqv_p (label, key))) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } labels = SCM_CDR (labels); } x = SCM_CDR (x); } } RETURN (SCM_UNSPECIFIED); case (ISYMNUM (SCM_IM_COND)): x = SCM_CDR (x); while (!scm_is_null (x)) { const SCM clause = SCM_CAR (x); if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } else { arg1 = EVALCAR (clause, env); /* SRFI 61 extended cond */ if (!scm_is_null (SCM_CDR (clause)) && !scm_is_null (SCM_CDDR (clause)) && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW)) { SCM xx, guard_result; if (SCM_VALUESP (arg1)) arg1 = scm_struct_ref (arg1, SCM_INUM0); else arg1 = scm_list_1 (arg1); xx = SCM_CDR (clause); proc = EVALCAR (xx, env); guard_result = SCM_APPLY (proc, arg1, SCM_EOL); if (scm_is_true (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_is_null (x)) RETURN (arg1); else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } else { proc = SCM_CDR (x); proc = EVALCAR (proc, env); PREP_APPLY (proc, scm_list_1 (arg1)); ENTER_APPLY; goto evap1; } } x = SCM_CDR (x); } } RETURN (SCM_UNSPECIFIED); case (ISYMNUM (SCM_IM_DO)): x = SCM_CDR (x); { /* Compute the initialization values and the initial environment. */ SCM init_forms = SCM_CAR (x); SCM init_values = SCM_EOL; while (!scm_is_null (init_forms)) { init_values = scm_cons (EVALCAR (init_forms, env), init_values); init_forms = SCM_CDR (init_forms); } x = SCM_CDR (x); env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); } x = SCM_CDR (x); { SCM test_form = SCM_CAR (x); SCM body_forms = SCM_CADR (x); SCM step_forms = SCM_CDDR (x); SCM test_result = EVALCAR (test_form, env); while (scm_is_false (test_result) || SCM_NILP (test_result)) { { /* Evaluate body forms. */ SCM temp_forms; for (temp_forms = body_forms; !scm_is_null (temp_forms); temp_forms = SCM_CDR (temp_forms)) { SCM form = SCM_CAR (temp_forms); /* Dirk:FIXME: We only need to eval forms that may have * a side effect here. This is only true for forms that * start with a pair. All others are just constants. * Since with the current memoizer 'form' may hold a * constant, we call EVAL here to handle the constant * cases. In the long run it would make sense to have * the macro transformer of 'do' eliminate all forms * that have no sideeffect. Then instead of EVAL we * could call CEVAL directly here. */ (void) EVAL (form, env); } } { /* Evaluate the step expressions. */ SCM temp_forms; SCM step_values = SCM_EOL; for (temp_forms = step_forms; !scm_is_null (temp_forms); temp_forms = SCM_CDR (temp_forms)) { const SCM value = EVALCAR (temp_forms, env); step_values = scm_cons (value, step_values); } env = SCM_EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env)); } test_result = EVALCAR (test_form, env); } } x = SCM_CDAR (x); if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; case (ISYMNUM (SCM_IM_IF)): x = SCM_CDR (x); { SCM test_result = EVALCAR (x, env); x = SCM_CDR (x); /* then expression */ if (scm_is_false (test_result) || SCM_NILP (test_result)) { x = SCM_CDR (x); /* else expression */ if (scm_is_null (x)) RETURN (SCM_UNSPECIFIED); } } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; case (ISYMNUM (SCM_IM_LET)): x = SCM_CDR (x); { SCM init_forms = SCM_CADR (x); SCM init_values = SCM_EOL; do { init_values = scm_cons (EVALCAR (init_forms, env), init_values); init_forms = SCM_CDR (init_forms); } while (!scm_is_null (init_forms)); env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); } x = SCM_CDDR (x); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; case (ISYMNUM (SCM_IM_LETREC)): x = SCM_CDR (x); env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env); x = SCM_CDR (x); { SCM init_forms = SCM_CAR (x); SCM init_values = scm_list_1 (SCM_BOOL_T); SCM *init_values_eol = SCM_CDRLOC (init_values); ceval_letrec_inits (env, init_forms, &init_values_eol); SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values)); } x = SCM_CDR (x); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; case (ISYMNUM (SCM_IM_LETSTAR)): x = SCM_CDR (x); { SCM bindings = SCM_CAR (x); if (!scm_is_null (bindings)) { do { SCM name = SCM_CAR (bindings); SCM init = SCM_CDR (bindings); env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); bindings = SCM_CDR (init); } while (!scm_is_null (bindings)); } } x = SCM_CDR (x); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; case (ISYMNUM (SCM_IM_OR)): x = SCM_CDR (x); while (!scm_is_null (SCM_CDR (x))) { SCM val = EVALCAR (x, env); if (scm_is_true (val) && !SCM_NILP (val)) RETURN (val); else x = SCM_CDR (x); } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; case (ISYMNUM (SCM_IM_LAMBDA)): RETURN (scm_closure (SCM_CDR (x), env)); case (ISYMNUM (SCM_IM_QUOTE)): RETURN (SCM_CDR (x)); case (ISYMNUM (SCM_IM_SET_X)): x = SCM_CDR (x); { SCM *location; SCM variable = SCM_CAR (x); if (SCM_ILOCP (variable)) location = scm_ilookup (variable, env); else if (SCM_VARIABLEP (variable)) location = SCM_VARIABLE_LOC (variable); else { /* (scm_is_symbol (variable)) is known to be true */ variable = lazy_memoize_variable (variable, env); SCM_SETCAR (x, variable); location = SCM_VARIABLE_LOC (variable); } x = SCM_CDR (x); *location = EVALCAR (x, env); } RETURN (SCM_UNSPECIFIED); case (ISYMNUM (SCM_IM_APPLY)): /* Evaluate the procedure to be applied. */ x = SCM_CDR (x); proc = EVALCAR (x, env); PREP_APPLY (proc, SCM_EOL); /* Evaluate the argument holding the list of arguments */ x = SCM_CDR (x); arg1 = EVALCAR (x, env); apply_proc: /* Go here to tail-apply a procedure. PROC is the procedure and * ARG1 is the list of arguments. PREP_APPLY must have been called * before jumping to apply_proc. */ if (SCM_CLOSUREP (proc)) { SCM formals = SCM_CLOSURE_FORMALS (proc); #ifdef DEVAL debug.info->a.args = arg1; #endif if (SCM_UNLIKELY (scm_badargsp (formals, arg1))) scm_wrong_num_args (proc); ENTER_APPLY; /* Copy argument list */ if (SCM_NULL_OR_NIL_P (arg1)) env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); else { SCM args = scm_list_1 (SCM_CAR (arg1)); SCM tail = args; arg1 = SCM_CDR (arg1); while (!SCM_NULL_OR_NIL_P (arg1)) { SCM new_tail = scm_list_1 (SCM_CAR (arg1)); SCM_SETCDR (tail, new_tail); tail = new_tail; arg1 = SCM_CDR (arg1); } env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc)); } x = SCM_CLOSURE_BODY (proc); goto nontoplevel_begin; } else { ENTER_APPLY; RETURN (SCM_APPLY (proc, arg1, SCM_EOL)); } case (ISYMNUM (SCM_IM_CONT)): { int first; SCM val = scm_make_continuation (&first); if (!first) RETURN (val); else { arg1 = val; proc = SCM_CDR (x); proc = EVALCAR (proc, env); PREP_APPLY (proc, scm_list_1 (arg1)); ENTER_APPLY; goto evap1; } } case (ISYMNUM (SCM_IM_DELAY)): RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env))); #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 clause for the internal macro SCM_IM_DISPATCH. Please don't remove it from this location without discussing it with Mikael */ /* The type dispatch code is duplicated below * (c.f. objects.c:scm_mcache_compute_cmethod) since that * cuts down execution time for type dispatch to 50%. */ type_dispatch: /* inputs: x, arg1 */ /* Type dispatch means to determine from the types of the function * arguments (i. e. the 'signature' of the call), which method from * a generic function is to be called. This process of selecting * the right method takes some time. To speed it up, guile uses * caching: Together with the macro call to dispatch the signatures * of some previous calls to that generic function from the same * place are stored (in the code!) in a cache that we call the * 'method cache'. This is done since it is likely, that * consecutive calls to dispatch from that position in the code will * have the same signature. Thus, the type dispatch works as * follows: First, determine a hash value from the signature of the * actual arguments. Second, use this hash value as an index to * find that same signature in the method cache stored at this * position in the code. If found, you have also found the * corresponding method that belongs to that signature. If the * signature is not found in the method cache, you have to perform a * full search over all signatures stored with the generic * function. */ { unsigned long int specializers; unsigned long int hash_value; unsigned long int cache_end_pos; unsigned long int mask; SCM method_cache; { SCM z = SCM_CDDR (x); SCM tmp = SCM_CADR (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_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 * an array of random numbers, that are determined when the * class is created. The integer 'hashset' is an index into * that array of random numbers. Now, from all classes that * are part of the signature of the actual arguments, the * random numbers at index 'hashset' are taken and summed * up, giving the hash value. The value of 'hashset' is * stored at the call to dispatch. This allows to have * different 'formulas' for calculating the hash value at * different places where dispatch is called. This allows * to optimize the hash formula at every individual place * 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_to_ulong (tmp); unsigned long int counter = specializers + 1; SCM tmp_arg = arg1; hash_value = 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); tmp_arg = SCM_CDR (tmp_arg); counter--; } z = SCM_CDDR (z); method_cache = SCM_CADR (z); mask = scm_to_ulong (SCM_CAR (z)); hash_value &= mask; cache_end_pos = hash_value; } } { /* Search the method cache for a method with a matching * signature. Start the search at position 'hash_value'. The * hashing implementation uses linear probing for conflict * resolution, that is, if the signature in question is not * found at the starting index in the hash table, the next table * entry is tried, and so on, until in the worst case the whole * cache has been searched, but still the signature has not been * found. */ SCM z; do { SCM args = arg1; /* list of arguments */ 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_is_eq (class_of_arg, SCM_CAR (z))) goto next_method; args = SCM_CDR (args); z = SCM_CDR (z); } /* Fewer arguments than specifiers => CAR != CLASS */ if (!scm_is_pair (z)) goto apply_vm_cmethod; else if (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))) goto apply_memoized_cmethod; next_method: hash_value = (hash_value + 1) & mask; } while (hash_value != cache_end_pos); /* No appropriate method was found in the cache. */ z = scm_memoize_method (x, arg1); if (scm_is_pair (z)) goto apply_memoized_cmethod; apply_vm_cmethod: proc = z; PREP_APPLY (proc, arg1); goto apply_proc; apply_memoized_cmethod: /* inputs: z, arg1 */ { SCM formals = SCM_CMETHOD_FORMALS (z); env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); x = SCM_CMETHOD_BODY (z); goto nontoplevel_begin; } } } case (ISYMNUM (SCM_IM_SLOT_REF)): x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); } case (ISYMNUM (SCM_IM_SLOT_SET_X)): x = SCM_CDR (x); { SCM instance = EVALCAR (x, env); unsigned long int slot = SCM_I_INUM (SCM_CADR (x)); SCM value = EVALCAR (SCM_CDDR (x), env); SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); RETURN (SCM_UNSPECIFIED); } #if SCM_ENABLE_ELISP case (ISYMNUM (SCM_IM_NIL_COND)): { SCM test_form = SCM_CDR (x); x = SCM_CDR (test_form); while (!SCM_NULL_OR_NIL_P (x)) { SCM test_result = EVALCAR (test_form, env); if (!(scm_is_false (test_result) || SCM_NULL_OR_NIL_P (test_result))) { if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (test_result); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; } else { test_form = SCM_CDR (x); x = SCM_CDR (test_form); } } x = test_form; PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; } #endif /* SCM_ENABLE_ELISP */ case (ISYMNUM (SCM_IM_BIND)): { SCM vars, exps, vals; x = SCM_CDR (x); vars = SCM_CAAR (x); exps = SCM_CDAR (x); vals = SCM_EOL; while (!scm_is_null (exps)) { vals = scm_cons (EVALCAR (exps, env), vals); exps = SCM_CDR (exps); } scm_swap_bindings (vars, vals); scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ())); /* Ignore all but the last evaluation result. */ for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x)) { if (scm_is_pair (SCM_CAR (x))) CEVAL (SCM_CAR (x), env); } proc = EVALCAR (x, env); scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); scm_swap_bindings (vars, vals); RETURN (proc); } case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): { SCM producer; x = SCM_CDR (x); producer = EVALCAR (x, env); x = SCM_CDR (x); proc = EVALCAR (x, env); /* proc is the consumer. */ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); if (SCM_VALUESP (arg1)) { /* The list of arguments is not copied. Rather, it is assumed * that this has been done by the 'values' procedure. */ arg1 = scm_struct_ref (arg1, SCM_INUM0); } else { arg1 = scm_list_1 (arg1); } PREP_APPLY (proc, arg1); goto apply_proc; } default: break; } } else { if (SCM_VARIABLEP (SCM_CAR (x))) proc = SCM_VARIABLE_REF (SCM_CAR (x)); else if (SCM_ILOCP (SCM_CAR (x))) proc = *scm_ilookup (SCM_CAR (x), env); else if (scm_is_pair (SCM_CAR (x))) proc = CEVAL (SCM_CAR (x), env); else if (scm_is_symbol (SCM_CAR (x))) { SCM orig_sym = SCM_CAR (x); { SCM *location = scm_lookupcar1 (x, env, 1); if (location == NULL) { /* we have lost the race, start again. */ goto dispatch; } proc = *location; #ifdef DEVAL if (scm_check_memoize_p && SCM_TRAPS_P) { SCM_CLEAR_TRACED_FRAME (debug); SCM arg1 = scm_make_debugobj (&debug); SCM retval = SCM_BOOL_T; SCM_TRAPS_P = 0; retval = scm_call_4 (SCM_MEMOIZE_HDLR, scm_sym_memoize_symbol, arg1, x, env); /* do something with retval? */ SCM_TRAPS_P = 1; } #endif } if (SCM_MACROP (proc)) { SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ handle_a_macro: /* inputs: x, env, proc */ #ifdef DEVAL /* Set a flag during macro expansion so that macro application frames can be deleted from the backtrace. */ SCM_SET_MACROEXP (debug); #endif arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif switch (SCM_MACRO_TYPE (proc)) { case 3: case 2: if (!scm_is_pair (arg1)) arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); assert (!scm_is_eq (x, SCM_CAR (arg1)) && !scm_is_eq (x, SCM_CDR (arg1))); #ifdef DEVAL if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) { SCM_CRITICAL_SECTION_START; SCM_SETCAR (x, SCM_CAR (arg1)); SCM_SETCDR (x, SCM_CDR (arg1)); SCM_CRITICAL_SECTION_END; goto dispatch; } /* Prevent memoizing of debug info expression. */ debug.info->e.exp = scm_cons_source (debug.info->e.exp, SCM_CAR (x), SCM_CDR (x)); #endif SCM_CRITICAL_SECTION_START; SCM_SETCAR (x, SCM_CAR (arg1)); SCM_SETCDR (x, SCM_CDR (arg1)); SCM_CRITICAL_SECTION_END; PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto loop; #if SCM_ENABLE_DEPRECATED == 1 case 1: x = arg1; if (SCM_NIMP (x)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto loop; } else RETURN (arg1); #endif case 0: RETURN (arg1); } } } else proc = SCM_CAR (x); if (SCM_MACROP (proc)) goto handle_a_macro; } /* When reaching this part of the code, the following is granted: Variable x * holds the first pair of an expression of the form ( arg ...). * Variable proc holds the object that resulted from the evaluation of * . In the following, the arguments (if any) will be evaluated, * and proc will be applied to them. If proc does not really hold a * function object, this will be signalled as an error on the scheme * level. If the number of arguments does not match the number of arguments * that are allowed to be passed to proc, also an error on the scheme level * will be signalled. */ PREP_APPLY (proc, SCM_EOL); if (scm_is_null (SCM_CDR (x))) { ENTER_APPLY; evap0: SCM_ASRTGO (!SCM_IMP (proc), badfun); switch (SCM_TYP7 (proc)) { /* no arguments given */ case scm_tc7_subr_0: RETURN (SCM_SUBRF (proc) ()); case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); case scm_tc7_lsubr: RETURN (SCM_SUBRF (proc) (SCM_EOL)); case scm_tc7_rpsubr: RETURN (SCM_BOOL_T); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_0 (proc)); case scm_tc7_gsubr: #ifdef DEVAL debug.info->a.proc = proc; debug.info->a.args = SCM_EOL; #endif RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL debug.info->a.proc = proc; #endif if (!SCM_CLOSUREP (proc)) goto evap0; /* fallthrough */ case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); if (SCM_UNLIKELY (scm_is_pair (formals))) goto wrongnumargs; x = SCM_CLOSURE_BODY (proc); env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); goto nontoplevel_begin; } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); arg1 = SCM_EOL; goto type_dispatch; } else if (SCM_I_OPERATORP (proc)) { arg1 = proc; proc = (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc)); #ifdef DEVAL debug.info->a.proc = proc; debug.info->a.args = scm_list_1 (arg1); #endif goto evap1; } else goto badfun; case scm_tc7_subr_1: case scm_tc7_subr_2: case scm_tc7_subr_2o: case scm_tc7_dsubr: case scm_tc7_cxr: case scm_tc7_subr_3: case scm_tc7_lsubr_2: wrongnumargs: scm_wrong_num_args (proc); default: badfun: scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); } } /* must handle macros by here */ x = SCM_CDR (x); if (SCM_LIKELY (scm_is_pair (x))) arg1 = EVALCAR (x, env); else scm_wrong_num_args (proc); #ifdef DEVAL debug.info->a.args = scm_list_1 (arg1); #endif x = SCM_CDR (x); { SCM arg2; if (scm_is_null (x)) { ENTER_APPLY; evap1: /* inputs: proc, arg1 */ SCM_ASRTGO (!SCM_IMP (proc), badfun); switch (SCM_TYP7 (proc)) { /* have one argument in arg1 */ case scm_tc7_subr_2o: RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); case scm_tc7_subr_1: case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_dsubr: if (SCM_I_INUMP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_rpsubr: RETURN (SCM_BOOL_T); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); case scm_tc7_lsubr: #ifdef DEVAL RETURN (SCM_SUBRF (proc) (debug.info->a.args)); #else RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); #endif case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); case scm_tc7_gsubr: #ifdef DEVAL debug.info->a.args = scm_cons (arg1, debug.info->a.args); debug.info->a.proc = proc; #endif RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL debug.info->a.proc = proc; #endif if (!SCM_CLOSUREP (proc)) goto evap1; /* fallthrough */ case scm_tcs_closures: { /* clos1: */ const SCM formals = SCM_CLOSURE_FORMALS (proc); if (scm_is_null (formals) || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals)))) goto wrongnumargs; x = SCM_CLOSURE_BODY (proc); #ifdef DEVAL env = SCM_EXTEND_ENV (formals, debug.info->a.args, SCM_ENV (proc)); #else env = SCM_EXTEND_ENV (formals, scm_list_1 (arg1), SCM_ENV (proc)); #endif goto nontoplevel_begin; } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL arg1 = debug.info->a.args; #else arg1 = scm_list_1 (arg1); #endif goto type_dispatch; } else if (SCM_I_OPERATORP (proc)) { arg2 = arg1; arg1 = proc; proc = (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc)); #ifdef DEVAL debug.info->a.args = scm_cons (arg1, debug.info->a.args); debug.info->a.proc = proc; #endif goto evap2; } else goto badfun; case scm_tc7_subr_2: case scm_tc7_subr_0: case scm_tc7_subr_3: case scm_tc7_lsubr_2: scm_wrong_num_args (proc); default: goto badfun; } } if (SCM_LIKELY (scm_is_pair (x))) arg2 = EVALCAR (x, env); else scm_wrong_num_args (proc); { /* have two or more arguments */ #ifdef DEVAL debug.info->a.args = scm_list_2 (arg1, arg2); #endif x = SCM_CDR (x); if (scm_is_null (x)) { ENTER_APPLY; evap2: SCM_ASRTGO (!SCM_IMP (proc), badfun); switch (SCM_TYP7 (proc)) { /* have two arguments */ case scm_tc7_subr_2: case scm_tc7_subr_2o: RETURN (SCM_SUBRF (proc) (arg1, arg2)); case scm_tc7_lsubr: #ifdef DEVAL RETURN (SCM_SUBRF (proc) (debug.info->a.args)); #else RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); #endif case scm_tc7_lsubr_2: RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); case scm_tc7_rpsubr: case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (arg1, arg2)); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); case scm_tc7_gsubr: #ifdef DEVAL RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args)); #else RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED)); #endif case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL arg1 = debug.info->a.args; #else arg1 = scm_list_2 (arg1, arg2); #endif goto type_dispatch; } else if (SCM_I_OPERATORP (proc)) { operatorn: #ifdef DEVAL RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc), scm_cons (proc, debug.info->a.args), SCM_EOL)); #else RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc), scm_cons2 (proc, arg1, scm_cons (arg2, scm_ceval_args (x, env, proc))), SCM_EOL)); #endif } else goto badfun; case scm_tc7_subr_0: case scm_tc7_dsubr: case scm_tc7_cxr: case scm_tc7_subr_1o: case scm_tc7_subr_1: case scm_tc7_subr_3: scm_wrong_num_args (proc); default: goto badfun; case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL debug.info->a.proc = proc; #endif if (!SCM_CLOSUREP (proc)) goto evap2; /* fallthrough */ case scm_tcs_closures: { /* clos2: */ const SCM formals = SCM_CLOSURE_FORMALS (proc); if (scm_is_null (formals) || (scm_is_pair (formals) && (scm_is_null (SCM_CDR (formals)) || (scm_is_pair (SCM_CDR (formals)) && scm_is_pair (SCM_CDDR (formals)))))) goto wrongnumargs; #ifdef DEVAL env = SCM_EXTEND_ENV (formals, debug.info->a.args, SCM_ENV (proc)); #else env = SCM_EXTEND_ENV (formals, scm_list_2 (arg1, arg2), SCM_ENV (proc)); #endif x = SCM_CLOSURE_BODY (proc); goto nontoplevel_begin; } } } if (SCM_UNLIKELY (!scm_is_pair (x))) scm_wrong_num_args (proc); #ifdef DEVAL debug.info->a.args = scm_cons2 (arg1, arg2, deval_args (x, env, proc, SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); #endif ENTER_APPLY; evap3: SCM_ASRTGO (!SCM_IMP (proc), badfun); switch (SCM_TYP7 (proc)) { /* have 3 or more arguments */ #ifdef DEVAL case scm_tc7_subr_3: if (!scm_is_null (SCM_CDR (x))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_CADDR (debug.info->a.args))); case scm_tc7_asubr: arg1 = SCM_SUBRF(proc)(arg1, arg2); arg2 = SCM_CDDR (debug.info->a.args); do { arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); arg2 = SCM_CDR (arg2); } while (SCM_NIMP (arg2)); RETURN (arg1); case scm_tc7_rpsubr: if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) RETURN (SCM_BOOL_F); arg1 = SCM_CDDR (debug.info->a.args); do { if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) RETURN (SCM_BOOL_F); arg2 = SCM_CAR (arg1); arg1 = SCM_CDR (arg1); } while (SCM_NIMP (arg1)); RETURN (SCM_BOOL_T); case scm_tc7_lsubr_2: RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_CDDR (debug.info->a.args))); case scm_tc7_lsubr: RETURN (SCM_SUBRF (proc) (debug.info->a.args)); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, SCM_CDDR (debug.info->a.args))); case scm_tc7_gsubr: RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); debug.info->a.proc = proc; if (!SCM_CLOSUREP (proc)) goto evap3; /* fallthrough */ case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); if (scm_is_null (formals) || (scm_is_pair (formals) && (scm_is_null (SCM_CDR (formals)) || (scm_is_pair (SCM_CDR (formals)) && scm_badargsp (SCM_CDDR (formals), x))))) goto wrongnumargs; SCM_SET_ARGSREADY (debug); env = SCM_EXTEND_ENV (formals, debug.info->a.args, SCM_ENV (proc)); x = SCM_CLOSURE_BODY (proc); goto nontoplevel_begin; } #else /* DEVAL */ case scm_tc7_subr_3: if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x)))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); case scm_tc7_asubr: arg1 = SCM_SUBRF (proc) (arg1, arg2); do { arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); x = SCM_CDR(x); } while (!scm_is_null (x)); RETURN (arg1); case scm_tc7_rpsubr: if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) RETURN (SCM_BOOL_F); do { arg1 = EVALCAR (x, env); if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1))) RETURN (SCM_BOOL_F); arg2 = arg1; x = SCM_CDR (x); } while (!scm_is_null (x)); RETURN (SCM_BOOL_T); case scm_tc7_lsubr_2: RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc))); case scm_tc7_lsubr: RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)))); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, scm_ceval_args (x, env, proc))); case scm_tc7_gsubr: if (scm_is_null (SCM_CDR (x))) /* 3 arguments */ RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env), SCM_UNDEFINED)); else RETURN (scm_i_gsubr_apply_list (proc, scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); if (!SCM_CLOSUREP (proc)) goto evap3; /* fallthrough */ case scm_tcs_closures: { const SCM formals = SCM_CLOSURE_FORMALS (proc); if (scm_is_null (formals) || (scm_is_pair (formals) && (scm_is_null (SCM_CDR (formals)) || (scm_is_pair (SCM_CDR (formals)) && scm_badargsp (SCM_CDDR (formals), x))))) goto wrongnumargs; env = SCM_EXTEND_ENV (formals, scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)), SCM_ENV (proc)); x = SCM_CLOSURE_BODY (proc); goto nontoplevel_begin; } #endif /* DEVAL */ case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL arg1 = debug.info->a.args; #else arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)); #endif x = SCM_ENTITY_PROCEDURE (proc); goto type_dispatch; } else if (SCM_I_OPERATORP (proc)) goto operatorn; else goto badfun; case scm_tc7_subr_2: case scm_tc7_subr_1o: case scm_tc7_subr_2o: case scm_tc7_subr_0: case scm_tc7_dsubr: case scm_tc7_cxr: case scm_tc7_subr_1: scm_wrong_num_args (proc); default: goto badfun; } } } #ifdef DEVAL exit: if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); arg1 = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); SCM_TRAPS_P = 1; if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) proc = SCM_CDR (arg1); } scm_i_set_last_debug_frame (debug.prev); return proc; #endif } /* Apply a function to a list of arguments. This function is exported to the Scheme level as taking two required arguments and a tail argument, as if it were: (lambda (proc arg1 . args) ...) Thus, if you just have a list of arguments to pass to a procedure, pass the list as ARG1, and '() for ARGS. If you have some fixed args, pass the first as ARG1, then cons any remaining fixed args onto the front of your argument list, and pass that as ARGS. */ SCM 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_i_last_debug_frame (); debug.status = SCM_APPLYFRAME; debug.vect = &debug_vect_body; debug.vect[0].a.proc = proc; debug.vect[0].a.args = SCM_EOL; scm_i_set_last_debug_frame (&debug); #else if (scm_debug_mode_p) return scm_dapply (proc, arg1, args); #endif SCM_ASRTGO (SCM_NIMP (proc), badproc); /* If ARGS is the empty list, then we're calling apply with only two arguments --- ARG1 is the list of arguments for PROC. Whatever the case, futz with things so that ARG1 is the first argument to give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the rest. Setting the debug apply frame args this way is pretty messy. Perhaps we should store arg1 and args directly in the frame as received, and let scm_frame_arguments unpack them, because that's a relatively rare operation. This works for now; if the Guile developer archives are still around, see Mikael's post of 11-Apr-97. */ if (scm_is_null (args)) { if (scm_is_null (arg1)) { arg1 = SCM_UNDEFINED; #ifdef DEVAL debug.vect[0].a.args = SCM_EOL; #endif } else { #ifdef DEVAL debug.vect[0].a.args = arg1; #endif args = SCM_CDR (arg1); arg1 = SCM_CAR (arg1); } } else { args = scm_nconc2last (args); #ifdef DEVAL debug.vect[0].a.args = scm_cons (arg1, args); #endif } #ifdef DEVAL if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) { SCM tmp = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp); SCM_TRAPS_P = 1; } ENTER_APPLY; #endif tail: switch (SCM_TYP7 (proc)) { case scm_tc7_subr_2o: if (SCM_UNLIKELY (SCM_UNBNDP (arg1))) scm_wrong_num_args (proc); if (scm_is_null (args)) args = SCM_UNDEFINED; else { if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args)))) scm_wrong_num_args (proc); args = SCM_CAR (args); } RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: if (SCM_UNLIKELY (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))) scm_wrong_num_args (proc); args = SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_0: if (SCM_UNLIKELY (!SCM_UNBNDP (arg1))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) ()); case scm_tc7_subr_1: if (SCM_UNLIKELY (SCM_UNBNDP (arg1))) scm_wrong_num_args (proc); case scm_tc7_subr_1o: if (SCM_UNLIKELY (!scm_is_null (args))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_dsubr: if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) scm_wrong_num_args (proc); if (SCM_I_INUMP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); } else if (SCM_REALP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); } else if (SCM_BIGP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); } else if (SCM_FRACTIONP (arg1)) { RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); } SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); case scm_tc7_cxr: if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) scm_wrong_num_args (proc); RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_subr_3: if (SCM_UNLIKELY (scm_is_null (args) || scm_is_null (SCM_CDR (args)) || !scm_is_null (SCM_CDDR (args)))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); case scm_tc7_lsubr: #ifdef DEVAL RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); #else RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); #endif case scm_tc7_lsubr_2: if (SCM_UNLIKELY (!scm_is_pair (args))) scm_wrong_num_args (proc); else RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_asubr: if (scm_is_null (args)) RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); while (SCM_NIMP (args)) { SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); args = SCM_CDR (args); } RETURN (arg1); case scm_tc7_rpsubr: if (scm_is_null (args)) RETURN (SCM_BOOL_T); while (SCM_NIMP (args)) { SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) RETURN (SCM_BOOL_F); arg1 = SCM_CAR (args); args = SCM_CDR (args); } RETURN (SCM_BOOL_T); case scm_tcs_closures: #ifdef DEVAL arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args); #else arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))) scm_wrong_num_args (proc); /* Copy argument list */ if (SCM_IMP (arg1)) args = arg1; else { SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1)) { SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); tl = SCM_CDR (tl); } SCM_SETCDR (tl, arg1); } args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc)); proc = SCM_CLOSURE_BODY (proc); again: arg1 = SCM_CDR (proc); while (!scm_is_null (arg1)) { if (SCM_IMP (SCM_CAR (proc))) { if (SCM_ISYMP (SCM_CAR (proc))) { scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&source_mutex); /* check for race condition */ if (SCM_ISYMP (SCM_CAR (proc))) m_expand_body (proc, args); scm_dynwind_end (); goto again; } else SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc)); } else (void) EVAL (SCM_CAR (proc), args); proc = arg1; arg1 = SCM_CDR (proc); } RETURN (EVALCAR (proc, args)); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badproc; if (SCM_UNBNDP (arg1)) RETURN (SCM_SMOB_APPLY_0 (proc)); else if (scm_is_null (args)) RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); else if (scm_is_null (SCM_CDR (args))) RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); else RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_gsubr: #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); debug.vect[0].a.proc = proc; debug.vect[0].a.args = scm_cons (arg1, args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif RETURN (scm_i_gsubr_apply_list (proc, args)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL debug.vect[0].a.proc = proc; #endif goto tail; case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif RETURN (scm_apply_generic (proc, args)); } else if (SCM_I_OPERATORP (proc)) { /* operator */ #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif arg1 = proc; proc = (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc)); #ifdef DEVAL debug.vect[0].a.proc = proc; debug.vect[0].a.args = scm_cons (arg1, args); #endif if (SCM_NIMP (proc)) goto tail; else goto badproc; } else goto badproc; default: badproc: scm_wrong_type_arg ("apply", SCM_ARG1, proc); } #ifdef DEVAL exit: if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); arg1 = scm_make_debugobj (&debug); SCM_TRAPS_P = 0; arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); SCM_TRAPS_P = 1; if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) proc = SCM_CDR (arg1); } scm_i_set_last_debug_frame (debug.prev); return proc; #endif }