/[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.308 by mdj, Thu May 22 09:16:32 2003 UTC revision 1.309 by dirk, Sun May 25 07:50:23 2003 UTC
# Line 1640  scm_badargsp (SCM formals, SCM args) Line 1640  scm_badargsp (SCM formals, SCM args)
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)
# Line 2188  dispatch: Line 2171  dispatch:
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);
# Line 2399  dispatch: Line 2378  dispatch:
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    
# Line 2407  dispatch: Line 2385  dispatch:
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);
# Line 2466  dispatch: Line 2443  dispatch:
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            }            }
# Line 2725  dispatch: Line 2699  dispatch:
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
# Line 2761  dispatch: Line 2734  dispatch:
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)))
# Line 2778  dispatch: Line 2750  dispatch:
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
# Line 2844  dispatch: Line 2810  dispatch:
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    
# Line 2873  evapply: /* inputs: x, proc */ Line 2822  evapply: /* inputs: x, proc */
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:
# Line 2904  evapply: /* inputs: x, proc */ Line 2854  evapply: /* inputs: x, proc */
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            {            {
# Line 2931  evapply: /* inputs: x, proc */ Line 2883  evapply: /* inputs: x, proc */
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:
# Line 2946  evapply: /* inputs: x, proc */ Line 2895  evapply: /* inputs: x, proc */
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    
# Line 2967  evapply: /* inputs: x, proc */ Line 2916  evapply: /* inputs: x, proc */
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:
# Line 3033  evapply: /* inputs: x, proc */ Line 2983  evapply: /* inputs: x, proc */
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                {                {
# Line 3072  evapply: /* inputs: x, proc */ Line 3027  evapply: /* inputs: x, proc */
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:
# Line 3099  evapply: /* inputs: x, proc */ Line 3051  evapply: /* inputs: x, proc */
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:
# Line 3183  evapply: /* inputs: x, proc */ Line 3136  evapply: /* inputs: x, proc */
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))
# Line 3209  evapply: /* inputs: x, proc */ Line 3170  evapply: /* inputs: x, proc */
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
# Line 3258  evapply: /* inputs: x, proc */ Line 3220  evapply: /* inputs: x, proc */
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)))
# Line 3312  evapply: /* inputs: x, proc */ Line 3282  evapply: /* inputs: x, proc */
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)

Legend:
Removed from v.1.308  
changed lines
  Added in v.1.309

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