libguile/vm-i-system.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* This file is included in vm_engine.c */
  43
  44 \f
  45 /*
  46  * Basic operations
  47  */
  48
  49 /* This must be the first instruction! */
  50 VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
  51 {
  52   NEXT;
  53 }
  54
  55 VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
  56 {
  57   SCM ret;
  58   vp->time += scm_c_get_internal_run_time () - start_time;
  59   HALT_HOOK ();
  60   nvalues = SCM_I_INUM (*sp--);
  61   NULLSTACK (1);
  62   if (nvalues == 1)
  63     POP (ret);
  64   else
  65     {
  66       POP_LIST (nvalues);
  67       POP (ret);
  68       SYNC_REGISTER ();
  69       ret = scm_values (ret);
  70     }
  71
  72   {
  73     ASSERT (sp == stack_base);
  74     ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
  75
  76     /* Restore registers */
  77     sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
  78     ip = NULL;
  79     fp = SCM_FRAME_DYNAMIC_LINK (fp);
  80     NULLSTACK (stack_base - sp);
  81   }
  82   SYNC_ALL ();
  83   scm_dynwind_end ();
  84   return ret;
  85 }
  86
  87 VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
  88 {
  89   BREAK_HOOK ();
  90   NEXT;
  91 }
  92
  93 VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
  94 {
  95   DROP ();
  96   NEXT;
  97 }
  98
  99 VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
 100 {
 101   PUSH (SCM_UNDEFINED);
 102   NEXT;
 103 }
 104
 105 VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
 106 {
 107   SCM x = *sp;
 108   PUSH (x);
 109   NEXT;
 110 }
 111
 112 \f
 113 /*
 114  * Object creation
 115  */
 116
 117 VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
 118 {
 119   PUSH (SCM_UNSPECIFIED);
 120   NEXT;
 121 }
 122
 123 VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
 124 {
 125   PUSH (SCM_BOOL_T);
 126   NEXT;
 127 }
 128
 129 VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
 130 {
 131   PUSH (SCM_BOOL_F);
 132   NEXT;
 133 }
 134
 135 VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
 136 {
 137   PUSH (SCM_EOL);
 138   NEXT;
 139 }
 140
 141 VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
 142 {
 143   PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
 144   NEXT;
 145 }
 146
 147 VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
 148 {
 149   PUSH (SCM_INUM0);
 150   NEXT;
 151 }
 152
 153 VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
 154 {
 155   PUSH (SCM_I_MAKINUM (1));
 156   NEXT;
 157 }
 158
 159 VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
 160 {
 161   int h = FETCH ();
 162   int l = FETCH ();
 163   PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
 164   NEXT;
 165 }
 166
 167 VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
 168 {
 169   PUSH (SCM_MAKE_CHAR (FETCH ()));
 170   NEXT;
 171 }
 172
 173 VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
 174 {
 175   unsigned h = FETCH ();
 176   unsigned l = FETCH ();
 177   unsigned len = ((h << 8) + l);
 178   POP_LIST (len);
 179   NEXT;
 180 }
 181
 182 VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
 183 {
 184   unsigned h = FETCH ();
 185   unsigned l = FETCH ();
 186   unsigned len = ((h << 8) + l);
 187   POP_LIST (len);
 188   SYNC_REGISTER ();
 189   *sp = scm_vector (*sp);
 190   NEXT;
 191 }
 192
 193 VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
 194 {
 195   POP_LIST_MARK ();
 196   NEXT;
 197 }
 198
 199 VM_DEFINE_INSTRUCTION (cons_mark, "cons-mark", 0, 0, 0)
 200 {
 201   POP_CONS_MARK ();
 202   NEXT;
 203 }
 204
 205 VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
 206 {
 207   POP_LIST_MARK ();
 208   SYNC_REGISTER ();
 209   *sp = scm_vector (*sp);
 210   NEXT;
 211 }
 212
 213 VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
 214 {
 215   SCM l;
 216   POP (l);
 217   for (; !SCM_NULLP (l); l = SCM_CDR (l))
 218     PUSH (SCM_CAR (l));
 219   NEXT;
 220 }
 221
 222 \f
 223 /*
 224  * Variable access
 225  */
 226
 227 #define OBJECT_REF(i)           objects[i]
 228 #define OBJECT_SET(i,o)         objects[i] = o
 229
 230 #define LOCAL_REF(i)            SCM_FRAME_VARIABLE (fp, i)
 231 #define LOCAL_SET(i,o)          SCM_FRAME_VARIABLE (fp, i) = o
 232
 233 /* For the variable operations, we _must_ obviously avoid function calls to
 234    `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
 235    nothing more than the corresponding macros.  */
 236 #define VARIABLE_REF(v)         SCM_VARIABLE_REF (v)
 237 #define VARIABLE_SET(v,o)       SCM_VARIABLE_SET (v, o)
 238 #define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
 239
 240 /* ref */
 241
 242 VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
 243 {
 244   register unsigned objnum = FETCH ();
 245   CHECK_OBJECT (objnum);
 246   PUSH (OBJECT_REF (objnum));
 247   NEXT;
 248 }
 249
 250 VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
 251 {
 252   PUSH (LOCAL_REF (FETCH ()));
 253   NEXT;
 254 }
 255
 256 VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
 257 {
 258   unsigned int i;
 259   SCM e = external;
 260   for (i = FETCH (); i; i--)
 261     {
 262       CHECK_EXTERNAL(e);
 263       e = SCM_CDR (e);
 264     }
 265   CHECK_EXTERNAL(e);
 266   PUSH (SCM_CAR (e));
 267   NEXT;
 268 }
 269
 270 VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
 271 {
 272   SCM x = *sp;
 273
 274   if (!VARIABLE_BOUNDP (x))
 275     {
 276       err_args = SCM_LIST1 (x);
 277       /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
 278       goto vm_error_unbound;
 279     }
 280   else
 281     {
 282       SCM o = VARIABLE_REF (x);
 283       *sp = o;
 284     }
 285
 286   NEXT;
 287 }
 288
 289 VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
 290 {
 291   unsigned objnum = FETCH ();
 292   SCM what;
 293   CHECK_OBJECT (objnum);
 294   what = OBJECT_REF (objnum);
 295
 296   if (!SCM_VARIABLEP (what))
 297     {
 298       SYNC_REGISTER ();
 299       if (SCM_LIKELY (SCM_SYMBOLP (what)))
 300         {
 301           if (SCM_LIKELY (scm_module_system_booted_p
 302                           && scm_is_true (bp->module)))
 303             /* might longjmp */
 304             what = scm_module_lookup (bp->module, what);
 305           else
 306             what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 307         }
 308       else
 309         {
 310           SCM mod;
 311           /* compilation of @ or @@
 312              `what' is a three-element list: (MODNAME SYM INTERFACE?)
 313              INTERFACE? is #t if we compiled @ or #f if we compiled @@
 314           */
 315           mod = scm_resolve_module (SCM_CAR (what));
 316           if (scm_is_true (SCM_CADDR (what)))
 317             mod = scm_module_public_interface (mod);
 318           if (SCM_FALSEP (mod))
 319             {
 320               err_args = SCM_LIST1 (mod);
 321               goto vm_error_no_such_module;
 322             }
 323           /* might longjmp */
 324           what = scm_module_lookup (mod, SCM_CADR (what));
 325         }
 326
 327       if (!VARIABLE_BOUNDP (what))
 328         {
 329           err_args = SCM_LIST1 (what);
 330           goto vm_error_unbound;
 331         }
 332
 333       OBJECT_SET (objnum, what);
 334     }
 335
 336   PUSH (VARIABLE_REF (what));
 337   NEXT;
 338 }
 339
 340 /* set */
 341
 342 VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
 343 {
 344   LOCAL_SET (FETCH (), *sp);
 345   DROP ();
 346   NEXT;
 347 }
 348
 349 VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
 350 {
 351   unsigned int i;
 352   SCM e = external;
 353   for (i = FETCH (); i; i--)
 354     {
 355       CHECK_EXTERNAL(e);
 356       e = SCM_CDR (e);
 357     }
 358   CHECK_EXTERNAL(e);
 359   SCM_SETCAR (e, *sp);
 360   DROP ();
 361   NEXT;
 362 }
 363
 364 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 365 {
 366   VARIABLE_SET (sp[0], sp[-1]);
 367   DROPN (2);
 368   NEXT;
 369 }
 370
 371 VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
 372 {
 373   unsigned objnum = FETCH ();
 374   SCM what;
 375   CHECK_OBJECT (objnum);
 376   what = OBJECT_REF (objnum);
 377
 378   if (!SCM_VARIABLEP (what))
 379     {
 380       SYNC_BEFORE_GC ();
 381       if (SCM_LIKELY (SCM_SYMBOLP (what)))
 382         {
 383           if (SCM_LIKELY (scm_module_system_booted_p
 384                           && scm_is_true (bp->module)))
 385             /* might longjmp */
 386             what = scm_module_lookup (bp->module, what);
 387           else
 388             what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 389         }
 390       else
 391         {
 392           SCM mod;
 393           /* compilation of @ or @@
 394              `what' is a three-element list: (MODNAME SYM INTERFACE?)
 395              INTERFACE? is #t if we compiled @ or #f if we compiled @@
 396           */
 397           mod = scm_resolve_module (SCM_CAR (what));
 398           if (scm_is_true (SCM_CADDR (what)))
 399             mod = scm_module_public_interface (mod);
 400           if (SCM_FALSEP (mod))
 401             {
 402               err_args = SCM_LIST1 (what);
 403               goto vm_error_no_such_module;
 404             }
 405           /* might longjmp */
 406           what = scm_module_lookup (mod, SCM_CADR (what));
 407         }
 408
 409       OBJECT_SET (objnum, what);
 410     }
 411
 412   VARIABLE_SET (what, *sp);
 413   DROP ();
 414   NEXT;
 415 }
 416
 417 \f
 418 /*
 419  * branch and jump
 420  */
 421
 422 /* offset must be a signed short!!! */
 423 #define FETCH_OFFSET(offset)                    \
 424 {                                               \
 425   int h = FETCH ();                             \
 426   int l = FETCH ();                             \
 427   offset = (h << 8) + l;                        \
 428 }
 429
 430 #define BR(p)                                   \
 431 {                                               \
 432   signed short offset;                          \
 433   FETCH_OFFSET (offset);                        \
 434   if (p)                                        \
 435     ip += offset;                               \
 436   NULLSTACK (1);                                \
 437   DROP ();                                      \
 438   NEXT;                                         \
 439 }
 440
 441 VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
 442 {
 443   int h = FETCH ();
 444   int l = FETCH ();
 445   ip += (signed short) (h << 8) + l;
 446   NEXT;
 447 }
 448
 449 VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
 450 {
 451   BR (!SCM_FALSEP (*sp));
 452 }
 453
 454 VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
 455 {
 456   BR (SCM_FALSEP (*sp));
 457 }
 458
 459 VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
 460 {
 461   BR (SCM_EQ_P (sp[0], sp--[1]));
 462 }
 463
 464 VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
 465 {
 466   BR (!SCM_EQ_P (sp[0], sp--[1]));
 467 }
 468
 469 VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
 470 {
 471   BR (SCM_NULLP (*sp));
 472 }
 473
 474 VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
 475 {
 476   BR (!SCM_NULLP (*sp));
 477 }
 478
 479 \f
 480 /*
 481  * Subprogram call
 482  */
 483
 484 VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
 485 {
 486   SYNC_BEFORE_GC ();
 487   *sp = scm_c_make_closure (*sp, external);
 488   NEXT;
 489 }
 490
 491 VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 492 {
 493   SCM x;
 494   nargs = FETCH ();
 495
 496  vm_call:
 497   x = sp[-nargs];
 498
 499   /*
 500    * Subprogram call
 501    */
 502   if (SCM_PROGRAM_P (x))
 503     {
 504       program = x;
 505       CACHE_PROGRAM ();
 506       INIT_ARGS ();
 507       NEW_FRAME ();
 508       ENTER_HOOK ();
 509       APPLY_HOOK ();
 510       NEXT;
 511     }
 512 #ifdef ENABLE_TRAMPOLINE
 513   /* Seems to slow down the fibo test, dunno why */
 514   /*
 515    * Subr call
 516    */
 517   switch (nargs)
 518     {
 519     case 0:
 520       {
 521         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 522         if (call)
 523           {
 524             SYNC_ALL ();
 525             *sp = call (x);
 526             NEXT;
 527           }
 528         break;
 529       }
 530     case 1:
 531       {
 532         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 533         if (call)
 534           {
 535             SCM arg1;
 536             POP (arg1);
 537             SYNC_ALL ();
 538             *sp = call (x, arg1);
 539             NEXT;
 540           }
 541         break;
 542       }
 543     case 2:
 544       {
 545         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 546         if (call)
 547           {
 548             SCM arg1, arg2;
 549             POP (arg2);
 550             POP (arg1);
 551             SYNC_ALL ();
 552             *sp = call (x, arg1, arg2);
 553             NEXT;
 554           }
 555         break;
 556       }
 557     }
 558 #endif
 559   /*
 560    * Other interpreted or compiled call
 561    */
 562   if (!SCM_FALSEP (scm_procedure_p (x)))
 563     {
 564       /* At this point, the stack contains the procedure and each one of its
 565          arguments.  */
 566       POP_LIST (nargs);
 567       SYNC_REGISTER ();
 568       /* keep args on stack so they are marked */
 569       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 570       NULLSTACK_FOR_NONLOCAL_EXIT ();
 571       /* FIXME what if SCM_VALUESP(*sp) */
 572       DROP ();
 573       NEXT;
 574     }
 575   /*
 576    * Continuation call
 577    */
 578   if (SCM_VM_CONT_P (x))
 579     {
 580       program = x;
 581     vm_call_continuation:
 582       /* Check the number of arguments */
 583       /* FIXME multiple args */
 584       if (nargs != 1)
 585         scm_wrong_num_args (program);
 586
 587       /* Reinstate the continuation */
 588       EXIT_HOOK ();
 589       reinstate_vm_cont (vp, program);
 590       CACHE_REGISTER ();
 591       program = SCM_FRAME_PROGRAM (fp);
 592       CACHE_PROGRAM ();
 593       NEXT;
 594     }
 595
 596   program = x;
 597   goto vm_error_wrong_type_apply;
 598 }
 599
 600 VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
 601 {
 602   register SCM x;
 603   nargs = FETCH ();
 604  vm_goto_args:
 605   x = sp[-nargs];
 606
 607   SYNC_REGISTER ();
 608   SCM_TICK;     /* allow interrupt here */
 609
 610   /*
 611    * Tail recursive call
 612    */
 613   if (SCM_EQ_P (x, program))
 614     {
 615       int i;
 616
 617       /* Move arguments */
 618       INIT_ARGS ();
 619       sp -= bp->nargs - 1;
 620       for (i = 0; i < bp->nargs; i++)
 621         LOCAL_SET (i, sp[i]);
 622
 623       /* Drop the first argument and the program itself.  */
 624       sp -= 2;
 625       NULLSTACK (bp->nargs + 1)
 626
 627       /* Call itself */
 628       ip = bp->base;
 629       APPLY_HOOK ();
 630       NEXT;
 631     }
 632
 633   /*
 634    * Tail call, but not to self -- reuse the frame, keeping the ra and dl
 635    */
 636   if (SCM_PROGRAM_P (x))
 637     {
 638       SCM *data, *tail_args, *dl;
 639       int i;
 640       scm_byte_t *ra, *mvra;
 641 #ifdef VM_ENABLE_STACK_NULLING
 642       SCM *old_sp;
 643 #endif
 644
 645       EXIT_HOOK ();
 646
 647       /* save registers */
 648       tail_args = stack_base + 2;
 649       ra = SCM_FRAME_RETURN_ADDRESS (fp);
 650       mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
 651       dl = SCM_FRAME_DYNAMIC_LINK (fp);
 652
 653       /* switch programs */
 654       program = x;
 655       CACHE_PROGRAM ();
 656       INIT_ARGS ();
 657       /* delay updating the frame so that if INIT_ARGS has to cons up a rest
 658          arg, going into GC, the stack still makes sense */
 659       fp[-1] = program;
 660       nargs = bp->nargs;
 661
 662 #ifdef VM_ENABLE_STACK_NULLING
 663       old_sp = sp;
 664       CHECK_STACK_LEAK ();
 665 #endif
 666
 667       /* new registers -- logically this would be better later, but let's make
 668          sure we have space for the locals now */
 669       data = SCM_FRAME_DATA_ADDRESS (fp);
 670       ip = bp->base;
 671       stack_base = data + 4;
 672       sp = stack_base;
 673       CHECK_OVERFLOW ();
 674
 675       /* copy args, bottom-up */
 676       for (i = 0; i < nargs; i++)
 677         fp[i] = tail_args[i];
 678
 679       NULLSTACK (old_sp - sp);
 680
 681       /* init locals */
 682       for (i = bp->nlocs; i; i--)
 683         data[-i] = SCM_UNDEFINED;
 684
 685       /* Set frame data */
 686       data[4] = (SCM)ra;
 687       data[3] = (SCM)mvra;
 688       data[2] = (SCM)dl;
 689       data[1] = SCM_BOOL_F;
 690
 691       /* Postpone initializing external vars, because if the CONS causes a GC,
 692          we want the stack marker to see the data array formatted as expected. */
 693       data[0] = SCM_UNDEFINED;
 694       external = bp->external;
 695       for (i = 0; i < bp->nexts; i++)
 696         CONS (external, SCM_UNDEFINED, external);
 697       data[0] = external;
 698
 699       ENTER_HOOK ();
 700       APPLY_HOOK ();
 701       NEXT;
 702     }
 703 #ifdef ENABLE_TRAMPOLINE
 704   /* This seems to actually slow down the fibo test -- dunno why */
 705   /*
 706    * Subr call
 707    */
 708   switch (nargs)
 709     {
 710     case 0:
 711       {
 712         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 713         if (call)
 714           {
 715             SYNC_ALL ();
 716             *sp = call (x);
 717             goto vm_return;
 718           }
 719         break;
 720       }
 721     case 1:
 722       {
 723         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 724         if (call)
 725           {
 726             SCM arg1;
 727             POP (arg1);
 728             SYNC_ALL ();
 729             *sp = call (x, arg1);
 730             goto vm_return;
 731           }
 732         break;
 733       }
 734     case 2:
 735       {
 736         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 737         if (call)
 738           {
 739             SCM arg1, arg2;
 740             POP (arg2);
 741             POP (arg1);
 742             SYNC_ALL ();
 743             *sp = call (x, arg1, arg2);
 744             goto vm_return;
 745           }
 746         break;
 747       }
 748     }
 749 #endif
 750
 751   /*
 752    * Other interpreted or compiled call
 753    */
 754   if (!SCM_FALSEP (scm_procedure_p (x)))
 755     {
 756       POP_LIST (nargs);
 757       SYNC_REGISTER ();
 758       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 759       NULLSTACK_FOR_NONLOCAL_EXIT ();
 760       DROP ();
 761       /* FIXME what if SCM_VALUESP(*sp) */
 762       goto vm_return;
 763     }
 764
 765   program = x;
 766
 767   /*
 768    * Continuation call
 769    */
 770   if (SCM_VM_CONT_P (program))
 771     goto vm_call_continuation;
 772
 773   goto vm_error_wrong_type_apply;
 774 }
 775
 776 VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
 777 {
 778   SCM x;
 779   POP (x);
 780   nargs = scm_to_int (x);
 781   /* FIXME: should truncate values? */
 782   goto vm_goto_args;
 783 }
 784
 785 VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
 786 {
 787   SCM x;
 788   POP (x);
 789   nargs = scm_to_int (x);
 790   /* FIXME: should truncate values? */
 791   goto vm_call;
 792 }
 793
 794 VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
 795 {
 796   SCM x;
 797   signed short offset;
 798
 799   nargs = FETCH ();
 800   FETCH_OFFSET (offset);
 801
 802   x = sp[-nargs];
 803
 804   /*
 805    * Subprogram call
 806    */
 807   if (SCM_PROGRAM_P (x))
 808     {
 809       program = x;
 810       CACHE_PROGRAM ();
 811       INIT_ARGS ();
 812       NEW_FRAME ();
 813       SCM_FRAME_DATA_ADDRESS (fp)[3] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
 814       ENTER_HOOK ();
 815       APPLY_HOOK ();
 816       NEXT;
 817     }
 818   /*
 819    * Other interpreted or compiled call
 820    */
 821   if (!SCM_FALSEP (scm_procedure_p (x)))
 822     {
 823       /* At this point, the stack contains the procedure and each one of its
 824          arguments.  */
 825       POP_LIST (nargs);
 826       SYNC_REGISTER ();
 827       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 828       NULLSTACK_FOR_NONLOCAL_EXIT ();
 829       DROP ();
 830       if (SCM_VALUESP (*sp))
 831         {
 832           SCM values, len;
 833           POP (values);
 834           values = scm_struct_ref (values, SCM_INUM0);
 835           len = scm_length (values);
 836           for (; !SCM_NULLP (values); values = SCM_CDR (values))
 837             PUSH (SCM_CAR (values));
 838           PUSH (len);
 839           ip += offset;
 840         }
 841       NEXT;
 842     }
 843   /*
 844    * Continuation call
 845    */
 846   if (SCM_VM_CONT_P (x))
 847     {
 848       program = x;
 849       goto vm_call_continuation;
 850     }
 851
 852   program = x;
 853   goto vm_error_wrong_type_apply;
 854 }
 855
 856 VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
 857 {
 858   int len;
 859   SCM ls;
 860   POP (ls);
 861
 862   nargs = FETCH ();
 863   ASSERT (nargs >= 2);
 864
 865   len = scm_ilength (ls);
 866   if (len < 0)
 867     goto vm_error_wrong_type_arg;
 868
 869   for (; !SCM_NULLP (ls); ls = SCM_CDR (ls))
 870     PUSH (SCM_CAR (ls));
 871
 872   nargs += len - 2;
 873   goto vm_call;
 874 }
 875
 876 VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
 877 {
 878   int len;
 879   SCM ls;
 880   POP (ls);
 881
 882   nargs = FETCH ();
 883   ASSERT (nargs >= 2);
 884
 885   len = scm_ilength (ls);
 886   if (len < 0)
 887     goto vm_error_wrong_type_arg;
 888
 889   for (; !SCM_NULLP (ls); ls = SCM_CDR (ls))
 890     PUSH (SCM_CAR (ls));
 891
 892   nargs += len - 2;
 893   goto vm_goto_args;
 894 }
 895
 896 VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
 897 {
 898   int first;
 899   SCM proc, cont;
 900   POP (proc);
 901   SYNC_ALL ();
 902   cont = scm_make_continuation (&first);
 903   if (first)
 904     {
 905       PUSH (proc);
 906       PUSH (cont);
 907       nargs = 1;
 908       goto vm_call;
 909     }
 910   ASSERT (sp == vp->sp);
 911   ASSERT (fp == vp->fp);
 912   else if (SCM_VALUESP (cont))
 913     {
 914       /* multiple values returned to continuation */
 915       SCM values;
 916       values = scm_struct_ref (cont, SCM_INUM0);
 917       if (SCM_NULLP (values))
 918         goto vm_error_no_values;
 919       /* non-tail context does not accept multiple values? */
 920       PUSH (SCM_CAR (values));
 921       NEXT;
 922     }
 923   else
 924     {
 925       PUSH (cont);
 926       NEXT;
 927     }
 928 }
 929
 930 VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
 931 {
 932   int first;
 933   SCM proc, cont;
 934   POP (proc);
 935   SYNC_ALL ();
 936   cont = scm_make_continuation (&first);
 937   ASSERT (sp == vp->sp);
 938   ASSERT (fp == vp->fp);
 939   if (first)
 940     {
 941       PUSH (proc);
 942       PUSH (cont);
 943       nargs = 1;
 944       goto vm_goto_args;
 945     }
 946   else if (SCM_VALUESP (cont))
 947     {
 948       /* multiple values returned to continuation */
 949       SCM values;
 950       values = scm_struct_ref (cont, SCM_INUM0);
 951       nvalues = scm_ilength (values);
 952       for (; !SCM_NULLP (values); values = SCM_CDR (values))
 953         PUSH (SCM_CAR (values));
 954       goto vm_return_values;
 955     }
 956   else
 957     {
 958       PUSH (cont);
 959       goto vm_return;
 960     }
 961 }
 962
 963 VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
 964 {
 965  vm_return:
 966   EXIT_HOOK ();
 967   RETURN_HOOK ();
 968   {
 969     SCM ret, *data;
 970     data = SCM_FRAME_DATA_ADDRESS (fp);
 971
 972     POP (ret);
 973     ASSERT (sp == stack_base);
 974     ASSERT (stack_base == data + 4);
 975
 976     /* Restore registers */
 977     sp = SCM_FRAME_LOWER_ADDRESS (fp);
 978     ip = SCM_FRAME_BYTE_CAST (data[4]);
 979     fp = SCM_FRAME_STACK_CAST (data[2]);
 980     {
 981 #ifdef VM_ENABLE_STACK_NULLING
 982       int nullcount = stack_base - sp;
 983 #endif
 984       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
 985       NULLSTACK (nullcount);
 986     }
 987
 988     /* Set return value (sp is already pushed) */
 989     *sp = ret;
 990   }
 991
 992   /* Restore the last program */
 993   program = SCM_FRAME_PROGRAM (fp);
 994   CACHE_PROGRAM ();
 995   CACHE_EXTERNAL ();
 996   CHECK_IP ();
 997   NEXT;
 998 }
 999
