1640 |
return !SCM_NULLP (args) ? 1 : 0; |
return !SCM_NULLP (args) ? 1 : 0; |
1641 |
} |
} |
1642 |
|
|
|
|
|
|
static int |
|
|
scm_badformalsp (SCM closure, int n) |
|
|
{ |
|
|
SCM formals = SCM_CLOSURE_FORMALS (closure); |
|
|
while (!SCM_NULLP (formals)) |
|
|
{ |
|
|
if (!SCM_CONSP (formals)) |
|
|
return 0; |
|
|
if (n == 0) |
|
|
return 1; |
|
|
--n; |
|
|
formals = SCM_CDR (formals); |
|
|
} |
|
|
return n; |
|
|
} |
|
|
|
|
1643 |
|
|
1644 |
SCM |
SCM |
1645 |
scm_eval_args (SCM l, SCM env, SCM proc) |
scm_eval_args (SCM l, SCM env, SCM proc) |
2171 |
{ |
{ |
2172 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
2173 |
proc = EVALCAR (proc, env); |
proc = EVALCAR (proc, env); |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
|
2174 |
PREP_APPLY (proc, scm_list_1 (arg1)); |
PREP_APPLY (proc, scm_list_1 (arg1)); |
2175 |
ENTER_APPLY; |
ENTER_APPLY; |
2176 |
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) |
goto evap1; |
|
goto umwrongnumargs; |
|
|
else |
|
|
goto evap1; |
|
2177 |
} |
} |
2178 |
} |
} |
2179 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2378 |
/* new syntactic forms go here. */ |
/* new syntactic forms go here. */ |
2379 |
case SCM_BIT7 (SCM_MAKISYM (0)): |
case SCM_BIT7 (SCM_MAKISYM (0)): |
2380 |
proc = SCM_CAR (x); |
proc = SCM_CAR (x); |
|
SCM_ASRTGO (SCM_ISYMP (proc), badfun); |
|
2381 |
switch (SCM_ISYMNUM (proc)) |
switch (SCM_ISYMNUM (proc)) |
2382 |
{ |
{ |
2383 |
|
|
2385 |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
2386 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
2387 |
proc = EVALCAR (proc, env); |
proc = EVALCAR (proc, env); |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
|
2388 |
if (SCM_CLOSUREP (proc)) |
if (SCM_CLOSUREP (proc)) |
2389 |
{ |
{ |
2390 |
PREP_APPLY (proc, SCM_EOL); |
PREP_APPLY (proc, SCM_EOL); |
2443 |
arg1 = val; |
arg1 = val; |
2444 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
2445 |
proc = scm_eval_car (proc, env); |
proc = scm_eval_car (proc, env); |
|
SCM_ASRTGO (SCM_NIMP (proc), badfun); |
|
2446 |
PREP_APPLY (proc, scm_list_1 (arg1)); |
PREP_APPLY (proc, scm_list_1 (arg1)); |
2447 |
ENTER_APPLY; |
ENTER_APPLY; |
|
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) |
|
|
goto umwrongnumargs; |
|
2448 |
goto evap1; |
goto evap1; |
2449 |
} |
} |
2450 |
} |
} |
2699 |
|
|
2700 |
|
|
2701 |
default: |
default: |
2702 |
goto badfun; |
goto evapply; |
2703 |
} |
} |
2704 |
|
|
2705 |
default: |
default: |
2706 |
proc = x; |
proc = x; |
2707 |
badfun: |
goto evapply; |
|
scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); |
|
2708 |
case scm_tc7_vector: |
case scm_tc7_vector: |
2709 |
case scm_tc7_wvect: |
case scm_tc7_wvect: |
2710 |
#if SCM_HAVE_ARRAYS |
#if SCM_HAVE_ARRAYS |
2734 |
|
|
2735 |
case SCM_BIT7 (SCM_ILOC00): |
case SCM_BIT7 (SCM_ILOC00): |
2736 |
proc = *scm_ilookup (SCM_CAR (x), env); |
proc = *scm_ilookup (SCM_CAR (x), env); |
2737 |
SCM_ASRTGO (SCM_NIMP (proc), badfun); |
goto checkmacro; |
|
goto checkargs; |
|
2738 |
|
|
2739 |
case scm_tcs_cons_nimcar: |
case scm_tcs_cons_nimcar: |
2740 |
if (SCM_SYMBOLP (SCM_CAR (x))) |
if (SCM_SYMBOLP (SCM_CAR (x))) |
2750 |
proc = *location; |
proc = *location; |
2751 |
} |
} |
2752 |
|
|
|
if (SCM_IMP (proc)) |
|
|
{ |
|
|
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of |
|
|
lookupcar */ |
|
|
goto badfun; |
|
|
} |
|
2753 |
if (SCM_MACROP (proc)) |
if (SCM_MACROP (proc)) |
2754 |
{ |
{ |
2755 |
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of |
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of |
2810 |
} |
} |
2811 |
else |
else |
2812 |
proc = SCM_CEVAL (SCM_CAR (x), env); |
proc = SCM_CEVAL (SCM_CAR (x), env); |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
|
2813 |
|
|
2814 |
checkargs: |
checkmacro: |
2815 |
if (SCM_CLOSUREP (proc)) |
if (SCM_MACROP (proc)) |
|
{ |
|
|
SCM formals = SCM_CLOSURE_FORMALS (proc); |
|
|
SCM args = SCM_CDR (x); |
|
|
while (!SCM_NULLP (formals)) |
|
|
{ |
|
|
if (!SCM_CONSP (formals)) |
|
|
goto evapply; |
|
|
if (SCM_IMP (args)) |
|
|
goto umwrongnumargs; |
|
|
formals = SCM_CDR (formals); |
|
|
args = SCM_CDR (args); |
|
|
} |
|
|
if (!SCM_NULLP (args)) |
|
|
goto umwrongnumargs; |
|
|
} |
|
|
else if (SCM_MACROP (proc)) |
|
2816 |
goto handle_a_macro; |
goto handle_a_macro; |
2817 |
} |
} |
2818 |
|
|
2822 |
if (SCM_NULLP (SCM_CDR (x))) { |
if (SCM_NULLP (SCM_CDR (x))) { |
2823 |
ENTER_APPLY; |
ENTER_APPLY; |
2824 |
evap0: |
evap0: |
2825 |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
2826 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
2827 |
{ /* no arguments given */ |
{ /* no arguments given */ |
2828 |
case scm_tc7_subr_0: |
case scm_tc7_subr_0: |
2854 |
#endif |
#endif |
2855 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
2856 |
goto evap0; |
goto evap0; |
2857 |
if (scm_badformalsp (proc, 0)) |
/* fallthrough */ |
|
goto umwrongnumargs; |
|
2858 |
case scm_tcs_closures: |
case scm_tcs_closures: |
2859 |
x = SCM_CLOSURE_BODY (proc); |
{ |
2860 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
2861 |
SCM_EOL, |
if (SCM_CONSP (formals)) |
2862 |
SCM_ENV (proc)); |
goto umwrongnumargs; |
2863 |
goto nontoplevel_begin; |
x = SCM_CLOSURE_BODY (proc); |
2864 |
|
env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); |
2865 |
|
goto nontoplevel_begin; |
2866 |
|
} |
2867 |
case scm_tcs_struct: |
case scm_tcs_struct: |
2868 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
2869 |
{ |
{ |
2883 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
2884 |
debug.info->a.args = scm_list_1 (arg1); |
debug.info->a.args = scm_list_1 (arg1); |
2885 |
#endif |
#endif |
2886 |
if (SCM_NIMP (proc)) |
goto evap1; |
|
goto evap1; |
|
|
else |
|
|
goto badfun; |
|
2887 |
} |
} |
2888 |
case scm_tc7_subr_1: |
case scm_tc7_subr_1: |
2889 |
case scm_tc7_subr_2: |
case scm_tc7_subr_2: |
2895 |
unmemocar (x, env); |
unmemocar (x, env); |
2896 |
scm_wrong_num_args (proc); |
scm_wrong_num_args (proc); |
2897 |
default: |
default: |
2898 |
/* handle macros here */ |
badfun: |
2899 |
goto badfun; |
scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); |
2900 |
} |
} |
2901 |
} |
} |
2902 |
|
|
2916 |
{ |
{ |
2917 |
ENTER_APPLY; |
ENTER_APPLY; |
2918 |
evap1: /* inputs: proc, arg1 */ |
evap1: /* inputs: proc, arg1 */ |
2919 |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
2920 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
2921 |
{ /* have one argument in arg1 */ |
{ /* have one argument in arg1 */ |
2922 |
case scm_tc7_subr_2o: |
case scm_tc7_subr_2o: |
2983 |
#endif |
#endif |
2984 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
2985 |
goto evap1; |
goto evap1; |
2986 |
if (scm_badformalsp (proc, 1)) |
/* fallthrough */ |
|
goto umwrongnumargs; |
|
2987 |
case scm_tcs_closures: |
case scm_tcs_closures: |
2988 |
/* clos1: */ |
{ |
2989 |
x = SCM_CLOSURE_BODY (proc); |
/* clos1: */ |
2990 |
#ifdef DEVAL |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
2991 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
if (SCM_NULLP (formals) |
2992 |
debug.info->a.args, |
|| (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals)))) |
2993 |
SCM_ENV (proc)); |
goto umwrongnumargs; |
2994 |
|
x = SCM_CLOSURE_BODY (proc); |
2995 |
|
#ifdef DEVAL |
2996 |
|
env = SCM_EXTEND_ENV (formals, |
2997 |
|
debug.info->a.args, |
2998 |
|
SCM_ENV (proc)); |
2999 |
#else |
#else |
3000 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
env = SCM_EXTEND_ENV (formals, |
3001 |
scm_list_1 (arg1), |
scm_list_1 (arg1), |
3002 |
SCM_ENV (proc)); |
SCM_ENV (proc)); |
3003 |
#endif |
#endif |
3004 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
3005 |
|
} |
3006 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3007 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3008 |
{ |
{ |
3027 |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
3028 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
3029 |
#endif |
#endif |
3030 |
if (SCM_NIMP (proc)) |
goto evap2; |
|
goto evap2; |
|
|
else |
|
|
goto badfun; |
|
3031 |
} |
} |
3032 |
case scm_tc7_subr_2: |
case scm_tc7_subr_2: |
3033 |
case scm_tc7_subr_0: |
case scm_tc7_subr_0: |
3051 |
if (SCM_NULLP (x)) { |
if (SCM_NULLP (x)) { |
3052 |
ENTER_APPLY; |
ENTER_APPLY; |
3053 |
evap2: |
evap2: |
3054 |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
3055 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
3056 |
{ /* have two arguments */ |
{ /* have two arguments */ |
3057 |
case scm_tc7_subr_2: |
case scm_tc7_subr_2: |
3136 |
#endif |
#endif |
3137 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
3138 |
goto evap2; |
goto evap2; |
3139 |
if (scm_badformalsp (proc, 2)) |
/* fallthrough */ |
|
goto umwrongnumargs; |
|
3140 |
case scm_tcs_closures: |
case scm_tcs_closures: |
3141 |
/* clos2: */ |
{ |
3142 |
#ifdef DEVAL |
/* clos2: */ |
3143 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
3144 |
debug.info->a.args, |
if (SCM_NULLP (formals) |
3145 |
SCM_ENV (proc)); |
|| (SCM_CONSP (formals) |
3146 |
|
&& (SCM_NULLP (SCM_CDR (formals)) |
3147 |
|
|| (SCM_CONSP (SCM_CDR (formals)) |
3148 |
|
&& SCM_CONSP (SCM_CDDR (formals)))))) |
3149 |
|
goto umwrongnumargs; |
3150 |
|
#ifdef DEVAL |
3151 |
|
env = SCM_EXTEND_ENV (formals, |
3152 |
|
debug.info->a.args, |
3153 |
|
SCM_ENV (proc)); |
3154 |
#else |
#else |
3155 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
env = SCM_EXTEND_ENV (formals, |
3156 |
scm_list_2 (arg1, arg2), |
scm_list_2 (arg1, arg2), |
3157 |
SCM_ENV (proc)); |
SCM_ENV (proc)); |
3158 |
#endif |
#endif |
3159 |
x = SCM_CLOSURE_BODY (proc); |
x = SCM_CLOSURE_BODY (proc); |
3160 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
3161 |
|
} |
3162 |
} |
} |
3163 |
} |
} |
3164 |
if (!SCM_CONSP (x)) |
if (!SCM_CONSP (x)) |
3170 |
#endif |
#endif |
3171 |
ENTER_APPLY; |
ENTER_APPLY; |
3172 |
evap3: |
evap3: |
3173 |
|
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
3174 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
3175 |
{ /* have 3 or more arguments */ |
{ /* have 3 or more arguments */ |
3176 |
#ifdef DEVAL |
#ifdef DEVAL |
3220 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
3221 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
3222 |
goto evap3; |
goto evap3; |
3223 |
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) |
/* fallthrough */ |
|
goto umwrongnumargs; |
|
3224 |
case scm_tcs_closures: |
case scm_tcs_closures: |
3225 |
SCM_SET_ARGSREADY (debug); |
{ |
3226 |
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
3227 |
debug.info->a.args, |
if (SCM_NULLP (formals) |
3228 |
SCM_ENV (proc)); |
|| (SCM_CONSP (formals) |
3229 |
x = SCM_CLOSURE_BODY (proc); |
&& (SCM_NULLP (SCM_CDR (formals)) |
3230 |
goto nontoplevel_begin; |
|| (SCM_CONSP (SCM_CDR (formals)) |
3231 |
|
&& scm_badargsp (SCM_CDDR (formals), x))))) |
3232 |
|
goto umwrongnumargs; |
3233 |
|
SCM_SET_ARGSREADY (debug); |
3234 |
|
env = SCM_EXTEND_ENV (formals, |
3235 |
|
debug.info->a.args, |
3236 |
|
SCM_ENV (proc)); |
3237 |
|
x = SCM_CLOSURE_BODY (proc); |
3238 |
|
goto nontoplevel_begin; |
3239 |
|
} |
3240 |
#else /* DEVAL */ |
#else /* DEVAL */ |
3241 |
case scm_tc7_subr_3: |
case scm_tc7_subr_3: |
3242 |
if (!SCM_NULLP (SCM_CDR (x))) |
if (!SCM_NULLP (SCM_CDR (x))) |
3282 |
proc = SCM_PROCEDURE (proc); |
proc = SCM_PROCEDURE (proc); |
3283 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
3284 |
goto evap3; |
goto evap3; |
3285 |
|
/* fallthrough */ |
3286 |
|
case scm_tcs_closures: |
3287 |
{ |
{ |
3288 |
SCM formals = SCM_CLOSURE_FORMALS (proc); |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
3289 |
if (SCM_NULLP (formals) |
if (SCM_NULLP (formals) |
3290 |
|| (SCM_CONSP (formals) |
|| (SCM_CONSP (formals) |
3291 |
&& (SCM_NULLP (SCM_CDR (formals)) |
&& (SCM_NULLP (SCM_CDR (formals)) |
3292 |
|| (SCM_CONSP (SCM_CDR (formals)) |
|| (SCM_CONSP (SCM_CDR (formals)) |
3293 |
&& scm_badargsp (SCM_CDDR (formals), x))))) |
&& scm_badargsp (SCM_CDDR (formals), x))))) |
3294 |
goto umwrongnumargs; |
goto umwrongnumargs; |
3295 |
|
env = SCM_EXTEND_ENV (formals, |
3296 |
|
scm_cons2 (arg1, |
3297 |
|
arg2, |
3298 |
|
scm_eval_args (x, env, proc)), |
3299 |
|
SCM_ENV (proc)); |
3300 |
|
x = SCM_CLOSURE_BODY (proc); |
3301 |
|
goto nontoplevel_begin; |
3302 |
} |
} |
|
case scm_tcs_closures: |
|
|
#ifdef DEVAL |
|
|
SCM_SET_ARGSREADY (debug); |
|
|
#endif |
|
|
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
|
|
scm_cons2 (arg1, |
|
|
arg2, |
|
|
scm_eval_args (x, env, proc)), |
|
|
SCM_ENV (proc)); |
|
|
x = SCM_CLOSURE_BODY (proc); |
|
|
goto nontoplevel_begin; |
|
3303 |
#endif /* DEVAL */ |
#endif /* DEVAL */ |
3304 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3305 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |