/[guile]/guile/guile-core/libguile/eval.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eval.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.267 by dirk, Wed Mar 20 23:53:13 2002 UTC revision 1.268 by dirk, Thu Mar 21 00:36:03 2002 UTC
# Line 1884  scm_deval (SCM x, SCM env) Line 1884  scm_deval (SCM x, SCM env)
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;
# Line 2925  evapply: /* inputs: x, proc */ Line 2925  evapply: /* inputs: x, proc */
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:

Legend:
Removed from v.1.267  
changed lines
  Added in v.1.268

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26