1000 VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
1001 {
1002   /* nvalues declared at top level, because for some reason gcc seems to think
1003      that perhaps it might be used without declaration. Fooey to that, I say. */
1004   SCM *data;
1005
1006   nvalues = FETCH ();
1007  vm_return_values:
1008   EXIT_HOOK ();
1009   RETURN_HOOK ();
1010
1011   data = SCM_FRAME_DATA_ADDRESS (fp);
1012   ASSERT (stack_base == data + 4);
1013
1014   /* data[3] is the mv return address */
1015   if (nvalues != 1 && data[3])
1016     {
1017       int i;
1018       /* Restore registers */
1019       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1020       ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */
1021       fp = SCM_FRAME_STACK_CAST (data[2]);
1022
1023       /* Push return values, and the number of values */
1024       for (i = 0; i < nvalues; i++)
1025         *++sp = stack_base[1+i];
1026       *++sp = SCM_I_MAKINUM (nvalues);
1027
1028       /* Finally set new stack_base */
1029       NULLSTACK (stack_base - sp + nvalues + 1);
1030       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1031     }
1032   else if (nvalues >= 1)
1033     {
1034       /* Multiple values for a single-valued continuation -- here's where I
1035          break with guile tradition and try and do something sensible. (Also,
1036          this block handles the single-valued return to an mv
1037          continuation.) */
1038       /* Restore registers */
1039       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1040       ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */
1041       fp = SCM_FRAME_STACK_CAST (data[2]);
1042
1043       /* Push first value */
1044       *++sp = stack_base[1];
1045
1046       /* Finally set new stack_base */
1047       NULLSTACK (stack_base - sp);
1048       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1049     }
1050   else
1051     goto vm_error_no_values;
1052
1053   /* Restore the last program */
1054   program = SCM_FRAME_PROGRAM (fp);
1055   CACHE_PROGRAM ();
1056   CACHE_EXTERNAL ();
1057   CHECK_IP ();
1058   NEXT;
1059 }
1060
1061 VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
1062 {
1063   SCM l;
1064
1065   nvalues = FETCH ();
1066   ASSERT (nvalues >= 1);
1067
1068   nvalues--;
1069   POP (l);
1070   while (SCM_CONSP (l))
1071     {
1072       PUSH (SCM_CAR (l));
1073       l = SCM_CDR (l);
1074       nvalues++;
1075     }
1076
1077   goto vm_return_values;
1078 }
1079
1080 VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
1081 {
1082   SCM x;
1083   int nbinds, rest;
1084   POP (x);
1085   nvalues = scm_to_int (x);
1086   nbinds = FETCH ();
1087   rest = FETCH ();
1088
1089   if (rest)
1090     nbinds--;
1091
1092   if (nvalues < nbinds)
1093     goto vm_error_not_enough_values;
1094
1095   if (rest)
1096     POP_LIST (nvalues - nbinds);
1097   else
1098     DROPN (nvalues - nbinds);
1099
1100   NEXT;
1101 }
1102
1103 /*
1104   Local Variables:
1105   c-file-style: "gnu"
1106   End:
1107 */