1884 |
SCM |
SCM |
1885 |
SCM_CEVAL (SCM x, SCM env) |
SCM_CEVAL (SCM x, SCM env) |
1886 |
{ |
{ |
1887 |
SCM proc, arg1, arg2; |
SCM proc, arg1; |
1888 |
#ifdef DEVAL |
#ifdef DEVAL |
1889 |
scm_t_debug_frame debug; |
scm_t_debug_frame debug; |
1890 |
scm_t_debug_info *debug_info_end; |
scm_t_debug_info *debug_info_end; |
2925 |
debug.info->a.args = scm_list_1 (arg1); |
debug.info->a.args = scm_list_1 (arg1); |
2926 |
#endif |
#endif |
2927 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2928 |
if (SCM_NULLP (x)) |
{ |
2929 |
{ |
SCM arg2; |
2930 |
ENTER_APPLY; |
if (SCM_NULLP (x)) |
2931 |
evap1: |
{ |
2932 |
switch (SCM_TYP7 (proc)) |
ENTER_APPLY; |
2933 |
{ /* have one argument in arg1 */ |
evap1: /* inputs: proc, arg1 */ |
2934 |
case scm_tc7_subr_2o: |
switch (SCM_TYP7 (proc)) |
2935 |
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); |
{ /* have one argument in arg1 */ |
2936 |
case scm_tc7_subr_1: |
case scm_tc7_subr_2o: |
2937 |
case scm_tc7_subr_1o: |
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); |
2938 |
RETURN (SCM_SUBRF (proc) (arg1)); |
case scm_tc7_subr_1: |
2939 |
case scm_tc7_cxr: |
case scm_tc7_subr_1o: |
2940 |
if (SCM_SUBRF (proc)) |
RETURN (SCM_SUBRF (proc) (arg1)); |
2941 |
{ |
case scm_tc7_cxr: |
2942 |
if (SCM_INUMP (arg1)) |
if (SCM_SUBRF (proc)) |
2943 |
{ |
{ |
2944 |
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); |
if (SCM_INUMP (arg1)) |
2945 |
} |
{ |
2946 |
else if (SCM_REALP (arg1)) |
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); |
2947 |
{ |
} |
2948 |
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); |
else if (SCM_REALP (arg1)) |
2949 |
} |
{ |
2950 |
|
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); |
2951 |
|
} |
2952 |
#ifdef SCM_BIGDIG |
#ifdef SCM_BIGDIG |
2953 |
else if (SCM_BIGP (arg1)) |
else if (SCM_BIGP (arg1)) |
2954 |
|
{ |
2955 |
|
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); |
2956 |
|
} |
2957 |
|
#endif |
2958 |
|
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, |
2959 |
|
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); |
2960 |
|
} |
2961 |
|
proc = SCM_SNAME (proc); |
2962 |
|
{ |
2963 |
|
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; |
2964 |
|
while ('c' != *--chrs) |
2965 |
{ |
{ |
2966 |
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); |
SCM_ASSERT (SCM_CONSP (arg1), |
2967 |
|
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); |
2968 |
|
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); |
2969 |
} |
} |
2970 |
#endif |
RETURN (arg1); |
|
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, |
|
|
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); |
|
2971 |
} |
} |
2972 |
proc = SCM_SNAME (proc); |
case scm_tc7_rpsubr: |
2973 |
{ |
RETURN (SCM_BOOL_T); |
2974 |
char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; |
case scm_tc7_asubr: |
2975 |
while ('c' != *--chrs) |
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); |
2976 |
{ |
case scm_tc7_lsubr: |
|
SCM_ASSERT (SCM_CONSP (arg1), |
|
|
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); |
|
|
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); |
|
|
} |
|
|
RETURN (arg1); |
|
|
} |
|
|
case scm_tc7_rpsubr: |
|
|
RETURN (SCM_BOOL_T); |
|
|
case scm_tc7_asubr: |
|
|
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); |
|
|
case scm_tc7_lsubr: |
|
2977 |
#ifdef DEVAL |
#ifdef DEVAL |
2978 |
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); |
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); |
2979 |
#else |
#else |
2980 |
RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); |
RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); |
2981 |
#endif |
#endif |
2982 |
case scm_tc7_smob: |
case scm_tc7_smob: |
2983 |
if (!SCM_SMOB_APPLICABLE_P (proc)) |
if (!SCM_SMOB_APPLICABLE_P (proc)) |
2984 |
goto badfun; |
goto badfun; |
2985 |
RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); |
RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); |
2986 |
case scm_tc7_cclo: |
case scm_tc7_cclo: |
2987 |
arg2 = arg1; |
arg2 = arg1; |
2988 |
arg1 = proc; |
arg1 = proc; |
2989 |
proc = SCM_CCLO_SUBR (proc); |
proc = SCM_CCLO_SUBR (proc); |
2990 |
#ifdef DEVAL |
#ifdef DEVAL |
2991 |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
2992 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
2993 |
#endif |
#endif |
2994 |
goto evap2; |
goto evap2; |
2995 |
case scm_tc7_pws: |
case scm_tc7_pws: |
2996 |
proc = SCM_PROCEDURE (proc); |
proc = SCM_PROCEDURE (proc); |
2997 |
#ifdef DEVAL |
#ifdef DEVAL |
2998 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
2999 |
#endif |
#endif |
3000 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
3001 |
goto evap1; |
goto evap1; |
3002 |
if (scm_badformalsp (proc, 1)) |
if (scm_badformalsp (proc, 1)) |
3003 |
goto umwrongnumargs; |
goto umwrongnumargs; |
3004 |
case scm_tcs_closures: |
case scm_tcs_closures: |
3005 |
/* clos1: */ |
/* clos1: */ |
3006 |
x = SCM_CLOSURE_BODY (proc); |
x = SCM_CLOSURE_BODY (proc); |
3007 |
#ifdef DEVAL |
#ifdef DEVAL |
3008 |
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)); |
3009 |
#else |
#else |
3010 |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc)); |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc)); |
3011 |
#endif |
#endif |
3012 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
3013 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3014 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3015 |
{ |
{ |
3016 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
3017 |
#ifdef DEVAL |
#ifdef DEVAL |
3018 |
arg1 = debug.info->a.args; |
arg1 = debug.info->a.args; |
3019 |
#else |
#else |
3020 |
arg1 = scm_list_1 (arg1); |
arg1 = scm_list_1 (arg1); |
3021 |
#endif |
#endif |
3022 |
goto type_dispatch; |
goto type_dispatch; |
3023 |
} |
} |
3024 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
3025 |
goto badfun; |
goto badfun; |
3026 |
else |
else |
3027 |
{ |
{ |
3028 |
arg2 = arg1; |
arg2 = arg1; |
3029 |
arg1 = proc; |
arg1 = proc; |
3030 |
proc = (SCM_I_ENTITYP (proc) |
proc = (SCM_I_ENTITYP (proc) |
3031 |
? SCM_ENTITY_PROCEDURE (proc) |
? SCM_ENTITY_PROCEDURE (proc) |
3032 |
: SCM_OPERATOR_PROCEDURE (proc)); |
: SCM_OPERATOR_PROCEDURE (proc)); |
3033 |
#ifdef DEVAL |
#ifdef DEVAL |
3034 |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
debug.info->a.args = scm_cons (arg1, debug.info->a.args); |
3035 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
3036 |
#endif |
#endif |
3037 |
if (SCM_NIMP (proc)) |
if (SCM_NIMP (proc)) |
3038 |
goto evap2; |
goto evap2; |
3039 |
else |
else |
3040 |
goto badfun; |
goto badfun; |
3041 |
} |
} |
3042 |
case scm_tc7_subr_2: |
case scm_tc7_subr_2: |
3043 |
case scm_tc7_subr_0: |
case scm_tc7_subr_0: |
3044 |
case scm_tc7_subr_3: |
case scm_tc7_subr_3: |
3045 |
case scm_tc7_lsubr_2: |
case scm_tc7_lsubr_2: |
3046 |
goto wrongnumargs; |
goto wrongnumargs; |
3047 |
default: |
default: |
3048 |
goto badfun; |
goto badfun; |
3049 |
} |
} |
3050 |
} |
} |
3051 |
#ifdef SCM_CAUTIOUS |
#ifdef SCM_CAUTIOUS |
3052 |
if (SCM_IMP (x)) |
if (SCM_CONSP (x)) |
3053 |
goto wrongnumargs; |
arg2 = EVALCAR (x, env); |
3054 |
else if (SCM_CONSP (x)) |
else |
3055 |
{ |
goto wrongnumargs; |
|
if (SCM_IMP (SCM_CAR (x))) |
|
|
arg2 = SCM_EVALIM (SCM_CAR (x), env); |
|
|
else |
|
|
arg2 = EVALCELLCAR (x, env); |
|
|
} |
|
|
else |
|
|
goto wrongnumargs; |
|
3056 |
#else |
#else |
3057 |
arg2 = EVALCAR (x, env); |
arg2 = EVALCAR (x, env); |
3058 |
#endif |
#endif |
3059 |
{ /* have two or more arguments */ |
{ /* have two or more arguments */ |
3060 |
#ifdef DEVAL |
#ifdef DEVAL |
3061 |
debug.info->a.args = scm_list_2 (arg1, arg2); |
debug.info->a.args = scm_list_2 (arg1, arg2); |
3062 |
#endif |
#endif |
3063 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
3064 |
if (SCM_NULLP (x)) { |
if (SCM_NULLP (x)) { |
3065 |
ENTER_APPLY; |
ENTER_APPLY; |
3066 |
evap2: |
evap2: |
3067 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
3068 |
{ /* have two arguments */ |
{ /* have two arguments */ |
3069 |
case scm_tc7_subr_2: |
case scm_tc7_subr_2: |
3070 |
case scm_tc7_subr_2o: |
case scm_tc7_subr_2o: |
3071 |
RETURN (SCM_SUBRF (proc) (arg1, arg2)); |
RETURN (SCM_SUBRF (proc) (arg1, arg2)); |
3072 |
case scm_tc7_lsubr: |
case scm_tc7_lsubr: |
3073 |
#ifdef DEVAL |
#ifdef DEVAL |
3074 |
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); |
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); |
3075 |
#else |
#else |
3076 |
RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); |
RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); |
3077 |
#endif |
#endif |
3078 |
case scm_tc7_lsubr_2: |
case scm_tc7_lsubr_2: |
3079 |
RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); |
RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); |
3080 |
case scm_tc7_rpsubr: |
case scm_tc7_rpsubr: |
3081 |
case scm_tc7_asubr: |
case scm_tc7_asubr: |
3082 |
RETURN (SCM_SUBRF (proc) (arg1, arg2)); |
RETURN (SCM_SUBRF (proc) (arg1, arg2)); |
3083 |
case scm_tc7_smob: |
case scm_tc7_smob: |
3084 |
if (!SCM_SMOB_APPLICABLE_P (proc)) |
if (!SCM_SMOB_APPLICABLE_P (proc)) |
3085 |
goto badfun; |
goto badfun; |
3086 |
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); |
RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); |
3087 |
cclon: |
cclon: |
3088 |
case scm_tc7_cclo: |
case scm_tc7_cclo: |
3089 |
|
#ifdef DEVAL |
3090 |
|
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), |
3091 |
|
scm_cons (proc, debug.info->a.args), |
3092 |
|
SCM_EOL)); |
3093 |
|
#else |
3094 |
|
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), |
3095 |
|
scm_cons2 (proc, arg1, |
3096 |
|
scm_cons (arg2, |
3097 |
|
scm_eval_args (x, |
3098 |
|
env, |
3099 |
|
proc))), |
3100 |
|
SCM_EOL)); |
3101 |
|
#endif |
3102 |
|
case scm_tcs_struct: |
3103 |
|
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3104 |
|
{ |
3105 |
|
x = SCM_ENTITY_PROCEDURE (proc); |
3106 |
#ifdef DEVAL |
#ifdef DEVAL |
3107 |
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), |
arg1 = debug.info->a.args; |
|
scm_cons (proc, debug.info->a.args), |
|
|
SCM_EOL)); |
|
3108 |
#else |
#else |
3109 |
RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), |
arg1 = scm_list_2 (arg1, arg2); |
|
scm_cons2 (proc, arg1, |
|
|
scm_cons (arg2, |
|
|
scm_eval_args (x, |
|
|
env, |
|
|
proc))), |
|
|
SCM_EOL)); |
|
3110 |
#endif |
#endif |
3111 |
case scm_tcs_struct: |
goto type_dispatch; |
3112 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
} |
3113 |
{ |
else if (!SCM_I_OPERATORP (proc)) |
3114 |
x = SCM_ENTITY_PROCEDURE (proc); |
goto badfun; |
3115 |
|
else |
3116 |
|
{ |
3117 |
|
operatorn: |
3118 |
#ifdef DEVAL |
#ifdef DEVAL |
3119 |
arg1 = debug.info->a.args; |
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) |
3120 |
|
? SCM_ENTITY_PROCEDURE (proc) |
3121 |
|
: SCM_OPERATOR_PROCEDURE (proc), |
3122 |
|
scm_cons (proc, debug.info->a.args), |
3123 |
|
SCM_EOL)); |
3124 |
#else |
#else |
3125 |
arg1 = scm_list_2 (arg1, arg2); |
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) |
3126 |
|
? SCM_ENTITY_PROCEDURE (proc) |
3127 |
|
: SCM_OPERATOR_PROCEDURE (proc), |
3128 |
|
scm_cons2 (proc, arg1, |
3129 |
|
scm_cons (arg2, |
3130 |
|
scm_eval_args (x, |
3131 |
|
env, |
3132 |
|
proc))), |
3133 |
|
SCM_EOL)); |
3134 |
#endif |
#endif |
3135 |
goto type_dispatch; |
} |
3136 |
} |
case scm_tc7_subr_0: |
3137 |
else if (!SCM_I_OPERATORP (proc)) |
case scm_tc7_cxr: |
3138 |
|
case scm_tc7_subr_1o: |
3139 |
|
case scm_tc7_subr_1: |
3140 |
|
case scm_tc7_subr_3: |
3141 |
|
goto wrongnumargs; |
3142 |
|
default: |
3143 |
goto badfun; |
goto badfun; |
3144 |
else |
case scm_tc7_pws: |
3145 |
{ |
proc = SCM_PROCEDURE (proc); |
|
operatorn: |
|
3146 |
#ifdef DEVAL |
#ifdef DEVAL |
3147 |
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) |
debug.info->a.proc = proc; |
3148 |
? SCM_ENTITY_PROCEDURE (proc) |
#endif |
3149 |
: SCM_OPERATOR_PROCEDURE (proc), |
if (!SCM_CLOSUREP (proc)) |
3150 |
scm_cons (proc, debug.info->a.args), |
goto evap2; |
3151 |
SCM_EOL)); |
if (scm_badformalsp (proc, 2)) |
3152 |
|
goto umwrongnumargs; |
3153 |
|
case scm_tcs_closures: |
3154 |
|
/* clos2: */ |
3155 |
|
#ifdef DEVAL |
3156 |
|
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
3157 |
|
debug.info->a.args, |
3158 |
|
SCM_ENV (proc)); |
3159 |
#else |
#else |
3160 |
RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
3161 |
? SCM_ENTITY_PROCEDURE (proc) |
scm_list_2 (arg1, arg2), SCM_ENV (proc)); |
|
: SCM_OPERATOR_PROCEDURE (proc), |
|
|
scm_cons2 (proc, arg1, |
|
|
scm_cons (arg2, |
|
|
scm_eval_args (x, |
|
|
env, |
|
|
proc))), |
|
|
SCM_EOL)); |
|
3162 |
#endif |
#endif |
3163 |
} |
x = SCM_CLOSURE_BODY (proc); |
3164 |
case scm_tc7_subr_0: |
goto nontoplevel_begin; |
3165 |
case scm_tc7_cxr: |
} |
3166 |
case scm_tc7_subr_1o: |
} |
3167 |
case scm_tc7_subr_1: |
#ifdef SCM_CAUTIOUS |
3168 |
|
if (!SCM_CONSP (x)) |
3169 |
|
goto wrongnumargs; |
3170 |
|
#endif |
3171 |
|
#ifdef DEVAL |
3172 |
|
debug.info->a.args = scm_cons2 (arg1, arg2, |
3173 |
|
deval_args (x, env, proc, |
3174 |
|
SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); |
3175 |
|
#endif |
3176 |
|
ENTER_APPLY; |
3177 |
|
evap3: |
3178 |
|
switch (SCM_TYP7 (proc)) |
3179 |
|
{ /* have 3 or more arguments */ |
3180 |
|
#ifdef DEVAL |
3181 |
case scm_tc7_subr_3: |
case scm_tc7_subr_3: |
3182 |
goto wrongnumargs; |
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); |
3183 |
default: |
RETURN (SCM_SUBRF (proc) (arg1, arg2, |
3184 |
goto badfun; |
SCM_CADDR (debug.info->a.args))); |
3185 |
|
case scm_tc7_asubr: |
3186 |
|
arg1 = SCM_SUBRF(proc)(arg1, arg2); |
3187 |
|
arg2 = SCM_CDDR (debug.info->a.args); |
3188 |
|
do |
3189 |
|
{ |
3190 |
|
arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); |
3191 |
|
arg2 = SCM_CDR (arg2); |
3192 |
|
} |
3193 |
|
while (SCM_NIMP (arg2)); |
3194 |
|
RETURN (arg1); |
3195 |
|
case scm_tc7_rpsubr: |
3196 |
|
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) |
3197 |
|
RETURN (SCM_BOOL_F); |
3198 |
|
arg1 = SCM_CDDR (debug.info->a.args); |
3199 |
|
do |
3200 |
|
{ |
3201 |
|
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) |
3202 |
|
RETURN (SCM_BOOL_F); |
3203 |
|
arg2 = SCM_CAR (arg1); |
3204 |
|
arg1 = SCM_CDR (arg1); |
3205 |
|
} |
3206 |
|
while (SCM_NIMP (arg1)); |
3207 |
|
RETURN (SCM_BOOL_T); |
3208 |
|
case scm_tc7_lsubr_2: |
3209 |
|
RETURN (SCM_SUBRF (proc) (arg1, arg2, |
3210 |
|
SCM_CDDR (debug.info->a.args))); |
3211 |
|
case scm_tc7_lsubr: |
3212 |
|
RETURN (SCM_SUBRF (proc) (debug.info->a.args)); |
3213 |
|
case scm_tc7_smob: |
3214 |
|
if (!SCM_SMOB_APPLICABLE_P (proc)) |
3215 |
|
goto badfun; |
3216 |
|
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, |
3217 |
|
SCM_CDDR (debug.info->a.args))); |
3218 |
|
case scm_tc7_cclo: |
3219 |
|
goto cclon; |
3220 |
case scm_tc7_pws: |
case scm_tc7_pws: |
3221 |
proc = SCM_PROCEDURE (proc); |
proc = SCM_PROCEDURE (proc); |
|
#ifdef DEVAL |
|
3222 |
debug.info->a.proc = proc; |
debug.info->a.proc = proc; |
|
#endif |
|
3223 |
if (!SCM_CLOSUREP (proc)) |
if (!SCM_CLOSUREP (proc)) |
3224 |
goto evap2; |
goto evap3; |
3225 |
if (scm_badformalsp (proc, 2)) |
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) |
3226 |
goto umwrongnumargs; |
goto umwrongnumargs; |
3227 |
case scm_tcs_closures: |
case scm_tcs_closures: |
3228 |
/* clos2: */ |
SCM_SET_ARGSREADY (debug); |
|
#ifdef DEVAL |
|
3229 |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
3230 |
debug.info->a.args, |
debug.info->a.args, |
3231 |
SCM_ENV (proc)); |
SCM_ENV (proc)); |
|
#else |
|
|
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
|
|
scm_list_2 (arg1, arg2), SCM_ENV (proc)); |
|
|
#endif |
|
3232 |
x = SCM_CLOSURE_BODY (proc); |
x = SCM_CLOSURE_BODY (proc); |
3233 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
|
} |
|
|
} |
|
|
#ifdef SCM_CAUTIOUS |
|
|
if (SCM_IMP (x) || !SCM_CONSP (x)) |
|
|
goto wrongnumargs; |
|
|
#endif |
|
|
#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: |
|
|
switch (SCM_TYP7 (proc)) |
|
|
{ /* have 3 or more arguments */ |
|
|
#ifdef DEVAL |
|
|
case scm_tc7_subr_3: |
|
|
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); |
|
|
RETURN (SCM_SUBRF (proc) (arg1, arg2, |
|
|
SCM_CADDR (debug.info->a.args))); |
|
|
case scm_tc7_asubr: |
|
|
#ifdef BUILTIN_RPASUBR |
|
|
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); |
|
|
#endif /* BUILTIN_RPASUBR */ |
|
|
case scm_tc7_rpsubr: |
|
|
#ifdef BUILTIN_RPASUBR |
|
|
if (SCM_FALSEP (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)))) |
|
|
RETURN (SCM_BOOL_F); |
|
|
arg2 = SCM_CAR (arg1); |
|
|
arg1 = SCM_CDR (arg1); |
|
|
} |
|
|
while (SCM_NIMP (arg1)); |
|
|
RETURN (SCM_BOOL_T); |
|
|
#else /* BUILTIN_RPASUBR */ |
|
|
RETURN (SCM_APPLY (proc, arg1, |
|
|
scm_acons (arg2, |
|
|
SCM_CDDR (debug.info->a.args), |
|
|
SCM_EOL))); |
|
|
#endif /* BUILTIN_RPASUBR */ |
|
|
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_cclo: |
|
|
goto cclon; |
|
|
case scm_tc7_pws: |
|
|
proc = SCM_PROCEDURE (proc); |
|
|
debug.info->a.proc = proc; |
|
|
if (!SCM_CLOSUREP (proc)) |
|
|
goto evap3; |
|
|
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) |
|
|
goto umwrongnumargs; |
|
|
case scm_tcs_closures: |
|
|
SCM_SET_ARGSREADY (debug); |
|
|
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
|
|
debug.info->a.args, |
|
|
SCM_ENV (proc)); |
|
|
x = SCM_CLOSURE_BODY (proc); |
|
|
goto nontoplevel_begin; |
|
3234 |
#else /* DEVAL */ |
#else /* DEVAL */ |
3235 |
case scm_tc7_subr_3: |
case scm_tc7_subr_3: |
3236 |
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); |
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); |
3237 |
RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); |
RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); |
3238 |
case scm_tc7_asubr: |
case scm_tc7_asubr: |
3239 |
#ifdef BUILTIN_RPASUBR |
arg1 = SCM_SUBRF (proc) (arg1, arg2); |
3240 |
arg1 = SCM_SUBRF (proc) (arg1, arg2); |
do |
3241 |
do |
{ |
3242 |
{ |
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); |
3243 |
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); |
x = SCM_CDR(x); |
3244 |
x = SCM_CDR(x); |
} |
3245 |
} |
while (SCM_NIMP (x)); |
3246 |
while (SCM_NIMP (x)); |
RETURN (arg1); |
3247 |
RETURN (arg1); |
case scm_tc7_rpsubr: |
3248 |
#endif /* BUILTIN_RPASUBR */ |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) |
3249 |
case scm_tc7_rpsubr: |
RETURN (SCM_BOOL_F); |
3250 |
#ifdef BUILTIN_RPASUBR |
do |
3251 |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) |
{ |
3252 |
RETURN (SCM_BOOL_F); |
arg1 = EVALCAR (x, env); |
3253 |
do |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) |
3254 |
|
RETURN (SCM_BOOL_F); |
3255 |
|
arg2 = arg1; |
3256 |
|
x = SCM_CDR (x); |
3257 |
|
} |
3258 |
|
while (SCM_NIMP (x)); |
3259 |
|
RETURN (SCM_BOOL_T); |
3260 |
|
case scm_tc7_lsubr_2: |
3261 |
|
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); |
3262 |
|
case scm_tc7_lsubr: |
3263 |
|
RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, |
3264 |
|
arg2, |
3265 |
|
scm_eval_args (x, env, proc)))); |
3266 |
|
case scm_tc7_smob: |
3267 |
|
if (!SCM_SMOB_APPLICABLE_P (proc)) |
3268 |
|
goto badfun; |
3269 |
|
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, |
3270 |
|
scm_eval_args (x, env, proc))); |
3271 |
|
case scm_tc7_cclo: |
3272 |
|
goto cclon; |
3273 |
|
case scm_tc7_pws: |
3274 |
|
proc = SCM_PROCEDURE (proc); |
3275 |
|
if (!SCM_CLOSUREP (proc)) |
3276 |
|
goto evap3; |
3277 |
{ |
{ |
3278 |
arg1 = EVALCAR (x, env); |
SCM formals = SCM_CLOSURE_FORMALS (proc); |
3279 |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) |
if (SCM_NULLP (formals) |
3280 |
RETURN (SCM_BOOL_F); |
|| (SCM_CONSP (formals) |
3281 |
arg2 = arg1; |
&& (SCM_NULLP (SCM_CDR (formals)) |
3282 |
x = SCM_CDR (x); |
|| (SCM_CONSP (SCM_CDR (formals)) |
3283 |
|
&& scm_badargsp (SCM_CDDR (formals), x))))) |
3284 |
|
goto umwrongnumargs; |
3285 |
} |
} |
3286 |
while (SCM_NIMP (x)); |
case scm_tcs_closures: |
|
RETURN (SCM_BOOL_T); |
|
|
#else /* BUILTIN_RPASUBR */ |
|
|
RETURN (SCM_APPLY (proc, arg1, |
|
|
scm_acons (arg2, |
|
|
scm_eval_args (x, env, proc), |
|
|
SCM_EOL))); |
|
|
#endif /* BUILTIN_RPASUBR */ |
|
|
case scm_tc7_lsubr_2: |
|
|
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); |
|
|
case scm_tc7_lsubr: |
|
|
RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, |
|
|
arg2, |
|
|
scm_eval_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_eval_args (x, env, proc))); |
|
|
case scm_tc7_cclo: |
|
|
goto cclon; |
|
|
case scm_tc7_pws: |
|
|
proc = SCM_PROCEDURE (proc); |
|
|
if (!SCM_CLOSUREP (proc)) |
|
|
goto evap3; |
|
|
{ |
|
|
SCM formals = SCM_CLOSURE_FORMALS (proc); |
|
|
if (SCM_NULLP (formals) |
|
|
|| (SCM_CONSP (formals) |
|
|
&& (SCM_NULLP (SCM_CDR (formals)) |
|
|
|| (SCM_CONSP (SCM_CDR (formals)) |
|
|
&& scm_badargsp (SCM_CDDR (formals), x))))) |
|
|
goto umwrongnumargs; |
|
|
} |
|
|
case scm_tcs_closures: |
|
3287 |
#ifdef DEVAL |
#ifdef DEVAL |
3288 |
SCM_SET_ARGSREADY (debug); |
SCM_SET_ARGSREADY (debug); |
3289 |
#endif |
#endif |
3290 |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
3291 |
scm_cons2 (arg1, |
scm_cons2 (arg1, |
3292 |
arg2, |
arg2, |
3293 |
scm_eval_args (x, env, proc)), |
scm_eval_args (x, env, proc)), |
3294 |
SCM_ENV (proc)); |
SCM_ENV (proc)); |
3295 |
x = SCM_CLOSURE_BODY (proc); |
x = SCM_CLOSURE_BODY (proc); |
3296 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
3297 |
#endif /* DEVAL */ |
#endif /* DEVAL */ |
3298 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3299 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3300 |
{ |
{ |
3301 |
#ifdef DEVAL |
#ifdef DEVAL |
3302 |
arg1 = debug.info->a.args; |
arg1 = debug.info->a.args; |
3303 |
#else |
#else |
3304 |
arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); |
arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); |
3305 |
#endif |
#endif |
3306 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
3307 |
goto type_dispatch; |
goto type_dispatch; |
3308 |
} |
} |
3309 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
3310 |
|
goto badfun; |
3311 |
|
else |
3312 |
|
goto operatorn; |
3313 |
|
case scm_tc7_subr_2: |
3314 |
|
case scm_tc7_subr_1o: |
3315 |
|
case scm_tc7_subr_2o: |
3316 |
|
case scm_tc7_subr_0: |
3317 |
|
case scm_tc7_cxr: |
3318 |
|
case scm_tc7_subr_1: |
3319 |
|
goto wrongnumargs; |
3320 |
|
default: |
3321 |
goto badfun; |
goto badfun; |
3322 |
else |
} |
3323 |
goto operatorn; |
} |
|
case scm_tc7_subr_2: |
|
|
case scm_tc7_subr_1o: |
|
|
case scm_tc7_subr_2o: |
|
|
case scm_tc7_subr_0: |
|
|
case scm_tc7_cxr: |
|
|
case scm_tc7_subr_1: |
|
|
goto wrongnumargs; |
|
|
default: |
|
|
goto badfun; |
|
|
} |
|
3324 |
} |
} |
3325 |
#ifdef DEVAL |
#ifdef DEVAL |
3326 |
exit: |
exit: |