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