mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

* eval.c (SCM_CEVAL), srcprop.h (SRCBRKP): Eliminated union 't'.

Browse source 
* eval.c (SCM_CEVAL): Exlined call to EVALCAR.
This commit is contained in:
Dirk Herrmann 2002-03-14 06:45:56 +00:00
parent ffaf65cdd0
commit dff9830622
3 changed files with 139 additions and 145 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/ChangeLog
View file

@ -1,3 +1,9 @@
2002-03-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (SCM_CEVAL), srcprop.h (SRCBRKP): Eliminated union 't'.
* eval.c (SCM_CEVAL): Exlined call to EVALCAR.
2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org> 2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
* guile-snarf.in: Update copyright. * guile-snarf.in: Update copyright.

272
libguile/eval.c
View file

@ -1890,12 +1890,7 @@ scm_deval (SCM x, SCM env)
SCM SCM
SCM_CEVAL (SCM x, SCM env) SCM_CEVAL (SCM x, SCM env)
{ {
union SCM proc, arg1, arg2, orig_sym;
{
SCM *lloc;
SCM arg1;
} t;
SCM proc, arg2, orig_sym;
#ifdef DEVAL #ifdef DEVAL
scm_t_debug_frame debug; scm_t_debug_frame debug;
scm_t_debug_info *debug_info_end; scm_t_debug_info *debug_info_end;
@ -1961,14 +1956,14 @@ start:
SCM tail = SCM_BOOL(SCM_TAILRECP (debug)); SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
SCM_SET_TAILREC (debug); SCM_SET_TAILREC (debug);
if (SCM_CHEAPTRAPS_P) if (SCM_CHEAPTRAPS_P)
t.arg1 = scm_make_debugobj (&debug); arg1 = scm_make_debugobj (&debug);
else else
{ {
int first; int first;
SCM val = scm_make_continuation (&first); SCM val = scm_make_continuation (&first);
if (first) if (first)
t.arg1 = val; arg1 = val;
else else
{ {
x = val; x = val;
@ -1983,7 +1978,7 @@ start:
SCM_TRAPS_P = 0; SCM_TRAPS_P = 0;
scm_call_4 (SCM_ENTER_FRAME_HDLR, scm_call_4 (SCM_ENTER_FRAME_HDLR,
scm_sym_enter_frame, scm_sym_enter_frame,
t.arg1, arg1,
tail, tail,
scm_unmemocopy (x, env)); scm_unmemocopy (x, env));
SCM_TRAPS_P = 1; SCM_TRAPS_P = 1;
@ -2130,12 +2125,12 @@ dispatch:
} }
else else
{ {
t.arg1 = EVALCAR (clause, env); arg1 = EVALCAR (clause, env);
if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1)) if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
{ {
x = SCM_CDR (clause); x = SCM_CDR (clause);
if (SCM_NULLP (x)) if (SCM_NULLP (x))
RETURN (t.arg1); RETURN (arg1);
else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow))
{ {
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
@ -2146,7 +2141,7 @@ dispatch:
proc = SCM_CDR (x); proc = SCM_CDR (x);
proc = EVALCAR (proc, env); proc = EVALCAR (proc, env);
SCM_ASRTGO (!SCM_IMP (proc), badfun); SCM_ASRTGO (!SCM_IMP (proc), badfun);
PREP_APPLY (proc, scm_list_1 (t.arg1)); PREP_APPLY (proc, scm_list_1 (arg1));
ENTER_APPLY; ENTER_APPLY;
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
goto umwrongnumargs; goto umwrongnumargs;
@ -2362,36 +2357,36 @@ dispatch:
if (SCM_CLOSUREP (proc)) if (SCM_CLOSUREP (proc))
{ {
PREP_APPLY (proc, SCM_EOL); PREP_APPLY (proc, SCM_EOL);
t.arg1 = SCM_CDDR (x); arg1 = SCM_CDDR (x);
t.arg1 = EVALCAR (t.arg1, env); arg1 = EVALCAR (arg1, env);
apply_closure: apply_closure:
/* Go here to tail-call a closure. PROC is the closure /* Go here to tail-call a closure. PROC is the closure
and T.ARG1 is the list of arguments. Do not forget to and ARG1 is the list of arguments. Do not forget to
call PREP_APPLY. */ call PREP_APPLY. */
{ {
SCM formals = SCM_CLOSURE_FORMALS (proc); SCM formals = SCM_CLOSURE_FORMALS (proc);
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = t.arg1; debug.info->a.args = arg1;
#endif #endif
#ifndef SCM_RECKLESS #ifndef SCM_RECKLESS
if (scm_badargsp (formals, t.arg1)) if (scm_badargsp (formals, arg1))
goto wrongnumargs; goto wrongnumargs;
#endif #endif
ENTER_APPLY; ENTER_APPLY;
/* Copy argument list */ /* Copy argument list */
if (SCM_NULL_OR_NIL_P (t.arg1)) if (SCM_NULL_OR_NIL_P (arg1))
env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
else else
{ {
SCM args = scm_list_1 (SCM_CAR (t.arg1)); SCM args = scm_list_1 (SCM_CAR (arg1));
SCM tail = args; SCM tail = args;
t.arg1 = SCM_CDR (t.arg1); arg1 = SCM_CDR (arg1);
while (!SCM_NULL_OR_NIL_P (t.arg1)) while (!SCM_NULL_OR_NIL_P (arg1))
{ {
SCM new_tail = scm_list_1 (SCM_CAR (t.arg1)); SCM new_tail = scm_list_1 (SCM_CAR (arg1));
SCM_SETCDR (tail, new_tail); SCM_SETCDR (tail, new_tail);
tail = new_tail; tail = new_tail;
t.arg1 = SCM_CDR (t.arg1); arg1 = SCM_CDR (arg1);
} }
env = EXTEND_ENV (formals, args, SCM_ENV (proc)); env = EXTEND_ENV (formals, args, SCM_ENV (proc));
} }
@ -2413,14 +2408,14 @@ dispatch:
SCM val = scm_make_continuation (&first); SCM val = scm_make_continuation (&first);
if (first) if (first)
t.arg1 = val; arg1 = val;
else else
RETURN (val); RETURN (val);
} }
proc = SCM_CDR (x); proc = SCM_CDR (x);
proc = scm_eval_car (proc, env); proc = scm_eval_car (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun); SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_list_1 (t.arg1)); PREP_APPLY (proc, scm_list_1 (arg1));
ENTER_APPLY; ENTER_APPLY;
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
goto umwrongnumargs; goto umwrongnumargs;
@ -2432,19 +2427,19 @@ dispatch:
case (SCM_ISYMNUM (SCM_IM_DISPATCH)): case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
{ {
/* If not done yet, evaluate the operand forms. The result is a /* If not done yet, evaluate the operand forms. The result is a
* list of arguments stored in t.arg1, which is used to perform the * list of arguments stored in arg1, which is used to perform the
* function dispatch. */ * function dispatch. */
SCM operand_forms = SCM_CADR (x); SCM operand_forms = SCM_CADR (x);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
if (SCM_ILOCP (operand_forms)) if (SCM_ILOCP (operand_forms))
t.arg1 = *scm_ilookup (operand_forms, env); arg1 = *scm_ilookup (operand_forms, env);
else if (SCM_VARIABLEP (operand_forms)) else if (SCM_VARIABLEP (operand_forms))
t.arg1 = SCM_VARIABLE_REF (operand_forms); arg1 = SCM_VARIABLE_REF (operand_forms);
else if (!SCM_CONSP (operand_forms)) else if (!SCM_CONSP (operand_forms))
t.arg1 = *scm_lookupcar (SCM_CDR (x), env, 1); arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);
else else
{ {
SCM tail = t.arg1 = scm_list_1 (EVALCAR (operand_forms, env)); SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env));
operand_forms = SCM_CDR (operand_forms); operand_forms = SCM_CDR (operand_forms);
while (!SCM_NULLP (operand_forms)) while (!SCM_NULLP (operand_forms))
{ {
@ -2459,7 +2454,7 @@ dispatch:
/* The type dispatch code is duplicated below /* The type dispatch code is duplicated below
* (c.f. objects.c:scm_mcache_compute_cmethod) since that * (c.f. objects.c:scm_mcache_compute_cmethod) since that
* cuts down execution time for type dispatch to 50%. */ * cuts down execution time for type dispatch to 50%. */
type_dispatch: /* inputs: x, t.arg1 */ type_dispatch: /* inputs: x, arg1 */
/* Type dispatch means to determine from the types of the function /* Type dispatch means to determine from the types of the function
* arguments (i. e. the 'signature' of the call), which method from * arguments (i. e. the 'signature' of the call), which method from
* a generic function is to be called. This process of selecting * a generic function is to be called. This process of selecting
@ -2514,7 +2509,7 @@ dispatch:
* method in the method cache. */ * method in the method cache. */
unsigned long int hashset = SCM_INUM (tmp); unsigned long int hashset = SCM_INUM (tmp);
unsigned long int counter = specializers + 1; unsigned long int counter = specializers + 1;
SCM tmp_arg = t.arg1; SCM tmp_arg = arg1;
hash_value = 0; hash_value = 0;
while (!SCM_NULLP (tmp_arg) && counter != 0) while (!SCM_NULLP (tmp_arg) && counter != 0)
{ {
@ -2553,7 +2548,7 @@ dispatch:
SCM z; SCM z;
do do
{ {
SCM args = t.arg1; /* list of arguments */ SCM args = arg1; /* list of arguments */
z = SCM_VELTS (method_cache)[hash_value]; z = SCM_VELTS (method_cache)[hash_value];
while (!SCM_NULLP (args)) while (!SCM_NULLP (args))
{ {
@ -2572,12 +2567,12 @@ dispatch:
} while (hash_value != cache_end_pos); } while (hash_value != cache_end_pos);
/* No appropriate method was found in the cache. */ /* No appropriate method was found in the cache. */
z = scm_memoize_method (x, t.arg1); z = scm_memoize_method (x, arg1);
apply_cmethod: /* inputs: z, t.arg1 */ apply_cmethod: /* inputs: z, arg1 */
{ {
SCM formals = SCM_CMETHOD_FORMALS (z); SCM formals = SCM_CMETHOD_FORMALS (z);
env = EXTEND_ENV (formals, t.arg1, SCM_CMETHOD_ENV (z)); env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
x = SCM_CMETHOD_BODY (z); x = SCM_CMETHOD_BODY (z);
goto nontoplevel_begin; goto nontoplevel_begin;
} }
@ -2675,17 +2670,17 @@ dispatch:
x = EVALCAR (proc, env); x = EVALCAR (proc, env);
proc = SCM_CDR (proc); proc = SCM_CDR (proc);
proc = EVALCAR (proc, env); proc = EVALCAR (proc, env);
t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL); arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
if (SCM_VALUESP (t.arg1)) if (SCM_VALUESP (arg1))
t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0); arg1 = scm_struct_ref (arg1, SCM_INUM0);
else else
t.arg1 = scm_list_1 (t.arg1); arg1 = scm_list_1 (arg1);
if (SCM_CLOSUREP (proc)) if (SCM_CLOSUREP (proc))
{ {
PREP_APPLY (proc, t.arg1); PREP_APPLY (proc, arg1);
goto apply_closure; goto apply_closure;
} }
return SCM_APPLY (proc, t.arg1, SCM_EOL); return SCM_APPLY (proc, arg1, SCM_EOL);
} }
@ -2770,7 +2765,7 @@ dispatch:
application frames can be deleted from the backtrace. */ application frames can be deleted from the backtrace. */
SCM_SET_MACROEXP (debug); SCM_SET_MACROEXP (debug);
#endif #endif
t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
scm_cons (env, scm_listofnull)); scm_cons (env, scm_listofnull));
#ifdef DEVAL #ifdef DEVAL
@ -2779,14 +2774,14 @@ dispatch:
switch (SCM_MACRO_TYPE (proc)) switch (SCM_MACRO_TYPE (proc))
{ {
case 2: case 2:
if (scm_ilength (t.arg1) <= 0) if (scm_ilength (arg1) <= 0)
t.arg1 = scm_list_2 (SCM_IM_BEGIN, t.arg1); arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
#ifdef DEVAL #ifdef DEVAL
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{ {
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (t.arg1)); SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (t.arg1)); SCM_SETCDR (x, SCM_CDR (arg1));
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
goto dispatch; goto dispatch;
} }
@ -2796,15 +2791,15 @@ dispatch:
SCM_CDR (x)); SCM_CDR (x));
#endif #endif
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (t.arg1)); SCM_SETCAR (x, SCM_CAR (arg1));
SCM_SETCDR (x, SCM_CDR (t.arg1)); SCM_SETCDR (x, SCM_CDR (arg1));
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
goto loopnoap; goto loopnoap;
case 1: case 1:
if (SCM_NIMP (x = t.arg1)) if (SCM_NIMP (x = arg1))
goto loopnoap; goto loopnoap;
case 0: case 0:
RETURN (t.arg1); RETURN (arg1);
} }
} }
} }
@ -2818,17 +2813,17 @@ dispatch:
if (SCM_CLOSUREP (proc)) if (SCM_CLOSUREP (proc))
{ {
arg2 = SCM_CLOSURE_FORMALS (proc); arg2 = SCM_CLOSURE_FORMALS (proc);
t.arg1 = SCM_CDR (x); arg1 = SCM_CDR (x);
while (!SCM_NULLP (arg2)) while (!SCM_NULLP (arg2))
{ {
if (!SCM_CONSP (arg2)) if (!SCM_CONSP (arg2))
goto evapply; goto evapply;
if (SCM_IMP (t.arg1)) if (SCM_IMP (arg1))
goto umwrongnumargs; goto umwrongnumargs;
arg2 = SCM_CDR (arg2); arg2 = SCM_CDR (arg2);
t.arg1 = SCM_CDR (t.arg1); arg1 = SCM_CDR (arg1);
} }
if (!SCM_NULLP (t.arg1)) if (!SCM_NULLP (arg1))
goto umwrongnumargs; goto umwrongnumargs;
} }
else if (SCM_MACROP (proc)) else if (SCM_MACROP (proc))
@ -2859,11 +2854,11 @@ evapply:
goto badfun; goto badfun;
RETURN (SCM_SMOB_APPLY_0 (proc)); RETURN (SCM_SMOB_APPLY_0 (proc));
case scm_tc7_cclo: case scm_tc7_cclo:
t.arg1 = proc; arg1 = proc;
proc = SCM_CCLO_SUBR (proc); proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL #ifdef DEVAL
debug.info->a.proc = proc; debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (t.arg1); debug.info->a.args = scm_list_1 (arg1);
#endif #endif
goto evap1; goto evap1;
case scm_tc7_pws: case scm_tc7_pws:
@ -2883,20 +2878,20 @@ evapply:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{ {
x = SCM_ENTITY_PROCEDURE (proc); x = SCM_ENTITY_PROCEDURE (proc);
t.arg1 = SCM_EOL; arg1 = SCM_EOL;
goto type_dispatch; goto type_dispatch;
} }
else if (!SCM_I_OPERATORP (proc)) else if (!SCM_I_OPERATORP (proc))
goto badfun; goto badfun;
else else
{ {
t.arg1 = proc; arg1 = proc;
proc = (SCM_I_ENTITYP (proc) proc = (SCM_I_ENTITYP (proc)
? SCM_ENTITY_PROCEDURE (proc) ? SCM_ENTITY_PROCEDURE (proc)
: SCM_OPERATOR_PROCEDURE (proc)); : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL #ifdef DEVAL
debug.info->a.proc = proc; debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (t.arg1); debug.info->a.args = scm_list_1 (arg1);
#endif #endif
if (SCM_NIMP (proc)) if (SCM_NIMP (proc))
goto evap1; goto evap1;
@ -2922,22 +2917,15 @@ evapply:
/* must handle macros by here */ /* must handle macros by here */
x = SCM_CDR (x); x = SCM_CDR (x);
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
if (SCM_IMP (x)) if (SCM_CONSP (x))
goto wrongnumargs; arg1 = EVALCAR (x, env);
else if (SCM_CONSP (x))
{
if (SCM_IMP (SCM_CAR (x)))
t.arg1 = SCM_EVALIM (SCM_CAR (x), env);
else
t.arg1 = EVALCELLCAR (x, env);
}
else else
goto wrongnumargs; goto wrongnumargs;
#else #else
t.arg1 = EVALCAR (x, env); arg1 = EVALCAR (x, env);
#endif #endif
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_list_1 (t.arg1); debug.info->a.args = scm_list_1 (arg1);
#endif #endif
x = SCM_CDR (x); x = SCM_CDR (x);
if (SCM_NULLP (x)) if (SCM_NULLP (x))
@ -2945,30 +2933,30 @@ evapply:
ENTER_APPLY; ENTER_APPLY;
evap1: evap1:
switch (SCM_TYP7 (proc)) switch (SCM_TYP7 (proc))
{ /* have one argument in t.arg1 */ { /* have one argument in arg1 */
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_subr_1: case scm_tc7_subr_1:
case scm_tc7_subr_1o: case scm_tc7_subr_1o:
RETURN (SCM_SUBRF (proc) (t.arg1)); RETURN (SCM_SUBRF (proc) (arg1));
case scm_tc7_cxr: case scm_tc7_cxr:
if (SCM_SUBRF (proc)) if (SCM_SUBRF (proc))
{ {
if (SCM_INUMP (t.arg1)) if (SCM_INUMP (arg1))
{ {
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)))); RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
} }
else if (SCM_REALP (t.arg1)) else if (SCM_REALP (arg1))
{ {
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1)))); RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
} }
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
else if (SCM_BIGP (t.arg1)) else if (SCM_BIGP (arg1))
{ {
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1)))); RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
} }
#endif #endif
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
} }
proc = SCM_SNAME (proc); proc = SCM_SNAME (proc);
@ -2976,32 +2964,32 @@ evapply:
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
while ('c' != *--chrs) while ('c' != *--chrs)
{ {
SCM_ASSERT (SCM_CONSP (t.arg1), SCM_ASSERT (SCM_CONSP (arg1),
t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
} }
RETURN (t.arg1); RETURN (arg1);
} }
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
RETURN (SCM_BOOL_T); RETURN (SCM_BOOL_T);
case scm_tc7_asubr: case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_lsubr: case scm_tc7_lsubr:
#ifdef DEVAL #ifdef DEVAL
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else #else
RETURN (SCM_SUBRF (proc) (scm_list_1 (t.arg1))); RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
#endif #endif
case scm_tc7_smob: case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc)) if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun; goto badfun;
RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1)); RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
case scm_tc7_cclo: case scm_tc7_cclo:
arg2 = t.arg1; arg2 = arg1;
t.arg1 = proc; arg1 = proc;
proc = SCM_CCLO_SUBR (proc); proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc; debug.info->a.proc = proc;
#endif #endif
goto evap2; goto evap2;
@ -3020,7 +3008,7 @@ evapply:
#ifdef DEVAL #ifdef DEVAL
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else #else
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (t.arg1), SCM_ENV (proc)); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc));
#endif #endif
goto nontoplevel_begin; goto nontoplevel_begin;
case scm_tcs_struct: case scm_tcs_struct:
@ -3028,9 +3016,9 @@ evapply:
{ {
x = SCM_ENTITY_PROCEDURE (proc); x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL #ifdef DEVAL
t.arg1 = debug.info->a.args; arg1 = debug.info->a.args;
#else #else
t.arg1 = scm_list_1 (t.arg1); arg1 = scm_list_1 (arg1);
#endif #endif
goto type_dispatch; goto type_dispatch;
} }
@ -3038,13 +3026,13 @@ evapply:
goto badfun; goto badfun;
else else
{ {
arg2 = t.arg1; arg2 = arg1;
t.arg1 = proc; arg1 = proc;
proc = (SCM_I_ENTITYP (proc) proc = (SCM_I_ENTITYP (proc)
? SCM_ENTITY_PROCEDURE (proc) ? SCM_ENTITY_PROCEDURE (proc)
: SCM_OPERATOR_PROCEDURE (proc)); : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc; debug.info->a.proc = proc;
#endif #endif
if (SCM_NIMP (proc)) if (SCM_NIMP (proc))
@ -3078,7 +3066,7 @@ evapply:
#endif #endif
{ /* have two or more arguments */ { /* have two or more arguments */
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_list_2 (t.arg1, arg2); debug.info->a.args = scm_list_2 (arg1, arg2);
#endif #endif
x = SCM_CDR (x); x = SCM_CDR (x);
if (SCM_NULLP (x)) { if (SCM_NULLP (x)) {
@ -3088,22 +3076,22 @@ evapply:
{ /* have two arguments */ { /* have two arguments */
case scm_tc7_subr_2: case scm_tc7_subr_2:
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); RETURN (SCM_SUBRF (proc) (arg1, arg2));
case scm_tc7_lsubr: case scm_tc7_lsubr:
#ifdef DEVAL #ifdef DEVAL
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else #else
RETURN (SCM_SUBRF (proc) (scm_list_2 (t.arg1, arg2))); RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
#endif #endif
case scm_tc7_lsubr_2: case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL)); RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
case scm_tc7_asubr: case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); RETURN (SCM_SUBRF (proc) (arg1, arg2));
case scm_tc7_smob: case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc)) if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun; goto badfun;
RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2)); RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
cclon: cclon:
case scm_tc7_cclo: case scm_tc7_cclo:
#ifdef DEVAL #ifdef DEVAL
@ -3112,7 +3100,7 @@ evapply:
SCM_EOL)); SCM_EOL));
#else #else
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
scm_cons2 (proc, t.arg1, scm_cons2 (proc, arg1,
scm_cons (arg2, scm_cons (arg2,
scm_eval_args (x, scm_eval_args (x,
env, env,
@ -3124,9 +3112,9 @@ evapply:
{ {
x = SCM_ENTITY_PROCEDURE (proc); x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL #ifdef DEVAL
t.arg1 = debug.info->a.args; arg1 = debug.info->a.args;
#else #else
t.arg1 = scm_list_2 (t.arg1, arg2); arg1 = scm_list_2 (arg1, arg2);
#endif #endif
goto type_dispatch; goto type_dispatch;
} }
@ -3145,7 +3133,7 @@ evapply:
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
? SCM_ENTITY_PROCEDURE (proc) ? SCM_ENTITY_PROCEDURE (proc)
: SCM_OPERATOR_PROCEDURE (proc), : SCM_OPERATOR_PROCEDURE (proc),
scm_cons2 (proc, t.arg1, scm_cons2 (proc, arg1,
scm_cons (arg2, scm_cons (arg2,
scm_eval_args (x, scm_eval_args (x,
env, env,
@ -3178,7 +3166,7 @@ evapply:
SCM_ENV (proc)); SCM_ENV (proc));
#else #else
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_list_2 (t.arg1, arg2), SCM_ENV (proc)); scm_list_2 (arg1, arg2), SCM_ENV (proc));
#endif #endif
x = SCM_CLOSURE_BODY (proc); x = SCM_CLOSURE_BODY (proc);
goto nontoplevel_begin; goto nontoplevel_begin;
@ -3189,7 +3177,7 @@ evapply:
goto wrongnumargs; goto wrongnumargs;
#endif #endif
#ifdef DEVAL #ifdef DEVAL
debug.info->a.args = scm_cons2 (t.arg1, arg2, debug.info->a.args = scm_cons2 (arg1, arg2,
deval_args (x, env, proc, SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); deval_args (x, env, proc, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif #endif
ENTER_APPLY; ENTER_APPLY;
@ -3199,49 +3187,49 @@ evapply:
#ifdef DEVAL #ifdef DEVAL
case scm_tc7_subr_3: case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, RETURN (SCM_SUBRF (proc) (arg1, arg2,
SCM_CADDR (debug.info->a.args))); SCM_CADDR (debug.info->a.args)));
case scm_tc7_asubr: case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR #ifdef BUILTIN_RPASUBR
t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); arg1 = SCM_SUBRF(proc)(arg1, arg2);
arg2 = SCM_CDDR (debug.info->a.args); arg2 = SCM_CDDR (debug.info->a.args);
do do
{ {
t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2)); arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
arg2 = SCM_CDR (arg2); arg2 = SCM_CDR (arg2);
} }
while (SCM_NIMP (arg2)); while (SCM_NIMP (arg2));
RETURN (t.arg1); RETURN (arg1);
#endif /* BUILTIN_RPASUBR */ #endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR #ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
RETURN (SCM_BOOL_F); RETURN (SCM_BOOL_F);
t.arg1 = SCM_CDDR (debug.info->a.args); arg1 = SCM_CDDR (debug.info->a.args);
do do
{ {
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1)))) if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
RETURN (SCM_BOOL_F); RETURN (SCM_BOOL_F);
arg2 = SCM_CAR (t.arg1); arg2 = SCM_CAR (arg1);
t.arg1 = SCM_CDR (t.arg1); arg1 = SCM_CDR (arg1);
} }
while (SCM_NIMP (t.arg1)); while (SCM_NIMP (arg1));
RETURN (SCM_BOOL_T); RETURN (SCM_BOOL_T);
#else /* BUILTIN_RPASUBR */ #else /* BUILTIN_RPASUBR */
RETURN (SCM_APPLY (proc, t.arg1, RETURN (SCM_APPLY (proc, arg1,
scm_acons (arg2, scm_acons (arg2,
SCM_CDDR (debug.info->a.args), SCM_CDDR (debug.info->a.args),
SCM_EOL))); SCM_EOL)));
#endif /* BUILTIN_RPASUBR */ #endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2: case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, RETURN (SCM_SUBRF (proc) (arg1, arg2,
SCM_CDDR (debug.info->a.args))); SCM_CDDR (debug.info->a.args)));
case scm_tc7_lsubr: case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); RETURN (SCM_SUBRF (proc) (debug.info->a.args));
case scm_tc7_smob: case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc)) if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun; goto badfun;
RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
SCM_CDDR (debug.info->a.args))); SCM_CDDR (debug.info->a.args)));
case scm_tc7_cclo: case scm_tc7_cclo:
goto cclon; goto cclon;
@ -3262,48 +3250,48 @@ evapply:
#else /* DEVAL */ #else /* DEVAL */
case scm_tc7_subr_3: case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env))); RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
case scm_tc7_asubr: case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR #ifdef BUILTIN_RPASUBR
t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2); arg1 = SCM_SUBRF (proc) (arg1, arg2);
do do
{ {
t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
x = SCM_CDR(x); x = SCM_CDR(x);
} }
while (SCM_NIMP (x)); while (SCM_NIMP (x));
RETURN (t.arg1); RETURN (arg1);
#endif /* BUILTIN_RPASUBR */ #endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR #ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
RETURN (SCM_BOOL_F); RETURN (SCM_BOOL_F);
do do
{ {
t.arg1 = EVALCAR (x, env); arg1 = EVALCAR (x, env);
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1))) if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
RETURN (SCM_BOOL_F); RETURN (SCM_BOOL_F);
arg2 = t.arg1; arg2 = arg1;
x = SCM_CDR (x); x = SCM_CDR (x);
} }
while (SCM_NIMP (x)); while (SCM_NIMP (x));
RETURN (SCM_BOOL_T); RETURN (SCM_BOOL_T);
#else /* BUILTIN_RPASUBR */ #else /* BUILTIN_RPASUBR */
RETURN (SCM_APPLY (proc, t.arg1, RETURN (SCM_APPLY (proc, arg1,
scm_acons (arg2, scm_acons (arg2,
scm_eval_args (x, env, proc), scm_eval_args (x, env, proc),
SCM_EOL))); SCM_EOL)));
#endif /* BUILTIN_RPASUBR */ #endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2: case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc))); RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
case scm_tc7_lsubr: case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
arg2, arg2,
scm_eval_args (x, env, proc)))); scm_eval_args (x, env, proc))));
case scm_tc7_smob: case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc)) if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun; goto badfun;
RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
scm_eval_args (x, env, proc))); scm_eval_args (x, env, proc)));
case scm_tc7_cclo: case scm_tc7_cclo:
goto cclon; goto cclon;
@ -3325,7 +3313,7 @@ evapply:
SCM_SET_ARGSREADY (debug); SCM_SET_ARGSREADY (debug);
#endif #endif
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_cons2 (t.arg1, scm_cons2 (arg1,
arg2, arg2,
scm_eval_args (x, env, proc)), scm_eval_args (x, env, proc)),
SCM_ENV (proc)); SCM_ENV (proc));
@ -3336,9 +3324,9 @@ evapply:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{ {
#ifdef DEVAL #ifdef DEVAL
t.arg1 = debug.info->a.args; arg1 = debug.info->a.args;
#else #else
t.arg1 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
#endif #endif
x = SCM_ENTITY_PROCEDURE (proc); x = SCM_ENTITY_PROCEDURE (proc);
goto type_dispatch; goto type_dispatch;
@ -3365,14 +3353,14 @@ exit:
{ {
SCM_CLEAR_TRACED_FRAME (debug); SCM_CLEAR_TRACED_FRAME (debug);
if (SCM_CHEAPTRAPS_P) if (SCM_CHEAPTRAPS_P)
t.arg1 = scm_make_debugobj (&debug); arg1 = scm_make_debugobj (&debug);
else else
{ {
int first; int first;
SCM val = scm_make_continuation (&first); SCM val = scm_make_continuation (&first);
if (first) if (first)
t.arg1 = val; arg1 = val;
else else
{ {
proc = val; proc = val;
@ -3380,7 +3368,7 @@ exit:
} }
} }
SCM_TRAPS_P = 0; SCM_TRAPS_P = 0;
scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, t.arg1, proc); scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
SCM_TRAPS_P = 1; SCM_TRAPS_P = 1;
} }
ret: ret:

6
libguile/srcprop.h
View file

@ -115,9 +115,9 @@ typedef struct scm_t_srcprops_chunk
#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) #define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) #define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
#define SRCBRKP(x) (!SCM_IMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\ #define SRCBRKP(x) (!SCM_IMP (arg1 = scm_whash_lookup (scm_source_whash, (x)))\
&& SRCPROPSP (t.arg1)\ && SRCPROPSP (arg1)\
&& SRCPROPBRK (t.arg1)) && SRCPROPBRK (arg1))
#define PROCTRACEP(x) (!SCM_FALSEP (scm_procedure_property (x, scm_sym_trace))) #define PROCTRACEP(x) (!SCM_FALSEP (scm_procedure_property (x, scm_sym_trace)))