/[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.264 by ttn, Thu Mar 14 03:47:41 2002 UTC revision 1.265 by dirk, Thu Mar 14 06:45:56 2002 UTC
# Line 1890  scm_deval (SCM x, SCM env) Line 1890  scm_deval (SCM x, SCM env)
1890  SCM  SCM
1891  SCM_CEVAL (SCM x, SCM env)  SCM_CEVAL (SCM x, SCM env)
1892  {  {
1893    union    SCM proc, arg1, arg2, orig_sym;
     {  
       SCM *lloc;  
       SCM arg1;  
    } t;  
   SCM proc, arg2, orig_sym;  
1894  #ifdef DEVAL  #ifdef DEVAL
1895    scm_t_debug_frame debug;    scm_t_debug_frame debug;
1896    scm_t_debug_info *debug_info_end;    scm_t_debug_info *debug_info_end;
# Line 1961  start: Line 1956  start:
1956          SCM tail = SCM_BOOL(SCM_TAILRECP (debug));          SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
1957          SCM_SET_TAILREC (debug);          SCM_SET_TAILREC (debug);
1958          if (SCM_CHEAPTRAPS_P)          if (SCM_CHEAPTRAPS_P)
1959            t.arg1 = scm_make_debugobj (&debug);            arg1 = scm_make_debugobj (&debug);
1960          else          else
1961            {            {
1962              int first;              int first;
1963              SCM val = scm_make_continuation (&first);              SCM val = scm_make_continuation (&first);
1964                            
1965              if (first)              if (first)
1966                t.arg1 = val;                arg1 = val;
1967              else              else
1968                {                {
1969                  x = val;                  x = val;
# Line 1983  start: Line 1978  start:
1978          SCM_TRAPS_P = 0;          SCM_TRAPS_P = 0;
1979          scm_call_4 (SCM_ENTER_FRAME_HDLR,          scm_call_4 (SCM_ENTER_FRAME_HDLR,
1980                      scm_sym_enter_frame,                      scm_sym_enter_frame,
1981                      t.arg1,                      arg1,
1982                      tail,                      tail,
1983                      scm_unmemocopy (x, env));                      scm_unmemocopy (x, env));
1984          SCM_TRAPS_P = 1;          SCM_TRAPS_P = 1;
# Line 2130  dispatch: Line 2125  dispatch:
2125              }              }
2126            else            else
2127              {              {
2128                t.arg1 = EVALCAR (clause, env);                arg1 = EVALCAR (clause, env);
2129                if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1))                if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
2130                  {                  {
2131                    x = SCM_CDR (clause);                    x = SCM_CDR (clause);
2132                    if (SCM_NULLP (x))                    if (SCM_NULLP (x))
2133                      RETURN (t.arg1);                      RETURN (arg1);
2134                    else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow))                    else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow))
2135                      {                      {
2136                        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);                        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
# Line 2146  dispatch: Line 2141  dispatch:
2141                        proc = SCM_CDR (x);                        proc = SCM_CDR (x);
2142                        proc = EVALCAR (proc, env);                        proc = EVALCAR (proc, env);
2143                        SCM_ASRTGO (!SCM_IMP (proc), badfun);                        SCM_ASRTGO (!SCM_IMP (proc), badfun);
2144                        PREP_APPLY (proc, scm_list_1 (t.arg1));                        PREP_APPLY (proc, scm_list_1 (arg1));
2145                        ENTER_APPLY;                        ENTER_APPLY;
2146                        if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))                        if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
2147                          goto umwrongnumargs;                          goto umwrongnumargs;
# Line 2362  dispatch: Line 2357  dispatch:
2357            if (SCM_CLOSUREP (proc))            if (SCM_CLOSUREP (proc))
2358              {              {
2359                PREP_APPLY (proc, SCM_EOL);                PREP_APPLY (proc, SCM_EOL);
2360                t.arg1 = SCM_CDDR (x);                arg1 = SCM_CDDR (x);
2361                t.arg1 = EVALCAR (t.arg1, env);                arg1 = EVALCAR (arg1, env);
2362              apply_closure:              apply_closure:
2363                /* Go here to tail-call a closure.  PROC is the closure                /* Go here to tail-call a closure.  PROC is the closure
2364                   and T.ARG1 is the list of arguments.  Do not forget to                   and ARG1 is the list of arguments.  Do not forget to
2365                   call PREP_APPLY. */                   call PREP_APPLY. */
2366                {                {
2367                  SCM formals = SCM_CLOSURE_FORMALS (proc);                  SCM formals = SCM_CLOSURE_FORMALS (proc);
2368  #ifdef DEVAL  #ifdef DEVAL
2369                  debug.info->a.args = t.arg1;                  debug.info->a.args = arg1;
2370  #endif  #endif
2371  #ifndef SCM_RECKLESS  #ifndef SCM_RECKLESS
2372                  if (scm_badargsp (formals, t.arg1))                  if (scm_badargsp (formals, arg1))
2373                    goto wrongnumargs;                    goto wrongnumargs;
2374  #endif  #endif
2375                  ENTER_APPLY;                  ENTER_APPLY;
2376                  /* Copy argument list */                  /* Copy argument list */
2377                  if (SCM_NULL_OR_NIL_P (t.arg1))                  if (SCM_NULL_OR_NIL_P (arg1))
2378                    env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));                    env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
2379                  else                  else
2380                    {                    {
2381                      SCM args = scm_list_1 (SCM_CAR (t.arg1));                      SCM args = scm_list_1 (SCM_CAR (arg1));
2382                      SCM tail = args;                      SCM tail = args;
2383                      t.arg1 = SCM_CDR (t.arg1);                      arg1 = SCM_CDR (arg1);
2384                      while (!SCM_NULL_OR_NIL_P (t.arg1))                      while (!SCM_NULL_OR_NIL_P (arg1))
2385                        {                        {
2386                          SCM new_tail = scm_list_1 (SCM_CAR (t.arg1));                          SCM new_tail = scm_list_1 (SCM_CAR (arg1));
2387                          SCM_SETCDR (tail, new_tail);                          SCM_SETCDR (tail, new_tail);
2388                          tail = new_tail;                          tail = new_tail;
2389                          t.arg1 = SCM_CDR (t.arg1);                          arg1 = SCM_CDR (arg1);
2390                        }                        }
2391                      env = EXTEND_ENV (formals, args, SCM_ENV (proc));                      env = EXTEND_ENV (formals, args, SCM_ENV (proc));
2392                    }                    }
# Line 2413  dispatch: Line 2408  dispatch:
2408              SCM val = scm_make_continuation (&first);              SCM val = scm_make_continuation (&first);
2409    
2410              if (first)              if (first)
2411                t.arg1 = val;                arg1 = val;
2412              else              else
2413                RETURN (val);                RETURN (val);
2414            }            }
2415            proc = SCM_CDR (x);            proc = SCM_CDR (x);
2416            proc = scm_eval_car (proc, env);            proc = scm_eval_car (proc, env);
2417            SCM_ASRTGO (SCM_NIMP (proc), badfun);            SCM_ASRTGO (SCM_NIMP (proc), badfun);
2418            PREP_APPLY (proc, scm_list_1 (t.arg1));            PREP_APPLY (proc, scm_list_1 (arg1));
2419            ENTER_APPLY;            ENTER_APPLY;
2420            if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))            if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
2421              goto umwrongnumargs;              goto umwrongnumargs;
# Line 2432  dispatch: Line 2427  dispatch:
2427          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
2428            {            {
2429              /* If not done yet, evaluate the operand forms.  The result is a              /* If not done yet, evaluate the operand forms.  The result is a
2430               * 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
2431               * function dispatch.  */               * function dispatch.  */
2432              SCM operand_forms = SCM_CADR (x);              SCM operand_forms = SCM_CADR (x);
2433              PREP_APPLY (SCM_UNDEFINED, SCM_EOL);              PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2434              if (SCM_ILOCP (operand_forms))              if (SCM_ILOCP (operand_forms))
2435                t.arg1 = *scm_ilookup (operand_forms, env);                arg1 = *scm_ilookup (operand_forms, env);
2436              else if (SCM_VARIABLEP (operand_forms))              else if (SCM_VARIABLEP (operand_forms))
2437                t.arg1 = SCM_VARIABLE_REF (operand_forms);                arg1 = SCM_VARIABLE_REF (operand_forms);
2438              else if (!SCM_CONSP (operand_forms))              else if (!SCM_CONSP (operand_forms))
2439                t.arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);                arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);
2440              else              else
2441                {                {
2442                  SCM tail = t.arg1 = scm_list_1 (EVALCAR (operand_forms, env));                  SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env));
2443                  operand_forms = SCM_CDR (operand_forms);                  operand_forms = SCM_CDR (operand_forms);
2444                  while (!SCM_NULLP (operand_forms))                  while (!SCM_NULLP (operand_forms))
2445                    {                    {
# Line 2459  dispatch: Line 2454  dispatch:
2454            /* The type dispatch code is duplicated below            /* The type dispatch code is duplicated below
2455             * (c.f. objects.c:scm_mcache_compute_cmethod) since that             * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2456             * cuts down execution time for type dispatch to 50%.  */             * cuts down execution time for type dispatch to 50%.  */
2457          type_dispatch: /* inputs: x, t.arg1 */          type_dispatch: /* inputs: x, arg1 */
2458            /* Type dispatch means to determine from the types of the function            /* Type dispatch means to determine from the types of the function
2459             * arguments (i. e. the 'signature' of the call), which method from             * arguments (i. e. the 'signature' of the call), which method from
2460             * a generic function is to be called.  This process of selecting             * a generic function is to be called.  This process of selecting
# Line 2514  dispatch: Line 2509  dispatch:
2509                     * method in the method cache.  */                     * method in the method cache.  */
2510                    unsigned long int hashset = SCM_INUM (tmp);                    unsigned long int hashset = SCM_INUM (tmp);
2511                    unsigned long int counter = specializers + 1;                    unsigned long int counter = specializers + 1;
2512                    SCM tmp_arg = t.arg1;                    SCM tmp_arg = arg1;
2513                    hash_value = 0;                    hash_value = 0;
2514                    while (!SCM_NULLP (tmp_arg) && counter != 0)                    while (!SCM_NULLP (tmp_arg) && counter != 0)
2515                      {                      {
# Line 2553  dispatch: Line 2548  dispatch:
2548                SCM z;                SCM z;
2549                do                do
2550                  {                  {
2551                    SCM args = t.arg1; /* list of arguments */                    SCM args = arg1; /* list of arguments */
2552                    z = SCM_VELTS (method_cache)[hash_value];                    z = SCM_VELTS (method_cache)[hash_value];
2553                    while (!SCM_NULLP (args))                    while (!SCM_NULLP (args))
2554                      {                      {
# Line 2572  dispatch: Line 2567  dispatch:
2567                  } while (hash_value != cache_end_pos);                  } while (hash_value != cache_end_pos);
2568    
2569                /* No appropriate method was found in the cache.  */                /* No appropriate method was found in the cache.  */
2570                z = scm_memoize_method (x, t.arg1);                z = scm_memoize_method (x, arg1);
2571    
2572              apply_cmethod: /* inputs: z, t.arg1 */              apply_cmethod: /* inputs: z, arg1 */
2573                {                {
2574                  SCM formals = SCM_CMETHOD_FORMALS (z);                  SCM formals = SCM_CMETHOD_FORMALS (z);
2575                  env = EXTEND_ENV (formals, t.arg1, SCM_CMETHOD_ENV (z));                  env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
2576                  x = SCM_CMETHOD_BODY (z);                  x = SCM_CMETHOD_BODY (z);
2577                  goto nontoplevel_begin;                  goto nontoplevel_begin;
2578                }                }
# Line 2675  dispatch: Line 2670  dispatch:
2670              x = EVALCAR (proc, env);              x = EVALCAR (proc, env);
2671              proc = SCM_CDR (proc);              proc = SCM_CDR (proc);
2672              proc = EVALCAR (proc, env);              proc = EVALCAR (proc, env);
2673              t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);              arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
2674              if (SCM_VALUESP (t.arg1))              if (SCM_VALUESP (arg1))
2675                t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0);                arg1 = scm_struct_ref (arg1, SCM_INUM0);
2676              else              else
2677                t.arg1 = scm_list_1 (t.arg1);                arg1 = scm_list_1 (arg1);
2678              if (SCM_CLOSUREP (proc))              if (SCM_CLOSUREP (proc))
2679                {                {
2680                  PREP_APPLY (proc, t.arg1);                  PREP_APPLY (proc, arg1);
2681                  goto apply_closure;                  goto apply_closure;
2682                }                }
2683              return SCM_APPLY (proc, t.arg1, SCM_EOL);              return SCM_APPLY (proc, arg1, SCM_EOL);
2684            }            }
2685    
2686    
# Line 2770  dispatch: Line 2765  dispatch:
2765                   application frames can be deleted from the backtrace. */                   application frames can be deleted from the backtrace. */
2766                SCM_SET_MACROEXP (debug);                SCM_SET_MACROEXP (debug);
2767  #endif  #endif
2768                t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,                arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
2769                                    scm_cons (env, scm_listofnull));                                    scm_cons (env, scm_listofnull));
2770    
2771  #ifdef DEVAL  #ifdef DEVAL
# Line 2779  dispatch: Line 2774  dispatch:
2774                switch (SCM_MACRO_TYPE (proc))                switch (SCM_MACRO_TYPE (proc))
2775                  {                  {
2776                  case 2:                  case 2:
2777                    if (scm_ilength (t.arg1) <= 0)                    if (scm_ilength (arg1) <= 0)
2778                      t.arg1 = scm_list_2 (SCM_IM_BEGIN, t.arg1);                      arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
2779  #ifdef DEVAL  #ifdef DEVAL
2780                    if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))                    if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
2781                      {                      {
2782                        SCM_DEFER_INTS;                        SCM_DEFER_INTS;
2783                        SCM_SETCAR (x, SCM_CAR (t.arg1));                        SCM_SETCAR (x, SCM_CAR (arg1));
2784                        SCM_SETCDR (x, SCM_CDR (t.arg1));                        SCM_SETCDR (x, SCM_CDR (arg1));
2785                        SCM_ALLOW_INTS;                        SCM_ALLOW_INTS;
2786                        goto dispatch;                        goto dispatch;
2787                      }                      }
# Line 2796  dispatch: Line 2791  dispatch:
2791                                                         SCM_CDR (x));                                                         SCM_CDR (x));
2792  #endif  #endif
2793                    SCM_DEFER_INTS;                    SCM_DEFER_INTS;
2794                    SCM_SETCAR (x, SCM_CAR (t.arg1));                    SCM_SETCAR (x, SCM_CAR (arg1));
2795                    SCM_SETCDR (x, SCM_CDR (t.arg1));                    SCM_SETCDR (x, SCM_CDR (arg1));
2796                    SCM_ALLOW_INTS;                    SCM_ALLOW_INTS;
2797                    goto loopnoap;                    goto loopnoap;
2798                  case 1:                  case 1:
2799                    if (SCM_NIMP (x = t.arg1))                    if (SCM_NIMP (x = arg1))
2800                      goto loopnoap;                      goto loopnoap;
2801                  case 0:                  case 0:
2802                    RETURN (t.arg1);                    RETURN (arg1);
2803                  }                  }
2804              }              }
2805          }          }
# Line 2818  dispatch: Line 2813  dispatch:
2813        if (SCM_CLOSUREP (proc))        if (SCM_CLOSUREP (proc))
2814          {          {
2815            arg2 = SCM_CLOSURE_FORMALS (proc);            arg2 = SCM_CLOSURE_FORMALS (proc);
2816            t.arg1 = SCM_CDR (x);            arg1 = SCM_CDR (x);
2817            while (!SCM_NULLP (arg2))            while (!SCM_NULLP (arg2))
2818              {              {
2819                if (!SCM_CONSP (arg2))                if (!SCM_CONSP (arg2))
2820                  goto evapply;                  goto evapply;
2821                if (SCM_IMP (t.arg1))                if (SCM_IMP (arg1))
2822                  goto umwrongnumargs;                  goto umwrongnumargs;
2823                arg2 = SCM_CDR (arg2);                arg2 = SCM_CDR (arg2);
2824                t.arg1 = SCM_CDR (t.arg1);                arg1 = SCM_CDR (arg1);
2825              }              }
2826            if (!SCM_NULLP (t.arg1))            if (!SCM_NULLP (arg1))
2827              goto umwrongnumargs;              goto umwrongnumargs;
2828          }          }
2829        else if (SCM_MACROP (proc))        else if (SCM_MACROP (proc))
# Line 2859  evapply: Line 2854  evapply:
2854            goto badfun;            goto badfun;
2855          RETURN (SCM_SMOB_APPLY_0 (proc));          RETURN (SCM_SMOB_APPLY_0 (proc));
2856        case scm_tc7_cclo:        case scm_tc7_cclo:
2857          t.arg1 = proc;          arg1 = proc;
2858          proc = SCM_CCLO_SUBR (proc);          proc = SCM_CCLO_SUBR (proc);
2859  #ifdef DEVAL  #ifdef DEVAL
2860          debug.info->a.proc = proc;          debug.info->a.proc = proc;
2861          debug.info->a.args = scm_list_1 (t.arg1);          debug.info->a.args = scm_list_1 (arg1);
2862  #endif  #endif
2863          goto evap1;          goto evap1;
2864        case scm_tc7_pws:        case scm_tc7_pws:
# Line 2883  evapply: Line 2878  evapply:
2878          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2879            {            {
2880              x = SCM_ENTITY_PROCEDURE (proc);              x = SCM_ENTITY_PROCEDURE (proc);
2881              t.arg1 = SCM_EOL;              arg1 = SCM_EOL;
2882              goto type_dispatch;              goto type_dispatch;
2883            }            }
2884          else if (!SCM_I_OPERATORP (proc))          else if (!SCM_I_OPERATORP (proc))
2885            goto badfun;            goto badfun;
2886          else          else
2887            {            {
2888              t.arg1 = proc;              arg1 = proc;
2889              proc = (SCM_I_ENTITYP (proc)              proc = (SCM_I_ENTITYP (proc)
2890                      ? SCM_ENTITY_PROCEDURE (proc)                      ? SCM_ENTITY_PROCEDURE (proc)
2891                      : SCM_OPERATOR_PROCEDURE (proc));                      : SCM_OPERATOR_PROCEDURE (proc));
2892  #ifdef DEVAL  #ifdef DEVAL
2893              debug.info->a.proc = proc;              debug.info->a.proc = proc;
2894              debug.info->a.args = scm_list_1 (t.arg1);              debug.info->a.args = scm_list_1 (arg1);
2895  #endif  #endif
2896              if (SCM_NIMP (proc))              if (SCM_NIMP (proc))
2897                goto evap1;                goto evap1;
# Line 2922  evapply: Line 2917  evapply:
2917    /* must handle macros by here */    /* must handle macros by here */
2918    x = SCM_CDR (x);    x = SCM_CDR (x);
2919  #ifdef SCM_CAUTIOUS  #ifdef SCM_CAUTIOUS
2920    if (SCM_IMP (x))    if (SCM_CONSP (x))
2921      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);  
     }  
