libguile/eval.i.c

   1 /*
   2  * eval.i.c - actual evaluator code for GUILE
   3  *
   4  * Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc.
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public License
   8  * as published by the Free Software Foundation; either version 3 of
   9  * the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful, but
  12  * WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public
  17  * License along with this library; if not, write to the Free Software
  18  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  19  * 02110-1301 USA
  20  */
  21
  22 #undef RETURN
  23 #undef ENTER_APPLY
  24 #undef PREP_APPLY
  25 #undef CEVAL
  26 #undef SCM_APPLY
  27 #undef EVAL_DEBUGGING_P
  28
  29
  30 #ifdef DEVAL
  31
  32 /*
  33   This code is specific for the debugging support.
  34  */
  35
  36 #define EVAL_DEBUGGING_P 1
  37 #define CEVAL deval     /* Substitute all uses of ceval */
  38 #define SCM_APPLY scm_dapply
  39 #define PREP_APPLY(p, l)                                                \
  40 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
  41
  42 #define ENTER_APPLY \
  43 do { \
  44   SCM_SET_ARGSREADY (debug);\
  45   if (scm_check_apply_p && SCM_TRAPS_P)\
  46     if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
  47       {\
  48         SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
  49         SCM_SET_TRACED_FRAME (debug); \
  50         SCM_TRAPS_P = 0;\
  51         tmp = scm_make_debugobj (&debug);\
  52         scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
  53         SCM_TRAPS_P = 1;\
  54       }\
  55 } while (0)
  56
  57 #define RETURN(e) do { proc = (e); goto exit; } while (0)
  58
  59 #ifdef STACK_CHECKING
  60 # ifndef EVAL_STACK_CHECKING
  61 # define EVAL_STACK_CHECKING
  62 # endif /* EVAL_STACK_CHECKING */
  63 #endif /* STACK_CHECKING */
  64
  65
  66
  67
  68 static SCM
  69 deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
  70 {
  71   SCM *results = lloc;
  72   while (scm_is_pair (l))
  73     {
  74       const SCM res = SCM_I_XEVALCAR (l, env, 1);
  75
  76       *lloc = scm_list_1 (res);
  77       lloc = SCM_CDRLOC (*lloc);
  78       l = SCM_CDR (l);
  79     }
  80   if (!scm_is_null (l))
  81     scm_wrong_num_args (proc);
  82   return *results;
  83 }
  84
  85
  86 #else /* DEVAL */
  87
  88 /*
  89   Code is specific to debugging-less support.
  90  */
  91
  92
  93 #define CEVAL ceval
  94 #define SCM_APPLY scm_apply
  95 #define PREP_APPLY(proc, args)
  96 #define ENTER_APPLY
  97 #define RETURN(x) do { return x; } while (0)
  98 #define EVAL_DEBUGGING_P 0
  99
 100 #ifdef STACK_CHECKING
 101 # ifndef NO_CEVAL_STACK_CHECKING
 102 # define EVAL_STACK_CHECKING
 103 # endif
 104 #endif
 105
 106
 107
 108
 109 static void
 110 ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
 111 {
 112   SCM argv[10];
 113   int i = 0, imax = sizeof (argv) / sizeof (SCM);
 114
 115   while (!scm_is_null (init_forms))
 116     {
 117       if (imax == i)
 118         {
 119           ceval_letrec_inits (env, init_forms, init_values_eol);
 120           break;
 121         }
 122       argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0);
 123       init_forms = SCM_CDR (init_forms);
 124     }
 125
 126   for (i--; i >= 0; i--)
 127     {
 128       **init_values_eol = scm_list_1 (argv[i]);
 129       *init_values_eol = SCM_CDRLOC (**init_values_eol);
 130     }
 131 }
 132
 133 static SCM
 134 scm_ceval_args (SCM l, SCM env, SCM proc)
 135 {
 136   SCM results = SCM_EOL, *lloc = &results, res;
 137   while (scm_is_pair (l))
 138     {
 139       res = EVALCAR (l, env);
 140
 141       *lloc = scm_list_1 (res);
 142       lloc = SCM_CDRLOC (*lloc);
 143       l = SCM_CDR (l);
 144     }
 145   if (!scm_is_null (l))
 146     scm_wrong_num_args (proc);
 147   return results;
 148 }
 149
 150
 151 SCM
 152 scm_eval_args (SCM l, SCM env, SCM proc)
 153 {
 154   return scm_ceval_args (l, env, proc);
 155 }
 156
 157
 158
 159 #endif
 160
 161
 162
 163
 164 #define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P)
 165 #define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P)
 166
 167
 168
 169 /* Update the toplevel environment frame ENV so that it refers to the
 170  * current module.  */
 171 #define UPDATE_TOPLEVEL_ENV(env) \
 172   do { \
 173     SCM p = scm_current_module_lookup_closure (); \
 174     if (p != SCM_CAR (env)) \
 175       env = scm_top_level_env (p); \
 176   } while (0)
 177
 178
 179 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
 180   ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
 181
 182
 183 /* This is the evaluator.  Like any real monster, it has three heads:
 184  *
 185  * ceval is the non-debugging evaluator, deval is the debugging version.  Both
 186  * are implemented using a common code base, using the following mechanism:
 187  * CEVAL is a macro, which is either defined to ceval or deval.  Thus, there
 188  * is no function CEVAL, but the code for CEVAL actually compiles to either
 189  * ceval or deval.  When CEVAL is defined to ceval, it is known that the macro
 190  * DEVAL is not defined.  When CEVAL is defined to deval, then the macro DEVAL
 191  * is known to be defined.  Thus, in CEVAL parts for the debugging evaluator
 192  * are enclosed within #ifdef DEVAL ... #endif.
 193  *
 194  * All three (ceval, deval and their common implementation CEVAL) take two
 195  * input parameters, x and env: x is a single expression to be evalutated.
 196  * env is the environment in which bindings are searched.
 197  *
 198  * x is known to be a pair.  Since x is a single expression, it is necessarily
 199  * in a tail position.  If x is just a call to another function like in the
 200  * expression (foo exp1 exp2 ...), the realization of that call therefore
 201  * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
 202  * however, may do so).  This is realized by making extensive use of 'goto'
 203  * statements within the evaluator: The gotos replace recursive calls to
 204  * CEVAL, thus re-using the same stack frame that CEVAL was already using.
 205  * If, however, x represents some form that requires to evaluate a sequence of
 206  * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
 207  * performed for all but the last expression of that sequence.  */
 208
 209 static SCM
 210 CEVAL (SCM x, SCM env)
 211 {
 212   SCM proc, arg1;
 213 #ifdef DEVAL
 214   scm_t_debug_frame debug;
 215   scm_t_debug_info *debug_info_end;
 216   debug.prev = scm_i_last_debug_frame ();
 217   debug.status = 0;
 218   /*
 219    * The debug.vect contains twice as much scm_t_debug_info frames as the
 220    * user has specified with (debug-set! frames <n>).
 221    *
 222    * Even frames are eval frames, odd frames are apply frames.
 223    */
 224   debug.vect = alloca (scm_debug_eframe_size * sizeof (scm_t_debug_info));
 225   debug.info = debug.vect;
 226   debug_info_end = debug.vect + scm_debug_eframe_size;
 227   scm_i_set_last_debug_frame (&debug);
 228 #endif
 229 #ifdef EVAL_STACK_CHECKING
 230   if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
 231     {
 232 #ifdef DEVAL
 233       debug.info->e.exp = x;
 234       debug.info->e.env = env;
 235 #endif
 236       scm_report_stack_overflow ();
 237     }
 238 #endif
 239
 240 #ifdef DEVAL
 241   goto start;
 242 #endif
 243
 244 loop:
 245 #ifdef DEVAL
 246   SCM_CLEAR_ARGSREADY (debug);
 247   if (SCM_OVERFLOWP (debug))
 248     --debug.info;
 249   /*
 250    * In theory, this should be the only place where it is necessary to
 251    * check for space in debug.vect since both eval frames and
 252    * available space are even.
 253    *
 254    * For this to be the case, however, it is necessary that primitive
 255    * special forms which jump back to `loop', `begin' or some similar
 256    * label call PREP_APPLY.
 257    */
 258   else if (++debug.info >= debug_info_end)
 259     {
 260       SCM_SET_OVERFLOW (debug);
 261       debug.info -= 2;
 262     }
 263
 264 start:
 265   debug.info->e.exp = x;
 266   debug.info->e.env = env;
 267   if (scm_check_entry_p && SCM_TRAPS_P)
 268     {
 269       if (SCM_ENTER_FRAME_P
 270           || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
 271         {
 272           SCM stackrep;
 273           SCM tail = scm_from_bool (SCM_TAILRECP (debug));
 274           SCM_SET_TAILREC (debug);
 275           stackrep = scm_make_debugobj (&debug);
 276           SCM_TRAPS_P = 0;
 277           stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
 278                                  scm_sym_enter_frame,
 279                                  stackrep,
 280                                  tail,
 281                                  unmemoize_expression (x, env));
 282           SCM_TRAPS_P = 1;
 283           if (scm_is_pair (stackrep) &&
 284               scm_is_eq (SCM_CAR (stackrep), sym_instead))
 285             {
 286               /* This gives the possibility for the debugger to modify
 287                  the source expression before evaluation. */
 288               x = SCM_CDR (stackrep);
 289               if (SCM_IMP (x))
 290                 RETURN (x);
 291             }
 292         }
 293     }
 294 #endif
 295 dispatch:
 296   SCM_TICK;
 297   if (SCM_ISYMP (SCM_CAR (x)))
 298     {
 299       switch (ISYMNUM (SCM_CAR (x)))
 300         {
 301         case (ISYMNUM (SCM_IM_AND)):
 302           x = SCM_CDR (x);
 303           while (!scm_is_null (SCM_CDR (x)))
 304             {
 305               SCM test_result = EVALCAR (x, env);
 306               if (scm_is_false_or_nil (test_result))
 307                 RETURN (SCM_BOOL_F);
 308               else
 309                 x = SCM_CDR (x);
 310             }
 311           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 312           goto carloop;
 313
 314         case (ISYMNUM (SCM_IM_BEGIN)):
 315           x = SCM_CDR (x);
 316           if (scm_is_null (x))
 317             RETURN (SCM_UNSPECIFIED);
 318
 319           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 320
 321         begin:
 322           /* If we are on toplevel with a lookup closure, we need to sync
 323              with the current module. */
 324           if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
 325             {
 326               UPDATE_TOPLEVEL_ENV (env);
 327               while (!scm_is_null (SCM_CDR (x)))
 328                 {
 329                   EVALCAR (x, env);
 330                   UPDATE_TOPLEVEL_ENV (env);
 331                   x = SCM_CDR (x);
 332                 }
 333               goto carloop;
 334             }
 335           else
 336             goto nontoplevel_begin;
 337
 338         nontoplevel_begin:
 339           while (!scm_is_null (SCM_CDR (x)))
 340             {
 341               const SCM form = SCM_CAR (x);
 342               if (SCM_IMP (form))
 343                 {
 344                   if (SCM_ISYMP (form))
 345                     {
 346                       scm_dynwind_begin (0);
 347                       scm_i_dynwind_pthread_mutex_lock (&source_mutex);
 348                       /* check for race condition */
 349                       if (SCM_ISYMP (SCM_CAR (x)))
 350                         m_expand_body (x, env);
 351                       scm_dynwind_end ();
 352                       goto nontoplevel_begin;
 353                     }
 354                   else
 355                     SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
 356                 }
 357               else
 358                 (void) EVAL (form, env);
 359               x = SCM_CDR (x);
 360             }
 361
 362         carloop:
 363           {
 364             /* scm_eval last form in list */
 365             const SCM last_form = SCM_CAR (x);
 366
 367             if (scm_is_pair (last_form))
 368               {
 369                 /* This is by far the most frequent case. */
 370                 x = last_form;
 371                 goto loop;              /* tail recurse */
 372               }
 373             else if (SCM_IMP (last_form))
 374               RETURN (SCM_I_EVALIM (last_form, env));
 375             else if (SCM_VARIABLEP (last_form))
 376               RETURN (SCM_VARIABLE_REF (last_form));
 377             else if (scm_is_symbol (last_form))
 378               RETURN (*scm_lookupcar (x, env, 1));
 379             else
 380               RETURN (last_form);
 381           }
 382
 383
 384         case (ISYMNUM (SCM_IM_CASE)):
 385           x = SCM_CDR (x);
 386           {
 387             const SCM key = EVALCAR (x, env);
 388             x = SCM_CDR (x);
 389             while (!scm_is_null (x))
 390               {
 391                 const SCM clause = SCM_CAR (x);
 392                 SCM labels = SCM_CAR (clause);
 393                 if (scm_is_eq (labels, SCM_IM_ELSE))
 394                   {
 395                     x = SCM_CDR (clause);
 396                     PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 397                     goto begin;
 398                   }
 399                 while (!scm_is_null (labels))
 400                   {
 401                     const SCM label = SCM_CAR (labels);
 402                     if (scm_is_eq (label, key)
 403                         || scm_is_true (scm_eqv_p (label, key)))
 404                       {
 405                         x = SCM_CDR (clause);
 406                         PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 407                         goto begin;
 408                       }
 409                     labels = SCM_CDR (labels);
 410                   }
 411                 x = SCM_CDR (x);
 412               }
 413           }
 414           RETURN (SCM_UNSPECIFIED);
 415
 416
 417         case (ISYMNUM (SCM_IM_COND)):
 418           x = SCM_CDR (x);
 419           while (!scm_is_null (x))
 420             {
 421               const SCM clause = SCM_CAR (x);
 422               if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
 423                 {
 424                   x = SCM_CDR (clause);
 425                   PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 426                   goto begin;
 427                 }
 428               else
 429                 {
 430                   arg1 = EVALCAR (clause, env);
 431                   /* SRFI 61 extended cond */
 432                   if (!scm_is_null (SCM_CDR (clause))
 433                       && !scm_is_null (SCM_CDDR (clause))
 434                       && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
 435                     {
 436                       SCM xx, guard_result;
 437                       if (SCM_VALUESP (arg1))
 438                         arg1 = scm_struct_ref (arg1, SCM_INUM0);
 439                       else
 440                         arg1 = scm_list_1 (arg1);
 441                       xx = SCM_CDR (clause);
 442                       proc = EVALCAR (xx, env);
 443                       guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
 444                       if (scm_is_true_and_not_nil (guard_result))
 445                         {
 446                           proc = SCM_CDDR (xx);
 447                           proc = EVALCAR (proc, env);
 448                           PREP_APPLY (proc, arg1);
 449                           goto apply_proc;
 450                         }
 451                     }
 452                   else if (scm_is_true_and_not_nil (arg1))
 453                     {
 454                       x = SCM_CDR (clause);
 455                       if (scm_is_null (x))
 456                         RETURN (arg1);
 457                       else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
 458                         {
 459                           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 460                           goto begin;
 461                         }
 462                       else
 463                         {
 464                           proc = SCM_CDR (x);
 465                           proc = EVALCAR (proc, env);
 466                           PREP_APPLY (proc, scm_list_1 (arg1));
 467                           ENTER_APPLY;
 468                           goto evap1;
 469                         }
 470                     }
 471                   x = SCM_CDR (x);
 472                 }
 473             }
 474           RETURN (SCM_UNSPECIFIED);
 475
 476
 477         case (ISYMNUM (SCM_IM_DO)):
 478           x = SCM_CDR (x);
 479           {
 480             /* Compute the initialization values and the initial environment.  */
 481             SCM init_forms = SCM_CAR (x);
 482             SCM init_values = SCM_EOL;
 483             while (!scm_is_null (init_forms))
 484               {
 485                 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
 486                 init_forms = SCM_CDR (init_forms);
 487               }
 488             x = SCM_CDR (x);
 489             env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
 490           }
 491           x = SCM_CDR (x);
 492           {
 493             SCM test_form = SCM_CAR (x);
 494             SCM body_forms = SCM_CADR (x);
 495             SCM step_forms = SCM_CDDR (x);
 496
 497             SCM test_result = EVALCAR (test_form, env);
 498
 499             while (scm_is_false_or_nil (test_result))
 500               {
 501                 {
 502                   /* Evaluate body forms.  */
 503                   SCM temp_forms;
 504                   for (temp_forms = body_forms;
 505                        !scm_is_null (temp_forms);
 506                        temp_forms = SCM_CDR (temp_forms))
 507                     {
 508                       SCM form = SCM_CAR (temp_forms);
 509                       /* Dirk:FIXME: We only need to eval forms that may have
 510                        * a side effect here.  This is only true for forms that
 511                        * start with a pair.  All others are just constants.
 512                        * Since with the current memoizer 'form' may hold a
 513                        * constant, we call EVAL here to handle the constant
 514                        * cases.  In the long run it would make sense to have
 515                        * the macro transformer of 'do' eliminate all forms
 516                        * that have no sideeffect.  Then instead of EVAL we
 517                        * could call CEVAL directly here.  */
 518                       (void) EVAL (form, env);
 519                     }
 520                 }
 521
 522                 {
 523                   /* Evaluate the step expressions.  */
 524                   SCM temp_forms;
 525                   SCM step_values = SCM_EOL;
 526                   for (temp_forms = step_forms;
 527                        !scm_is_null (temp_forms);
 528                        temp_forms = SCM_CDR (temp_forms))
 529                     {
 530                       const SCM value = EVALCAR (temp_forms, env);
 531                       step_values = scm_cons (value, step_values);
 532                     }
 533                   env = SCM_EXTEND_ENV (SCM_CAAR (env),
 534                                         step_values,
 535                                         SCM_CDR (env));
 536                 }
 537
 538                 test_result = EVALCAR (test_form, env);
 539               }
 540           }
 541           x = SCM_CDAR (x);
 542           if (scm_is_null (x))
 543             RETURN (SCM_UNSPECIFIED);
 544           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 545           goto nontoplevel_begin;
 546
 547
 548         case (ISYMNUM (SCM_IM_IF)):
 549           x = SCM_CDR (x);
 550           {
 551             SCM test_result = EVALCAR (x, env);
 552             x = SCM_CDR (x);  /* then expression */
 553             if (scm_is_false_or_nil (test_result))
 554               {
 555                 x = SCM_CDR (x);  /* else expression */
 556                 if (scm_is_null (x))
 557                   RETURN (SCM_UNSPECIFIED);
 558               }
 559           }
 560           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 561           goto carloop;
 562
 563
 564         case (ISYMNUM (SCM_IM_LET)):
 565           x = SCM_CDR (x);
 566           {
 567             SCM init_forms = SCM_CADR (x);
 568             SCM init_values = SCM_EOL;
 569             do
 570               {
 571                 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
 572                 init_forms = SCM_CDR (init_forms);
 573               }
 574             while (!scm_is_null (init_forms));
 575             env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
 576           }
 577           x = SCM_CDDR (x);
 578           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 579           goto nontoplevel_begin;
 580
 581
 582         case (ISYMNUM (SCM_IM_LETREC)):
 583           x = SCM_CDR (x);
 584           env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
 585           x = SCM_CDR (x);
 586           {
 587             SCM init_forms = SCM_CAR (x);
 588             SCM init_values = scm_list_1 (SCM_BOOL_T);
 589             SCM *init_values_eol = SCM_CDRLOC (init_values);
 590             ceval_letrec_inits (env, init_forms, &init_values_eol);
 591             SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
 592           }
 593           x = SCM_CDR (x);
 594           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 595           goto nontoplevel_begin;
 596
 597
 598         case (ISYMNUM (SCM_IM_LETSTAR)):
 599           x = SCM_CDR (x);
 600           {
 601             SCM bindings = SCM_CAR (x);
 602             if (!scm_is_null (bindings))
 603               {
 604                 do
 605                   {
 606                     SCM name = SCM_CAR (bindings);
 607                     SCM init = SCM_CDR (bindings);
 608                     env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
 609                     bindings = SCM_CDR (init);
 610                   }
 611                 while (!scm_is_null (bindings));
 612               }
 613           }
 614           x = SCM_CDR (x);
 615           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 616           goto nontoplevel_begin;
 617
 618
 619         case (ISYMNUM (SCM_IM_OR)):
 620           x = SCM_CDR (x);
 621           while (!scm_is_null (SCM_CDR (x)))
 622             {
 623               SCM val = EVALCAR (x, env);
 624               if (scm_is_true_and_not_nil (val))
 625                 RETURN (val);
 626               else
 627                 x = SCM_CDR (x);
 628             }
 629           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 630           goto carloop;
 631
 632
 633         case (ISYMNUM (SCM_IM_LAMBDA)):
 634           RETURN (scm_closure (SCM_CDR (x), env));
 635
 636
 637         case (ISYMNUM (SCM_IM_QUOTE)):
 638           RETURN (SCM_CDR (x));
 639
 640
 641         case (ISYMNUM (SCM_IM_SET_X)):
 642           x = SCM_CDR (x);
 643           {
 644             SCM *location;
 645             SCM variable = SCM_CAR (x);
 646             if (SCM_ILOCP (variable))
 647               location = scm_ilookup (variable, env);
 648             else if (SCM_VARIABLEP (variable))
 649               location = SCM_VARIABLE_LOC (variable);
 650             else
 651               {
 652                 /* (scm_is_symbol (variable)) is known to be true */
 653                 variable = lazy_memoize_variable (variable, env);
 654                 SCM_SETCAR (x, variable);
 655                 location = SCM_VARIABLE_LOC (variable);
 656               }
 657             x = SCM_CDR (x);
 658             *location = EVALCAR (x, env);
 659           }
 660           RETURN (SCM_UNSPECIFIED);
 661
 662
 663         case (ISYMNUM (SCM_IM_APPLY)):
 664           /* Evaluate the procedure to be applied.  */
 665           x = SCM_CDR (x);
 666           proc = EVALCAR (x, env);
 667           PREP_APPLY (proc, SCM_EOL);
 668
 669           /* Evaluate the argument holding the list of arguments */
 670           x = SCM_CDR (x);
 671           arg1 = EVALCAR (x, env);
 672
 673         apply_proc:
 674           /* Go here to tail-apply a procedure.  PROC is the procedure and
 675            * ARG1 is the list of arguments. PREP_APPLY must have been called
 676            * before jumping to apply_proc.  */
 677           if (SCM_CLOSUREP (proc))
 678             {
 679               SCM formals = SCM_CLOSURE_FORMALS (proc);
 680 #ifdef DEVAL
 681               debug.info->a.args = arg1;
 682 #endif
 683               if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
 684                 scm_wrong_num_args (proc);
 685               ENTER_APPLY;
 686               /* Copy argument list */
 687               if (SCM_NULL_OR_NIL_P (arg1))
 688                 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
 689               else
 690                 {
 691                   SCM args = scm_list_1 (SCM_CAR (arg1));
 692                   SCM tail = args;
 693                   arg1 = SCM_CDR (arg1);
 694                   while (!SCM_NULL_OR_NIL_P (arg1))
 695                     {
 696                       SCM new_tail = scm_list_1 (SCM_CAR (arg1));
 697                       SCM_SETCDR (tail, new_tail);
 698                       tail = new_tail;
 699                       arg1 = SCM_CDR (arg1);
 700                     }
 701                   env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
 702                 }
 703
 704               x = SCM_CLOSURE_BODY (proc);
 705               goto nontoplevel_begin;
 706             }
 707           else
 708             {
 709               ENTER_APPLY;
 710               RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
 711             }
 712
 713
 714         case (ISYMNUM (SCM_IM_CONT)):
 715           {
 716             int first;
 717             SCM val = scm_make_continuation (&first);
 718
 719             if (!first)
 720               RETURN (val);
 721             else
 722               {
 723                 arg1 = val;
 724                 proc = SCM_CDR (x);
 725                 proc = EVALCAR (proc, env);
 726                 PREP_APPLY (proc, scm_list_1 (arg1));
 727                 ENTER_APPLY;
 728                 goto evap1;
 729               }
 730           }
 731
 732
 733         case (ISYMNUM (SCM_IM_DELAY)):
 734           RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
 735
 736           /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
 737              code (type_dispatch) is intended to be the tail of the case
 738              clause for the internal macro SCM_IM_DISPATCH.  Please don't
 739              remove it from this location without discussing it with Mikael
 740              <djurfeldt@nada.kth.se>  */
 741
 742           /* The type dispatch code is duplicated below
 743            * (c.f. objects.c:scm_mcache_compute_cmethod) since that
 744            * cuts down execution time for type dispatch to 50%.  */
 745         type_dispatch: /* inputs: x, arg1 */
 746           {
 747             proc = scm_mcache_compute_cmethod (x, arg1);
 748             PREP_APPLY (proc, arg1);
 749             goto apply_proc;
 750           }
 751
 752
 753         case (ISYMNUM (SCM_IM_SLOT_REF)):
 754           x = SCM_CDR (x);
 755           {
 756             SCM instance = EVALCAR (x, env);
 757             unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
 758             RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 759           }
 760
 761
 762         case (ISYMNUM (SCM_IM_SLOT_SET_X)):
 763           x = SCM_CDR (x);
 764           {
 765             SCM instance = EVALCAR (x, env);
 766             unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
 767             SCM value = EVALCAR (SCM_CDDR (x), env);
 768             SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
 769             RETURN (SCM_UNSPECIFIED);
 770           }
 771
 772
 773 #if SCM_ENABLE_ELISP
 774
 775         case (ISYMNUM (SCM_IM_NIL_COND)):
 776           {
 777             SCM test_form = SCM_CDR (x);
 778             x = SCM_CDR (test_form);
 779             while (!SCM_NULL_OR_NIL_P (x))
 780               {
 781                 SCM test_result = EVALCAR (test_form, env);
 782                 if (!(scm_is_false (test_result)
 783                       || SCM_NULL_OR_NIL_P (test_result)))
 784                   {
 785                     if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
 786                       RETURN (test_result);
 787                     PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 788                     goto carloop;
 789                   }
 790                 else
 791                   {
 792                     test_form = SCM_CDR (x);
 793                     x = SCM_CDR (test_form);
 794                   }
 795               }
 796             x = test_form;
 797             PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 798             goto carloop;
 799           }
 800
 801 #endif /* SCM_ENABLE_ELISP */
 802
 803         case (ISYMNUM (SCM_IM_BIND)):
 804           {
 805             SCM vars, exps, vals;
 806
 807             x = SCM_CDR (x);
 808             vars = SCM_CAAR (x);
 809             exps = SCM_CDAR (x);
 810             vals = SCM_EOL;
 811             while (!scm_is_null (exps))
 812               {
 813                 vals = scm_cons (EVALCAR (exps, env), vals);
 814                 exps = SCM_CDR (exps);
 815               }
 816
 817             scm_swap_bindings (vars, vals);
 818             scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
 819
 820             /* Ignore all but the last evaluation result.  */
 821             for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
 822               {
 823                 if (scm_is_pair (SCM_CAR (x)))
 824                   CEVAL (SCM_CAR (x), env);
 825               }
 826             proc = EVALCAR (x, env);
 827
 828             scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
 829             scm_swap_bindings (vars, vals);
 830
 831             RETURN (proc);
 832           }
 833
 834
 835         case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
 836           {
 837             SCM producer;
 838
 839             x = SCM_CDR (x);
 840             producer = EVALCAR (x, env);
 841             x = SCM_CDR (x);
 842             proc = EVALCAR (x, env);  /* proc is the consumer. */
 843             arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
 844             if (SCM_VALUESP (arg1))
 845               {
 846                 /* The list of arguments is not copied.  Rather, it is assumed
 847                  * that this has been done by the 'values' procedure.  */
 848                 arg1 = scm_struct_ref (arg1, SCM_INUM0);
 849               }
 850             else
 851               {
 852                 arg1 = scm_list_1 (arg1);
 853               }
 854             PREP_APPLY (proc, arg1);
 855             goto apply_proc;
 856           }
 857
 858
 859         default:
 860           break;
 861         }
 862     }
 863   else
 864     {
 865       if (SCM_VARIABLEP (SCM_CAR (x)))
 866         proc = SCM_VARIABLE_REF (SCM_CAR (x));
 867       else if (SCM_ILOCP (SCM_CAR (x)))
 868         proc = *scm_ilookup (SCM_CAR (x), env);
 869       else if (scm_is_pair (SCM_CAR (x)))
 870         proc = CEVAL (SCM_CAR (x), env);
 871       else if (scm_is_symbol (SCM_CAR (x)))
 872         {
 873           SCM orig_sym = SCM_CAR (x);
 874           {
 875             SCM *location = scm_lookupcar1 (x, env, 1);
 876             if (location == NULL)
 877               {
 878                 /* we have lost the race, start again. */
 879                 goto dispatch;
 880               }
 881             proc = *location;
 882 #ifdef DEVAL
 883             if (scm_check_memoize_p && SCM_TRAPS_P)
 884               {
 885                 SCM arg1, retval;
 886
 887                 SCM_CLEAR_TRACED_FRAME (debug);
 888                 arg1 = scm_make_debugobj (&debug);
 889                 retval = SCM_BOOL_T;
 890                 SCM_TRAPS_P = 0;
 891                 retval = scm_call_4 (SCM_MEMOIZE_HDLR,
 892                                      scm_sym_memoize_symbol,
 893                                      arg1, x, env);
 894
 895                 /*
 896                   do something with retval?
 897                  */
 898                 SCM_TRAPS_P = 1;
 899               }
 900 #endif
 901           }
 902
 903           if (SCM_MACROP (proc))
 904             {
 905               SCM_SETCAR (x, orig_sym);  /* Undo memoizing effect of
 906                                             lookupcar */
 907             handle_a_macro: /* inputs: x, env, proc */
 908 #ifdef DEVAL
 909               /* Set a flag during macro expansion so that macro
 910                  application frames can be deleted from the backtrace. */
 911               SCM_SET_MACROEXP (debug);
 912 #endif
 913               arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
 914                                 scm_cons (env, scm_listofnull));
 915 #ifdef DEVAL
 916               SCM_CLEAR_MACROEXP (debug);
 917 #endif
 918               switch (SCM_MACRO_TYPE (proc))
 919                 {
 920                 case 3:
 921                 case 2:
 922                   if (!scm_is_pair (arg1))
 923                     arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
 924
 925                   assert (!scm_is_eq (x, SCM_CAR (arg1))
 926                           && !scm_is_eq (x, SCM_CDR (arg1)));
 927
 928 #ifdef DEVAL
 929                   if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
 930                     {
 931                       SCM_CRITICAL_SECTION_START;
 932                       SCM_SETCAR (x, SCM_CAR (arg1));
 933                       SCM_SETCDR (x, SCM_CDR (arg1));
 934                       SCM_CRITICAL_SECTION_END;
 935                       goto dispatch;
 936                     }
 937                   /* Prevent memoizing of debug info expression. */
 938                   debug.info->e.exp = scm_cons_source (debug.info->e.exp,
 939                                                        SCM_CAR (x),
 940                                                        SCM_CDR (x));
 941 #endif
 942                   SCM_CRITICAL_SECTION_START;
 943                   SCM_SETCAR (x, SCM_CAR (arg1));
 944                   SCM_SETCDR (x, SCM_CDR (arg1));
 945                   SCM_CRITICAL_SECTION_END;
 946                   PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 947                   goto loop;
 948 #if SCM_ENABLE_DEPRECATED == 1
 949                 case 1:
 950                   x = arg1;
 951                   if (SCM_NIMP (x))
 952                     {
 953                       PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
 954                       goto loop;
 955                     }
 956                   else
 957                     RETURN (arg1);
 958 #endif
 959                 case 0:
 960                   RETURN (arg1);
 961                 }
 962             }
 963         }
 964       else
 965         proc = SCM_CAR (x);
 966
 967       if (SCM_MACROP (proc))
 968         goto handle_a_macro;
 969     }
 970
 971
 972   /* When reaching this part of the code, the following is granted: Variable x
 973    * holds the first pair of an expression of the form (<function> arg ...).
 974    * Variable proc holds the object that resulted from the evaluation of
 975    * <function>.  In the following, the arguments (if any) will be evaluated,
 976    * and proc will be applied to them.  If proc does not really hold a
 977    * function object, this will be signalled as an error on the scheme
 978    * level.  If the number of arguments does not match the number of arguments
 979    * that are allowed to be passed to proc, also an error on the scheme level
 980    * will be signalled.  */
 981
 982   PREP_APPLY (proc, SCM_EOL);
 983   if (scm_is_null (SCM_CDR (x))) {
 984     ENTER_APPLY;
 985   evap0:
 986     SCM_ASRTGO (!SCM_IMP (proc), badfun);
 987     switch (SCM_TYP7 (proc))
 988       {                         /* no arguments given */
 989       case scm_tc7_subr_0:
 990         RETURN (SCM_SUBRF (proc) ());
 991       case scm_tc7_subr_1o:
 992         RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
 993       case scm_tc7_lsubr:
 994         RETURN (SCM_SUBRF (proc) (SCM_EOL));
 995       case scm_tc7_rpsubr:
 996         RETURN (SCM_BOOL_T);
 997       case scm_tc7_asubr:
 998         RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
 999       case scm_tc7_program:
1000         RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
1001       case scm_tc7_smob:
1002         if (!SCM_SMOB_APPLICABLE_P (proc))
1003           goto badfun;
1004         RETURN (SCM_SMOB_APPLY_0 (proc));
1005       case scm_tc7_gsubr:
1006 #ifdef DEVAL
1007         debug.info->a.proc = proc;
1008         debug.info->a.args = SCM_EOL;
1009 #endif
1010         RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
1011       case scm_tc7_pws:
1012         proc = SCM_PROCEDURE (proc);
1013 #ifdef DEVAL
1014         debug.info->a.proc = proc;
1015 #endif
1016         if (!SCM_CLOSUREP (proc))
1017           goto evap0;
1018         /* fallthrough */
1019       case scm_tcs_closures:
1020         {
1021           const SCM formals = SCM_CLOSURE_FORMALS (proc);
1022           if (SCM_UNLIKELY (scm_is_pair (formals)))
1023             goto wrongnumargs;
1024           x = SCM_CLOSURE_BODY (proc);
1025           env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
1026           goto nontoplevel_begin;
1027         }
1028       case scm_tcs_struct:
1029         if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1030           {
1031             x = SCM_GENERIC_METHOD_CACHE (proc);
1032             arg1 = SCM_EOL;
1033             goto type_dispatch;
1034           }
1035         else if (SCM_STRUCT_APPLICABLE_P (proc))
1036           {
1037             arg1 = proc;
1038             proc = SCM_STRUCT_PROCEDURE (proc);
1039 #ifdef DEVAL
1040             debug.info->a.proc = proc;
1041             debug.info->a.args = scm_list_1 (arg1);
1042 #endif
1043             goto evap1;
1044           }
1045         else
1046           goto badfun;
1047       case scm_tc7_subr_1:
1048       case scm_tc7_subr_2:
1049       case scm_tc7_subr_2o:
1050       case scm_tc7_dsubr:
1051       case scm_tc7_cxr:
1052       case scm_tc7_subr_3:
1053       case scm_tc7_lsubr_2:
1054       wrongnumargs:
1055         scm_wrong_num_args (proc);
1056       default:
1057       badfun:
1058         scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
1059       }
1060   }
1061
1062   /* must handle macros by here */
1063   x = SCM_CDR (x);
1064   if (SCM_LIKELY (scm_is_pair (x)))
1065     arg1 = EVALCAR (x, env);
1066   else
1067     scm_wrong_num_args (proc);
1068 #ifdef DEVAL
1069   debug.info->a.args = scm_list_1 (arg1);
1070 #endif
1071   x = SCM_CDR (x);
1072   {
1073     SCM arg2;
1074     if (scm_is_null (x))
1075       {
1076         ENTER_APPLY;
1077       evap1: /* inputs: proc, arg1 */
1078         SCM_ASRTGO (!SCM_IMP (proc), badfun);
1079         switch (SCM_TYP7 (proc))
1080           {                             /* have one argument in arg1 */
1081           case scm_tc7_subr_2o:
1082             RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1083           case scm_tc7_subr_1:
1084           case scm_tc7_subr_1o:
1085             RETURN (SCM_SUBRF (proc) (arg1));
1086           case scm_tc7_dsubr:
1087             if (SCM_I_INUMP (arg1))
1088               {
1089                 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1090               }
1091             else if (SCM_REALP (arg1))
1092               {
1093                 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1094               }
1095             else if (SCM_BIGP (arg1))
1096               {
1097                 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1098               }
1099             else if (SCM_FRACTIONP (arg1))
1100               {
1101                 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1102               }
1103             SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
1104           case scm_tc7_cxr:
1105             RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1106           case scm_tc7_rpsubr:
1107             RETURN (SCM_BOOL_T);
1108           case scm_tc7_program:
1109             RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
1110           case scm_tc7_asubr:
1111             RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1112           case scm_tc7_lsubr:
1113 #ifdef DEVAL
1114             RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1115 #else
1116             RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
1117 #endif
1118           case scm_tc7_smob:
1119             if (!SCM_SMOB_APPLICABLE_P (proc))
1120               goto badfun;
1121             RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1122           case scm_tc7_gsubr:
1123 #ifdef DEVAL
1124             debug.info->a.args = debug.info->a.args;
1125             debug.info->a.proc = proc;
1126 #endif
1127             RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
1128           case scm_tc7_pws:
1129             proc = SCM_PROCEDURE (proc);
1130 #ifdef DEVAL
1131             debug.info->a.proc = proc;
1132 #endif
1133             if (!SCM_CLOSUREP (proc))
1134               goto evap1;
1135             /* fallthrough */
1136           case scm_tcs_closures:
1137             {
1138               /* clos1: */
1139               const SCM formals = SCM_CLOSURE_FORMALS (proc);
1140               if (scm_is_null (formals)
1141                   || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
1142                 goto wrongnumargs;
1143               x = SCM_CLOSURE_BODY (proc);
1144 #ifdef DEVAL
1145               env = SCM_EXTEND_ENV (formals,
1146                                     debug.info->a.args,
1147                                     SCM_ENV (proc));
1148 #else
1149               env = SCM_EXTEND_ENV (formals,
1150                                     scm_list_1 (arg1),
1151                                     SCM_ENV (proc));
1152 #endif
1153               goto nontoplevel_begin;
1154             }
1155           case scm_tcs_struct:
1156             if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1157               {
1158                 x = SCM_GENERIC_METHOD_CACHE (proc);
1159 #ifdef DEVAL
1160                 arg1 = debug.info->a.args;
1161 #else
1162                 arg1 = scm_list_1 (arg1);
1163 #endif
1164                 goto type_dispatch;
1165               }
1166             else if (SCM_STRUCT_APPLICABLE_P (proc))
1167               {
1168                 arg2 = arg1;
1169                 arg1 = proc;
1170                 proc = SCM_STRUCT_PROCEDURE (proc);
1171 #ifdef DEVAL
1172                 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
1173                 debug.info->a.proc = proc;
1174 #endif
1175                 goto evap2;
1176               }
1177             else
1178               goto badfun;
1179           case scm_tc7_subr_2:
1180           case scm_tc7_subr_0:
1181           case scm_tc7_subr_3:
1182           case scm_tc7_lsubr_2:
1183             scm_wrong_num_args (proc);
1184           default:
1185             goto badfun;
1186           }
1187       }
1188     if (SCM_LIKELY (scm_is_pair (x)))
1189       arg2 = EVALCAR (x, env);
1190     else
1191       scm_wrong_num_args (proc);
1192
1193     {                           /* have two or more arguments */
1194 #ifdef DEVAL
1195       debug.info->a.args = scm_list_2 (arg1, arg2);
1196 #endif
1197       x = SCM_CDR (x);
1198       if (scm_is_null (x)) {
1199         ENTER_APPLY;
1200       evap2:
1201         SCM_ASRTGO (!SCM_IMP (proc), badfun);
1202         switch (SCM_TYP7 (proc))
1203           {                     /* have two arguments */
1204           case scm_tc7_subr_2:
1205           case scm_tc7_subr_2o:
1206             RETURN (SCM_SUBRF (proc) (arg1, arg2));
1207           case scm_tc7_lsubr:
1208 #ifdef DEVAL
1209             RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1210 #else
1211             RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
1212 #endif
1213           case scm_tc7_lsubr_2:
1214             RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
1215           case scm_tc7_rpsubr:
1216           case scm_tc7_asubr:
1217             RETURN (SCM_SUBRF (proc) (arg1, arg2));
1218           case scm_tc7_program:
1219             { SCM args[2];
1220               args[0] = arg1;
1221               args[1] = arg2;
1222               RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
1223             }
1224           case scm_tc7_smob:
1225             if (!SCM_SMOB_APPLICABLE_P (proc))
1226               goto badfun;
1227             RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
1228           case scm_tc7_gsubr:
1229 #ifdef DEVAL
1230             RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
1231 #else
1232             RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
1233 #endif
1234           case scm_tcs_struct:
1235             if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1236               {
1237                 x = SCM_GENERIC_METHOD_CACHE (proc);
1238 #ifdef DEVAL
1239                 arg1 = debug.info->a.args;
1240 #else
1241                 arg1 = scm_list_2 (arg1, arg2);
1242 #endif
1243                 goto type_dispatch;
1244               }
1245             else if (SCM_STRUCT_APPLICABLE_P (proc))
1246               {
1247               operatorn:
1248 #ifdef DEVAL
1249                 RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
1250                                    scm_cons (proc, debug.info->a.args),
1251                                    SCM_EOL));
1252 #else
1253                 RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
1254                                    scm_cons2 (proc, arg1,
1255                                               scm_cons (arg2,
1256                                                         scm_ceval_args (x,
1257                                                                        env,
1258                                                                        proc))),
1259                                    SCM_EOL));
1260 #endif
1261               }
1262             else
1263               goto badfun;
1264           case scm_tc7_subr_0:
1265           case scm_tc7_dsubr:
1266           case scm_tc7_cxr:
1267           case scm_tc7_subr_1o:
1268           case scm_tc7_subr_1:
1269           case scm_tc7_subr_3:
1270             scm_wrong_num_args (proc);
1271           default:
1272             goto badfun;
1273           case scm_tc7_pws:
1274             proc = SCM_PROCEDURE (proc);
1275 #ifdef DEVAL
1276             debug.info->a.proc = proc;
1277 #endif
1278             if (!SCM_CLOSUREP (proc))
1279               goto evap2;
1280             /* fallthrough */
1281           case scm_tcs_closures:
1282             {
1283               /* clos2: */
1284               const SCM formals = SCM_CLOSURE_FORMALS (proc);
1285               if (scm_is_null (formals)
1286                   || (scm_is_pair (formals)
1287                       && (scm_is_null (SCM_CDR (formals))
1288                           || (scm_is_pair (SCM_CDR (formals))
1289                               && scm_is_pair (SCM_CDDR (formals))))))
1290                 goto wrongnumargs;
1291 #ifdef DEVAL
1292               env = SCM_EXTEND_ENV (formals,
1293                                     debug.info->a.args,
1294                                     SCM_ENV (proc));
1295 #else
1296               env = SCM_EXTEND_ENV (formals,
1297                                     scm_list_2 (arg1, arg2),
1298                                     SCM_ENV (proc));
1299 #endif
1300               x = SCM_CLOSURE_BODY (proc);
1301               goto nontoplevel_begin;
1302             }
1303           }
1304       }
1305       if (SCM_UNLIKELY (!scm_is_pair (x)))
1306         scm_wrong_num_args (proc);
1307 #ifdef DEVAL
1308       debug.info->a.args = scm_cons2 (arg1, arg2,
1309                                       deval_args (x, env, proc,
1310                                                   SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
1311 #endif
1312       ENTER_APPLY;
1313     evap3:
1314       SCM_ASRTGO (!SCM_IMP (proc), badfun);
1315       switch (SCM_TYP7 (proc))
1316         {                       /* have 3 or more arguments */
1317 #ifdef DEVAL
1318         case scm_tc7_subr_3:
1319           if (!scm_is_null (SCM_CDR (x)))
1320             scm_wrong_num_args (proc);
1321           else
1322             RETURN (SCM_SUBRF (proc) (arg1, arg2,
1323                                       SCM_CADDR (debug.info->a.args)));
1324         case scm_tc7_asubr:
1325           arg1 = SCM_SUBRF(proc)(arg1, arg2);
1326           arg2 = SCM_CDDR (debug.info->a.args);
1327           do
1328             {
1329               arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
1330               arg2 = SCM_CDR (arg2);
1331             }
1332           while (SCM_NIMP (arg2));
1333           RETURN (arg1);
1334         case scm_tc7_rpsubr:
1335           if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1336             RETURN (SCM_BOOL_F);
1337           arg1 = SCM_CDDR (debug.info->a.args);
1338           do
1339             {
1340               if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
1341                 RETURN (SCM_BOOL_F);
1342               arg2 = SCM_CAR (arg1);
1343               arg1 = SCM_CDR (arg1);
1344             }
1345           while (SCM_NIMP (arg1));
1346           RETURN (SCM_BOOL_T);
1347         case scm_tc7_lsubr_2:
1348           RETURN (SCM_SUBRF (proc) (arg1, arg2,
1349                                     SCM_CDDR (debug.info->a.args)));
1350         case scm_tc7_lsubr:
1351           RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1352         case scm_tc7_smob:
1353           if (!SCM_SMOB_APPLICABLE_P (proc))
1354             goto badfun;
1355           RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1356                                     SCM_CDDR (debug.info->a.args)));
1357         case scm_tc7_gsubr:
1358           RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
1359         case scm_tc7_program:
1360           RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
1361         case scm_tc7_pws:
1362           proc = SCM_PROCEDURE (proc);
1363           debug.info->a.proc = proc;
1364           if (!SCM_CLOSUREP (proc))
1365             goto evap3;
1366           /* fallthrough */
1367         case scm_tcs_closures:
1368           {
1369             const SCM formals = SCM_CLOSURE_FORMALS (proc);
1370             if (scm_is_null (formals)
1371                 || (scm_is_pair (formals)
1372                     && (scm_is_null (SCM_CDR (formals))
1373                         || (scm_is_pair (SCM_CDR (formals))
1374                             && scm_badargsp (SCM_CDDR (formals), x)))))
1375               goto wrongnumargs;
1376             SCM_SET_ARGSREADY (debug);
1377             env = SCM_EXTEND_ENV (formals,
1378                                   debug.info->a.args,
1379                                   SCM_ENV (proc));
1380             x = SCM_CLOSURE_BODY (proc);
1381             goto nontoplevel_begin;
1382           }
1383 #else /* DEVAL */
1384         case scm_tc7_subr_3:
1385           if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
1386             scm_wrong_num_args (proc);
1387           else
1388             RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
1389         case scm_tc7_asubr:
1390           arg1 = SCM_SUBRF (proc) (arg1, arg2);
1391           do
1392             {
1393               arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
1394               x = SCM_CDR(x);
1395             }
1396           while (!scm_is_null (x));
1397           RETURN (arg1);
1398         case scm_tc7_rpsubr:
1399           if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1400             RETURN (SCM_BOOL_F);
1401           do
1402             {
1403               arg1 = EVALCAR (x, env);
1404               if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
1405                 RETURN (SCM_BOOL_F);
1406               arg2 = arg1;
1407               x = SCM_CDR (x);
1408             }
1409           while (!scm_is_null (x));
1410           RETURN (SCM_BOOL_T);
1411         case scm_tc7_lsubr_2:
1412           RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
1413         case scm_tc7_lsubr:
1414           RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
1415                                                arg2,
1416                                                scm_ceval_args (x, env, proc))));
1417         case scm_tc7_smob:
1418           if (!SCM_SMOB_APPLICABLE_P (proc))
1419             goto badfun;
1420           RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1421                                     scm_ceval_args (x, env, proc)));
1422         case scm_tc7_gsubr:
1423           if (scm_is_null (SCM_CDR (x)))
1424             /* 3 arguments */
1425             RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
1426                                        SCM_UNDEFINED));
1427           else
1428             RETURN (scm_i_gsubr_apply_list (proc,
1429                                             scm_cons2 (arg1, arg2,
1430                                                        scm_ceval_args (x, env,
1431                                                                        proc))));
1432         case scm_tc7_program:
1433           RETURN (scm_vm_apply
1434                   (scm_the_vm (), proc,
1435                    scm_cons (arg1, scm_cons (arg2,
1436                                              scm_ceval_args (x, env, proc)))));
1437         case scm_tc7_pws:
1438           proc = SCM_PROCEDURE (proc);
1439           if (!SCM_CLOSUREP (proc))
1440             goto evap3;
1441           /* fallthrough */
1442         case scm_tcs_closures:
1443           {
1444             const SCM formals = SCM_CLOSURE_FORMALS (proc);
1445             if (scm_is_null (formals)
1446                 || (scm_is_pair (formals)
1447                     && (scm_is_null (SCM_CDR (formals))
1448                         || (scm_is_pair (SCM_CDR (formals))
1449                             && scm_badargsp (SCM_CDDR (formals), x)))))
1450               goto wrongnumargs;
1451             env = SCM_EXTEND_ENV (formals,
1452                                   scm_cons2 (arg1,
1453                                              arg2,
1454                                              scm_ceval_args (x, env, proc)),
1455                                   SCM_ENV (proc));
1456             x = SCM_CLOSURE_BODY (proc);
1457             goto nontoplevel_begin;
1458           }
1459 #endif /* DEVAL */
1460         case scm_tcs_struct:
1461           if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1462             {
1463 #ifdef DEVAL
1464               arg1 = debug.info->a.args;
1465 #else
1466               arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
1467 #endif
1468               x = SCM_GENERIC_METHOD_CACHE (proc);
1469               goto type_dispatch;
1470             }
1471           else if (SCM_STRUCT_APPLICABLE_P (proc))
1472             goto operatorn;
1473           else
1474             goto badfun;
1475         case scm_tc7_subr_2:
1476         case scm_tc7_subr_1o:
1477         case scm_tc7_subr_2o:
1478         case scm_tc7_subr_0:
1479         case scm_tc7_dsubr:
1480         case scm_tc7_cxr:
1481         case scm_tc7_subr_1:
1482           scm_wrong_num_args (proc);
1483         default:
1484           goto badfun;
1485         }
1486     }
1487   }
1488 #ifdef DEVAL
1489 exit:
1490   if (scm_check_exit_p && SCM_TRAPS_P)
1491     if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1492       {
1493         SCM_CLEAR_TRACED_FRAME (debug);
1494         arg1 = scm_make_debugobj (&debug);
1495         SCM_TRAPS_P = 0;
1496         arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1497         SCM_TRAPS_P = 1;
1498         if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1499           proc = SCM_CDR (arg1);
1500       }
1501   scm_i_set_last_debug_frame (debug.prev);
1502   return proc;
1503 #endif
1504 }
1505
1506
1507
1508
1509 /* Apply a function to a list of arguments.
1510
1511    This function is exported to the Scheme level as taking two
1512    required arguments and a tail argument, as if it were:
1513         (lambda (proc arg1 . args) ...)
1514    Thus, if you just have a list of arguments to pass to a procedure,
1515    pass the list as ARG1, and '() for ARGS.  If you have some fixed
1516    args, pass the first as ARG1, then cons any remaining fixed args
1517    onto the front of your argument list, and pass that as ARGS.  */
1518
1519 SCM
1520 SCM_APPLY (SCM proc, SCM arg1, SCM args)
1521 {
1522 #ifdef DEVAL
1523   scm_t_debug_frame debug;
1524   scm_t_debug_info debug_vect_body;
1525   debug.prev = scm_i_last_debug_frame ();
1526   debug.status = SCM_APPLYFRAME;
1527   debug.vect = &debug_vect_body;
1528   debug.vect[0].a.proc = proc;
1529   debug.vect[0].a.args = SCM_EOL;
1530   scm_i_set_last_debug_frame (&debug);
1531 #else
1532   if (scm_debug_mode_p)
1533     return scm_dapply (proc, arg1, args);
1534 #endif
1535
1536   SCM_ASRTGO (SCM_NIMP (proc), badproc);
1537
1538   /* If ARGS is the empty list, then we're calling apply with only two
1539      arguments --- ARG1 is the list of arguments for PROC.  Whatever
1540      the case, futz with things so that ARG1 is the first argument to
1541      give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
1542      rest.
1543
1544      Setting the debug apply frame args this way is pretty messy.
1545      Perhaps we should store arg1 and args directly in the frame as
1546      received, and let scm_frame_arguments unpack them, because that's
1547      a relatively rare operation.  This works for now; if the Guile
1548      developer archives are still around, see Mikael's post of
1549      11-Apr-97.  */
1550   if (scm_is_null (args))
1551     {
1552       if (scm_is_null (arg1))
1553         {
1554           arg1 = SCM_UNDEFINED;
1555 #ifdef DEVAL
1556           debug.vect[0].a.args = SCM_EOL;
1557 #endif
1558         }
1559       else
1560         {
1561 #ifdef DEVAL
1562           debug.vect[0].a.args = arg1;
1563 #endif
1564           args = SCM_CDR (arg1);
1565           arg1 = SCM_CAR (arg1);
1566         }
1567     }
1568   else
1569     {
1570       args = scm_nconc2last (args);
1571 #ifdef DEVAL
1572       debug.vect[0].a.args = scm_cons (arg1, args);
1573 #endif
1574     }
1575 #ifdef DEVAL
1576   if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
1577     {
1578       SCM tmp = scm_make_debugobj (&debug);
1579       SCM_TRAPS_P = 0;
1580       scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
1581       SCM_TRAPS_P = 1;
1582     }
1583   ENTER_APPLY;
1584 #endif
1585 tail:
1586   switch (SCM_TYP7 (proc))
1587     {
1588     case scm_tc7_subr_2o:
1589       if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1590         scm_wrong_num_args (proc);
1591       if (scm_is_null (args))
1592         args = SCM_UNDEFINED;
1593       else
1594         {
1595           if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
1596             scm_wrong_num_args (proc);
1597           args = SCM_CAR (args);
1598         }
1599       RETURN (SCM_SUBRF (proc) (arg1, args));
1600     case scm_tc7_subr_2:
1601       if (SCM_UNLIKELY (scm_is_null (args) ||
1602                             !scm_is_null (SCM_CDR (args))))
1603         scm_wrong_num_args (proc);
1604       args = SCM_CAR (args);
1605       RETURN (SCM_SUBRF (proc) (arg1, args));
1606     case scm_tc7_subr_0:
1607       if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
1608         scm_wrong_num_args (proc);
1609       else
1610         RETURN (SCM_SUBRF (proc) ());
1611     case scm_tc7_subr_1:
1612       if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1613         scm_wrong_num_args (proc);
1614     case scm_tc7_subr_1o:
1615       if (SCM_UNLIKELY (!scm_is_null (args)))
1616         scm_wrong_num_args (proc);
1617       else
1618         RETURN (SCM_SUBRF (proc) (arg1));
1619     case scm_tc7_dsubr:
1620       if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
1621         scm_wrong_num_args (proc);
1622       if (SCM_I_INUMP (arg1))
1623         {
1624           RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1625         }
1626       else if (SCM_REALP (arg1))
1627         {
1628           RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1629         }
1630       else if (SCM_BIGP (arg1))
1631         {
1632           RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1633         }
1634       else if (SCM_FRACTIONP (arg1))
1635         {
1636           RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1637         }
1638       SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
1639     case scm_tc7_cxr:
1640       if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
1641         scm_wrong_num_args (proc);
1642       RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1643     case scm_tc7_subr_3:
1644       if (SCM_UNLIKELY (scm_is_null (args)
1645                             || scm_is_null (SCM_CDR (args))
1646                             || !scm_is_null (SCM_CDDR (args))))
1647         scm_wrong_num_args (proc);
1648       else
1649         RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
1650     case scm_tc7_lsubr:
1651 #ifdef DEVAL
1652       RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
1653 #else
1654       RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
1655 #endif
1656     case scm_tc7_lsubr_2:
1657       if (SCM_UNLIKELY (!scm_is_pair (args)))
1658         scm_wrong_num_args (proc);
1659       else
1660         RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
1661     case scm_tc7_asubr:
1662       if (scm_is_null (args))
1663         RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1664       while (SCM_NIMP (args))
1665         {
1666           SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1667           arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
1668           args = SCM_CDR (args);
1669         }
1670       RETURN (arg1);
1671     case scm_tc7_program:
1672       if (SCM_UNBNDP (arg1))
1673         RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
1674       else
1675         RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
1676     case scm_tc7_rpsubr:
1677       if (scm_is_null (args))
1678         RETURN (SCM_BOOL_T);
1679       while (SCM_NIMP (args))
1680         {
1681           SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1682           if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
1683             RETURN (SCM_BOOL_F);
1684           arg1 = SCM_CAR (args);
1685           args = SCM_CDR (args);
1686         }
1687       RETURN (SCM_BOOL_T);
1688     case scm_tcs_closures:
1689 #ifdef DEVAL
1690       arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
1691 #else
1692       arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
1693 #endif
1694       if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
1695         scm_wrong_num_args (proc);
1696
1697       /* Copy argument list */
1698       if (SCM_IMP (arg1))
1699         args = arg1;
1700       else
1701         {
1702           SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
1703           for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
1704             {
1705               SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
1706               tl = SCM_CDR (tl);
1707             }
1708           SCM_SETCDR (tl, arg1);
1709         }
1710
1711       args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
1712                              args,
1713                              SCM_ENV (proc));
1714       proc = SCM_CLOSURE_BODY (proc);
1715     again:
1716       arg1 = SCM_CDR (proc);
1717       while (!scm_is_null (arg1))
1718         {
1719           if (SCM_IMP (SCM_CAR (proc)))
1720             {
1721               if (SCM_ISYMP (SCM_CAR (proc)))
1722                 {
1723                   scm_dynwind_begin (0);
1724                   scm_i_dynwind_pthread_mutex_lock (&source_mutex);
1725                   /* check for race condition */
1726                   if (SCM_ISYMP (SCM_CAR (proc)))
1727                     m_expand_body (proc, args);
1728                   scm_dynwind_end ();
1729                   goto again;
1730                 }
1731               else
1732                 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
1733             }
1734           else
1735             (void) EVAL (SCM_CAR (proc), args);
1736           proc = arg1;
1737           arg1 = SCM_CDR (proc);
1738         }
1739       RETURN (EVALCAR (proc, args));
1740     case scm_tc7_smob:
1741       if (!SCM_SMOB_APPLICABLE_P (proc))
1742         goto badproc;
1743       if (SCM_UNBNDP (arg1))
1744         RETURN (SCM_SMOB_APPLY_0 (proc));
1745       else if (scm_is_null (args))
1746         RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1747       else if (scm_is_null (SCM_CDR (args)))
1748         RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
1749       else
1750         RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
1751     case scm_tc7_gsubr:
1752 #ifdef DEVAL
1753       args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1754       debug.vect[0].a.proc = proc;
1755       debug.vect[0].a.args = args;
1756 #else
1757       args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1758 #endif
1759       RETURN (scm_i_gsubr_apply_list (proc, args));
1760     case scm_tc7_pws:
1761       proc = SCM_PROCEDURE (proc);
1762 #ifdef DEVAL
1763       debug.vect[0].a.proc = proc;
1764 #endif
1765       goto tail;
1766     case scm_tcs_struct:
1767       if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1768         {
1769 #ifdef DEVAL
1770           args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1771 #else
1772           args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1773 #endif
1774           RETURN (scm_apply_generic (proc, args));
1775         }
1776       else if (SCM_STRUCT_APPLICABLE_P (proc))
1777         {
1778           /* operator */
1779 #ifdef DEVAL
1780           args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1781 #else
1782           args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1783 #endif
1784           arg1 = proc;
1785           proc = SCM_STRUCT_PROCEDURE (proc);
1786 #ifdef DEVAL
1787           debug.vect[0].a.proc = proc;
1788           debug.vect[0].a.args = scm_cons (arg1, args);
1789 #endif
1790           if (SCM_NIMP (proc))
1791             goto tail;
1792           else
1793             goto badproc;
1794         }
1795       else
1796         goto badproc;
1797     default:
1798     badproc:
1799       scm_wrong_type_arg ("apply", SCM_ARG1, proc);
1800     }
1801 #ifdef DEVAL
1802 exit:
1803   if (scm_check_exit_p && SCM_TRAPS_P)
1804     if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1805       {
1806         SCM_CLEAR_TRACED_FRAME (debug);
1807         arg1 = scm_make_debugobj (&debug);
1808         SCM_TRAPS_P = 0;
1809         arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1810         SCM_TRAPS_P = 1;
1811         if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1812           proc = SCM_CDR (arg1);
1813       }
1814   scm_i_set_last_debug_frame (debug.prev);
1815   return proc;
1816 #endif
1817 }
1818