2922    else    else
2923      goto wrongnumargs;      goto wrongnumargs;
2924  #else  #else
2925    t.arg1 = EVALCAR (x, env);    arg1 = EVALCAR (x, env);
2926  #endif  #endif
2927  #ifdef DEVAL  #ifdef DEVAL
2928    debug.info->a.args = scm_list_1 (t.arg1);    debug.info->a.args = scm_list_1 (arg1);
2929  #endif  #endif
2930    x = SCM_CDR (x);    x = SCM_CDR (x);
2931    if (SCM_NULLP (x))    if (SCM_NULLP (x))
# Line 2945  evapply: Line 2933  evapply:
2933        ENTER_APPLY;        ENTER_APPLY;
2934      evap1:      evap1:
2935        switch (SCM_TYP7 (proc))        switch (SCM_TYP7 (proc))
2936          {                               /* have one argument in t.arg1 */          {                               /* have one argument in arg1 */
2937          case scm_tc7_subr_2o:          case scm_tc7_subr_2o:
2938            RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));            RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
2939          case scm_tc7_subr_1:          case scm_tc7_subr_1:
2940          case scm_tc7_subr_1o:          case scm_tc7_subr_1o:
2941            RETURN (SCM_SUBRF (proc) (t.arg1));            RETURN (SCM_SUBRF (proc) (arg1));
2942          case scm_tc7_cxr:          case scm_tc7_cxr:
2943            if (SCM_SUBRF (proc))            if (SCM_SUBRF (proc))
2944              {              {
2945                if (SCM_INUMP (t.arg1))                if (SCM_INUMP (arg1))
2946                  {                  {
2947                    RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1))));                    RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
2948                  }                  }
2949                else if (SCM_REALP (t.arg1))                else if (SCM_REALP (arg1))
2950                  {                  {
2951                    RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1))));                    RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
2952                  }                  }
2953  #ifdef SCM_BIGDIG  #ifdef SCM_BIGDIG
2954                else if (SCM_BIGP (t.arg1))                else if (SCM_BIGP (arg1))
2955                  {                  {
2956                    RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1))));                    RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
2957                  }                  }
2958  #endif  #endif
2959                SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,                SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
2960                                    SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));                                    SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
2961              }              }
2962            proc = SCM_SNAME (proc);            proc = SCM_SNAME (proc);
# Line 2976  evapply: Line 2964  evapply:
2964              char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;              char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
2965              while ('c' != *--chrs)              while ('c' != *--chrs)
2966                {                {
2967                  SCM_ASSERT (SCM_CONSP (t.arg1),                  SCM_ASSERT (SCM_CONSP (arg1),
2968                              t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));                              arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
2969                  t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);                  arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
2970                }                }
2971              RETURN (t.arg1);              RETURN (arg1);
2972            }            }
2973          case scm_tc7_rpsubr:          case scm_tc7_rpsubr:
2974            RETURN (SCM_BOOL_T);            RETURN (SCM_BOOL_T);
2975          case scm_tc7_asubr:          case scm_tc7_asubr:
2976            RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));            RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
2977          case scm_tc7_lsubr:          case scm_tc7_lsubr:
2978  #ifdef DEVAL  #ifdef DEVAL
2979            RETURN (SCM_SUBRF (proc) (debug.info->a.args));            RETURN (SCM_SUBRF (proc) (debug.info->a.args));
2980  #else  #else
2981            RETURN (SCM_SUBRF (proc) (scm_list_1 (t.arg1)));            RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
2982  #endif  #endif
2983          case scm_tc7_smob:          case scm_tc7_smob:
2984            if (!SCM_SMOB_APPLICABLE_P (proc))            if (!SCM_SMOB_APPLICABLE_P (proc))
2985              goto badfun;              goto badfun;
2986            RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1));            RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
2987          case scm_tc7_cclo:          case scm_tc7_cclo:
2988            arg2 = t.arg1;            arg2 = arg1;
2989            t.arg1 = proc;            arg1 = proc;
2990            proc = SCM_CCLO_SUBR (proc);            proc = SCM_CCLO_SUBR (proc);
2991  #ifdef DEVAL  #ifdef DEVAL
2992            debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);            debug.info->a.args = scm_cons (arg1, debug.info->a.args);
2993            debug.info->a.proc = proc;            debug.info->a.proc = proc;
2994  #endif  #endif
2995            goto evap2;            goto evap2;
# Line 3020  evapply: Line 3008  evapply:
3008  #ifdef DEVAL  #ifdef DEVAL
3009            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));
3010  #else  #else
3011            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));
3012  #endif  #endif
3013            goto nontoplevel_begin;            goto nontoplevel_begin;
3014          case scm_tcs_struct:          case scm_tcs_struct:
# Line 3028  evapply: Line 3016  evapply:
3016              {              {
3017                x = SCM_ENTITY_PROCEDURE (proc);                x = SCM_ENTITY_PROCEDURE (proc);
3018  #ifdef DEVAL  #ifdef DEVAL
3019                t.arg1 = debug.info->a.args;                arg1 = debug.info->a.args;
3020  #else  #else
3021                t.arg1 = scm_list_1 (t.arg1);                arg1 = scm_list_1 (arg1);
3022  #endif  #endif
3023                goto type_dispatch;                goto type_dispatch;
3024              }              }
# Line 3038  evapply: Line 3026  evapply:
3026              goto badfun;              goto badfun;
3027            else            else
3028              {              {
3029                arg2 = t.arg1;                arg2 = arg1;
3030                t.arg1 = proc;                arg1 = proc;
3031                proc = (SCM_I_ENTITYP (proc)                proc = (SCM_I_ENTITYP (proc)
3032                        ? SCM_ENTITY_PROCEDURE (proc)                        ? SCM_ENTITY_PROCEDURE (proc)
3033                        : SCM_OPERATOR_PROCEDURE (proc));                        : SCM_OPERATOR_PROCEDURE (proc));
3034  #ifdef DEVAL  #ifdef DEVAL
3035                debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);                debug.info->a.args = scm_cons (arg1, debug.info->a.args);
3036                debug.info->a.proc = proc;                debug.info->a.proc = proc;
3037  #endif  #endif
3038                if (SCM_NIMP (proc))                if (SCM_NIMP (proc))
# Line 3078  evapply: Line 3066  evapply:
3066  #endif  #endif
3067    {                             /* have two or more arguments */    {                             /* have two or more arguments */
3068  #ifdef DEVAL  #ifdef DEVAL
3069      debug.info->a.args = scm_list_2 (t.arg1, arg2);      debug.info->a.args = scm_list_2 (arg1, arg2);
3070  #endif  #endif
3071      x = SCM_CDR (x);      x = SCM_CDR (x);
3072      if (SCM_NULLP (x)) {      if (SCM_NULLP (x)) {
# Line 3088  evapply: Line 3076  evapply:
3076          {                       /* have two arguments */          {                       /* have two arguments */
3077          case scm_tc7_subr_2:          case scm_tc7_subr_2:
3078          case scm_tc7_subr_2o:          case scm_tc7_subr_2o:
3079            RETURN (SCM_SUBRF (proc) (t.arg1, arg2));            RETURN (SCM_SUBRF (proc) (arg1, arg2));
3080          case scm_tc7_lsubr:          case scm_tc7_lsubr:
3081  #ifdef DEVAL  #ifdef DEVAL
3082            RETURN (SCM_SUBRF (proc) (debug.info->a.args));            RETURN (SCM_SUBRF (proc) (debug.info->a.args));
3083  #else  #else
3084            RETURN (SCM_SUBRF (proc) (scm_list_2 (t.arg1, arg2)));            RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
3085  #endif  #endif
3086          case scm_tc7_lsubr_2:          case scm_tc7_lsubr_2:
3087            RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));            RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
3088          case scm_tc7_rpsubr:          case scm_tc7_rpsubr:
3089          case scm_tc7_asubr:          case scm_tc7_asubr:
3090            RETURN (SCM_SUBRF (proc) (t.arg1, arg2));            RETURN (SCM_SUBRF (proc) (arg1, arg2));
3091          case scm_tc7_smob:          case scm_tc7_smob:
3092            if (!SCM_SMOB_APPLICABLE_P (proc))            if (!SCM_SMOB_APPLICABLE_P (proc))
3093              goto badfun;              goto badfun;
3094            RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2));            RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
3095          cclon:          cclon:
3096          case scm_tc7_cclo:          case scm_tc7_cclo:
3097  #ifdef DEVAL  #ifdef DEVAL
# Line 3112  evapply: Line 3100  evapply:
3100                               SCM_EOL));                               SCM_EOL));
3101  #else  #else
3102            RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),            RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
3103                               scm_cons2 (proc, t.arg1,                               scm_cons2 (proc, arg1,
3104                                          scm_cons (arg2,                                          scm_cons (arg2,
3105                                                    scm_eval_args (x,                                                    scm_eval_args (x,
3106                                                                   env,                                                                   env,
# Line 3124  evapply: Line 3112  evapply:
3112              {              {
3113                x = SCM_ENTITY_PROCEDURE (proc);                x = SCM_ENTITY_PROCEDURE (proc);
3114  #ifdef DEVAL  #ifdef DEVAL
3115                t.arg1 = debug.info->a.args;                arg1 = debug.info->a.args;
3116  #else  #else
3117                t.arg1 = scm_list_2 (t.arg1, arg2);                arg1 = scm_list_2 (arg1, arg2);
3118  #endif  #endif
3119                goto type_dispatch;                goto type_dispatch;
3120              }              }
# Line 3145  evapply: Line 3133  evapply:
3133                RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)                RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
3134                                   ? SCM_ENTITY_PROCEDURE (proc)                                   ? SCM_ENTITY_PROCEDURE (proc)
3135                                   : SCM_OPERATOR_PROCEDURE (proc),                                   : SCM_OPERATOR_PROCEDURE (proc),
3136                                   scm_cons2 (proc, t.arg1,                                   scm_cons2 (proc, arg1,
3137                                              scm_cons (arg2,                                              scm_cons (arg2,
3138                                                        scm_eval_args (x,                                                        scm_eval_args (x,
3139                                                                       env,                                                                       env,
# Line 3178  evapply: Line 3166  evapply:
3166                              SCM_ENV (proc));                              SCM_ENV (proc));
3167  #else  #else
3168            env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),            env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
3169                              scm_list_2 (t.arg1, arg2), SCM_ENV (proc));                              scm_list_2 (arg1, arg2), SCM_ENV (proc));
3170  #endif  #endif
3171            x = SCM_CLOSURE_BODY (proc);            x = SCM_CLOSURE_BODY (proc);
3172            goto nontoplevel_begin;            goto nontoplevel_begin;
# Line 3189  evapply: Line 3177  evapply:
3177        goto wrongnumargs;        goto wrongnumargs;
3178  #endif  #endif
3179  #ifdef DEVAL  #ifdef DEVAL
3180      debug.info->a.args = scm_cons2 (t.arg1, arg2,      debug.info->a.args = scm_cons2 (arg1, arg2,
3181        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))));
3182  #endif  #endif
3183      ENTER_APPLY;      ENTER_APPLY;
# Line 3199  evapply: Line 3187  evapply:
3187  #ifdef DEVAL  #ifdef DEVAL
3188        case scm_tc7_subr_3:        case scm_tc7_subr_3:
3189          SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);          SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
3190          RETURN (SCM_SUBRF (proc) (t.arg1, arg2,          RETURN (SCM_SUBRF (proc) (arg1, arg2,
3191                                    SCM_CADDR (debug.info->a.args)));                                    SCM_CADDR (debug.info->a.args)));
3192        case scm_tc7_asubr:        case scm_tc7_asubr:
3193  #ifdef BUILTIN_RPASUBR  #ifdef BUILTIN_RPASUBR
3194          t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);          arg1 = SCM_SUBRF(proc)(arg1, arg2);
3195          arg2 = SCM_CDDR (debug.info->a.args);          arg2 = SCM_CDDR (debug.info->a.args);
3196          do          do
3197            {            {
3198              t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));              arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
3199              arg2 = SCM_CDR (arg2);              arg2 = SCM_CDR (arg2);
3200            }            }
3201          while (SCM_NIMP (arg2));          while (SCM_NIMP (arg2));
3202          RETURN (t.arg1);          RETURN (arg1);
3203  #endif /* BUILTIN_RPASUBR */  #endif /* BUILTIN_RPASUBR */
3204        case scm_tc7_rpsubr:        case scm_tc7_rpsubr:
3205  #ifdef BUILTIN_RPASUBR  #ifdef BUILTIN_RPASUBR
3206          if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))          if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
3207            RETURN (SCM_BOOL_F);            RETURN (SCM_BOOL_F);
3208          t.arg1 = SCM_CDDR (debug.info->a.args);          arg1 = SCM_CDDR (debug.info->a.args);
3209          do          do
3210            {            {
3211              if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))              if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
3212                RETURN (SCM_BOOL_F);                RETURN (SCM_BOOL_F);
3213              arg2 = SCM_CAR (t.arg1);              arg2 = SCM_CAR (arg1);
3214              t.arg1 = SCM_CDR (t.arg1);              arg1 = SCM_CDR (arg1);
3215            }            }
3216          while (SCM_NIMP (t.arg1));          while (SCM_NIMP (arg1));
3217          RETURN (SCM_BOOL_T);          RETURN (SCM_BOOL_T);
3218  #else /* BUILTIN_RPASUBR */  #else /* BUILTIN_RPASUBR */
3219          RETURN (SCM_APPLY (proc, t.arg1,          RETURN (SCM_APPLY (proc, arg1,
3220                             scm_acons (arg2,                             scm_acons (arg2,
3221                                        SCM_CDDR (debug.info->a.args),                                        SCM_CDDR (debug.info->a.args),
3222                                        SCM_EOL)));                                        SCM_EOL)));
3223  #endif /* BUILTIN_RPASUBR */  #endif /* BUILTIN_RPASUBR */
3224        case scm_tc7_lsubr_2:        case scm_tc7_lsubr_2:
3225          RETURN (SCM_SUBRF (proc) (t.arg1, arg2,          RETURN (SCM_SUBRF (proc) (arg1, arg2,
3226                                    SCM_CDDR (debug.info->a.args)));                                    SCM_CDDR (debug.info->a.args)));
3227        case scm_tc7_lsubr:        case scm_tc7_lsubr:
3228          RETURN (SCM_SUBRF (proc) (debug.info->a.args));          RETURN (SCM_SUBRF (proc) (debug.info->a.args));
3229        case scm_tc7_smob:        case scm_tc7_smob:
3230          if (!SCM_SMOB_APPLICABLE_P (proc))          if (!SCM_SMOB_APPLICABLE_P (proc))
3231            goto badfun;            goto badfun;
3232          RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2,          RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
3233                                    SCM_CDDR (debug.info->a.args)));                                    SCM_CDDR (debug.info->a.args)));
3234        case scm_tc7_cclo:        case scm_tc7_cclo:
3235          goto cclon;          goto cclon;
# Line 3262  evapply: Line 3250  evapply:
3250  #else /* DEVAL */  #else /* DEVAL */
3251        case scm_tc7_subr_3:        case scm_tc7_subr_3:
3252          SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);          SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
3253          RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));          RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
3254        case scm_tc7_asubr:        case scm_tc7_asubr:
3255  #ifdef BUILTIN_RPASUBR  #ifdef BUILTIN_RPASUBR
3256          t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2);          arg1 = SCM_SUBRF (proc) (arg1, arg2);
3257          do          do
3258            {            {
3259              t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));              arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
3260              x = SCM_CDR(x);              x = SCM_CDR(x);
3261            }            }
3262          while (SCM_NIMP (x));          while (SCM_NIMP (x));
3263          RETURN (t.arg1);          RETURN (arg1);
3264  #endif /* BUILTIN_RPASUBR */  #endif /* BUILTIN_RPASUBR */
3265        case scm_tc7_rpsubr:        case scm_tc7_rpsubr:
3266  #ifdef BUILTIN_RPASUBR  #ifdef BUILTIN_RPASUBR
3267          if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))          if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
3268            RETURN (SCM_BOOL_F);            RETURN (SCM_BOOL_F);
3269          do          do
3270            {            {
3271              t.arg1 = EVALCAR (x, env);              arg1 = EVALCAR (x, env);
3272              if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))              if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1)))
3273                RETURN (SCM_BOOL_F);                RETURN (SCM_BOOL_F);
3274              arg2 = t.arg1;              arg2 = arg1;
3275              x = SCM_CDR (x);              x = SCM_CDR (x);
3276            }            }
3277          while (SCM_NIMP (x));          while (SCM_NIMP (x));
3278          RETURN (SCM_BOOL_T);          RETURN (SCM_BOOL_T);
3279  #else /* BUILTIN_RPASUBR */  #else /* BUILTIN_RPASUBR */
3280          RETURN (SCM_APPLY (proc, t.arg1,          RETURN (SCM_APPLY (proc, arg1,
3281                             scm_acons (arg2,                             scm_acons (arg2,
3282                                        scm_eval_args (x, env, proc),                                        scm_eval_args (x, env, proc),
3283                                        SCM_EOL)));                                        SCM_EOL)));
3284  #endif /* BUILTIN_RPASUBR */  #endif /* BUILTIN_RPASUBR */
3285        case scm_tc7_lsubr_2:        case scm_tc7_lsubr_2:
3286          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)));
3287        case scm_tc7_lsubr:        case scm_tc7_lsubr:
3288          RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,          RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
3289                                               arg2,                                               arg2,
3290                                               scm_eval_args (x, env, proc))));                                               scm_eval_args (x, env, proc))));
3291        case scm_tc7_smob:        case scm_tc7_smob:
3292          if (!SCM_SMOB_APPLICABLE_P (proc))          if (!SCM_SMOB_APPLICABLE_P (proc))
3293            goto badfun;            goto badfun;
3294          RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2,          RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
3295                                    scm_eval_args (x, env, proc)));                                    scm_eval_args (x, env, proc)));
3296        case scm_tc7_cclo:        case scm_tc7_cclo:
3297          goto cclon;          goto cclon;
# Line 3325  evapply: Line 3313  evapply:
3313          SCM_SET_ARGSREADY (debug);          SCM_SET_ARGSREADY (debug);
3314  #endif  #endif
3315          env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),          env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
3316                                scm_cons2 (t.arg1,                                scm_cons2 (arg1,
3317                                           arg2,                                           arg2,
3318                                           scm_eval_args (x, env, proc)),                                           scm_eval_args (x, env, proc)),
3319                                SCM_ENV (proc));                                SCM_ENV (proc));
# Line 3336  evapply: Line 3324  evapply:
3324          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3325            {            {
3326  #ifdef DEVAL  #ifdef DEVAL
3327              t.arg1 = debug.info->a.args;              arg1 = debug.info->a.args;
3328  #else  #else
3329              t.arg1 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));              arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
3330  #endif  #endif
3331              x = SCM_ENTITY_PROCEDURE (proc);              x = SCM_ENTITY_PROCEDURE (proc);
3332              goto type_dispatch;              goto type_dispatch;
# Line 3365  exit: Line 3353  exit:
3353        {        {
3354          SCM_CLEAR_TRACED_FRAME (debug);          SCM_CLEAR_TRACED_FRAME (debug);
3355          if (SCM_CHEAPTRAPS_P)          if (SCM_CHEAPTRAPS_P)
3356            t.arg1 = scm_make_debugobj (&debug);            arg1 = scm_make_debugobj (&debug);
3357          else          else
3358            {            {
3359              int first;              int first;
3360              SCM val = scm_make_continuation (&first);              SCM val = scm_make_continuation (&first);
3361                            
3362              if (first)              if (first)
3363                t.arg1 = val;                arg1 = val;
3364              else              else
3365                {                {
3366                  proc = val;                  proc = val;
# Line 3380  exit: Line 3368  exit:
3368                }                }
3369            }            }
3370          SCM_TRAPS_P = 0;          SCM_TRAPS_P = 0;
3371          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);
3372          SCM_TRAPS_P = 1;          SCM_TRAPS_P = 1;
3373        }        }
3374  ret:  ret:

Legend:
Removed from v.1.264  
changed lines
  Added in v.1.265

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