libguile/vm-i-system.c

   1 /* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 /* This file is included in vm_engine.c */
  21
  22 \f
  23 /*
  24  * Basic operations
  25  */
  26
  27 VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
  28 {
  29   NEXT;
  30 }
  31
  32 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
  33 {
  34   nvalues = SCM_I_INUM (*sp--);
  35   NULLSTACK (1);
  36   if (nvalues == 1)
  37     POP (finish_args);
  38   else
  39     {
  40       POP_LIST (nvalues);
  41       POP (finish_args);
  42       SYNC_REGISTER ();
  43       finish_args = scm_values (finish_args);
  44     }
  45
  46   {
  47 #ifdef VM_ENABLE_STACK_NULLING
  48     SCM *old_sp = sp;
  49 #endif
  50
  51     /* Restore registers */
  52     sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
  53     /* Setting the ip here doesn't actually affect control flow, as the calling
  54        code will restore its own registers, but it does help when walking the
  55        stack */
  56     ip = SCM_FRAME_RETURN_ADDRESS (fp);
  57     fp = SCM_FRAME_DYNAMIC_LINK (fp);
  58     NULLSTACK (old_sp - sp);
  59   }
  60
  61   goto vm_done;
  62 }
  63
  64 VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
  65 {
  66   DROP ();
  67   NEXT;
  68 }
  69
  70 VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1)
  71 {
  72   SCM x = *sp;
  73   PUSH (x);
  74   DEAD (x);
  75   NEXT;
  76 }
  77
  78 \f
  79 /*
  80  * Object creation
  81  */
  82
  83 VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
  84 {
  85   PUSH (SCM_UNSPECIFIED);
  86   NEXT;
  87 }
  88
  89 VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1)
  90 {
  91   PUSH (SCM_BOOL_T);
  92   NEXT;
  93 }
  94
  95 VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1)
  96 {
  97   PUSH (SCM_BOOL_F);
  98   NEXT;
  99 }
 100
 101 VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1)
 102 {
 103   PUSH (SCM_ELISP_NIL);
 104   NEXT;
 105 }
 106
 107 VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
 108 {
 109   PUSH (SCM_EOL);
 110   NEXT;
 111 }
 112
 113 VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
 114 {
 115   PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
 116   NEXT;
 117 }
 118
 119 VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
 120 {
 121   PUSH (SCM_INUM0);
 122   NEXT;
 123 }
 124
 125 VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
 126 {
 127   PUSH (SCM_I_MAKINUM (1));
 128   NEXT;
 129 }
 130
 131 VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
 132 {
 133   int h = FETCH ();
 134   int l = FETCH ();
 135   PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
 136   NEXT;
 137 }
 138
 139 VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
 140 {
 141   scm_t_uint64 v = 0;
 142   v += FETCH ();
 143   v <<= 8; v += FETCH ();
 144   v <<= 8; v += FETCH ();
 145   v <<= 8; v += FETCH ();
 146   v <<= 8; v += FETCH ();
 147   v <<= 8; v += FETCH ();
 148   v <<= 8; v += FETCH ();
 149   v <<= 8; v += FETCH ();
 150   PUSH (scm_from_int64 ((scm_t_int64) v));
 151   NEXT;
 152 }
 153
 154 VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
 155 {
 156   scm_t_uint64 v = 0;
 157   v += FETCH ();
 158   v <<= 8; v += FETCH ();
 159   v <<= 8; v += FETCH ();
 160   v <<= 8; v += FETCH ();
 161   v <<= 8; v += FETCH ();
 162   v <<= 8; v += FETCH ();
 163   v <<= 8; v += FETCH ();
 164   v <<= 8; v += FETCH ();
 165   PUSH (scm_from_uint64 (v));
 166   NEXT;
 167 }
 168
 169 VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
 170 {
 171   scm_t_uint8 v = 0;
 172   v = FETCH ();
 173
 174   PUSH (SCM_MAKE_CHAR (v));
 175   /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())).  The
 176      contents of SCM_MAKE_CHAR may be evaluated more than once,
 177      resulting in a double fetch.  */
 178   NEXT;
 179 }
 180
 181 VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
 182 {
 183   scm_t_wchar v = 0;
 184   v += FETCH ();
 185   v <<= 8; v += FETCH ();
 186   v <<= 8; v += FETCH ();
 187   v <<= 8; v += FETCH ();
 188   PUSH (SCM_MAKE_CHAR (v));
 189   NEXT;
 190 }
 191
 192
 193
 194 VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
 195 {
 196   unsigned h = FETCH ();
 197   unsigned l = FETCH ();
 198   unsigned len = ((h << 8) + l);
 199   POP_LIST (len);
 200   NEXT;
 201 }
 202
 203 VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
 204 {
 205   unsigned h = FETCH ();
 206   unsigned l = FETCH ();
 207   unsigned len = ((h << 8) + l);
 208   SCM vect;
 209
 210   SYNC_REGISTER ();
 211   sp++; sp -= len;
 212   CHECK_UNDERFLOW ();
 213   vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
 214   memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
 215   NULLSTACK (len);
 216   *sp = vect;
 217   DEAD (vect);
 218
 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)      (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
 239
 240 #define FREE_VARIABLE_REF(i)    SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
 241
 242 /* ref */
 243
 244 VM_DEFINE_INSTRUCTION (19, 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 /* FIXME: necessary? elt 255 of the vector could be a vector... */
 253 VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
 254 {
 255   unsigned int objnum = FETCH ();
 256   objnum <<= 8;
 257   objnum += FETCH ();
 258   CHECK_OBJECT (objnum);
 259   PUSH (OBJECT_REF (objnum));
 260   NEXT;
 261 }
 262
 263 VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
 264 {
 265   PUSH (LOCAL_REF (FETCH ()));
 266   ASSERT_BOUND (*sp);
 267   NEXT;
 268 }
 269
 270 VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
 271 {
 272   unsigned int i = FETCH ();
 273   i <<= 8;
 274   i += FETCH ();
 275   PUSH (LOCAL_REF (i));
 276   ASSERT_BOUND (*sp);
 277   NEXT;
 278 }
 279
 280 VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
 281 {
 282   PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
 283   NEXT;
 284 }
 285
 286 VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
 287 {
 288   unsigned int i = FETCH ();
 289   i <<= 8;
 290   i += FETCH ();
 291   PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
 292   NEXT;
 293 }
 294
 295 VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1)
 296 {
 297   SCM x = *sp;
 298
 299   /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
 300      unlike in top-variable-ref, it really isn't an internal assertion
 301      that can be optimized out -- the variable could be coming directly
 302      from the user.  */
 303   if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
 304     {
 305       func_name = "variable-ref";
 306       finish_args = x;
 307       goto vm_error_not_a_variable;
 308     }
 309   else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
 310     {
 311       SCM var_name;
 312
 313       /* Attempt to provide the variable name in the error message.  */
 314       var_name = scm_module_reverse_lookup (scm_current_module (), x);
 315       finish_args = scm_is_true (var_name) ? var_name : x;
 316       goto vm_error_unbound;
 317     }
 318   else
 319     {
 320       SCM o = VARIABLE_REF (x);
 321       *sp = o;
 322       DEAD (o);
 323     }
 324
 325   NEXT;
 326 }
 327
 328 VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1)
 329 {
 330   SCM x = *sp;
 331
 332   if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
 333     {
 334       func_name = "variable-bound?";
 335       finish_args = x;
 336       goto vm_error_not_a_variable;
 337     }
 338   else
 339     *sp = scm_from_bool (VARIABLE_BOUNDP (x));
 340   DEAD (x);
 341   NEXT;
 342 }
 343
 344 VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
 345 {
 346   unsigned objnum = FETCH ();
 347   SCM what;
 348   CHECK_OBJECT (objnum);
 349   what = OBJECT_REF (objnum);
 350
 351   if (!SCM_VARIABLEP (what))
 352     {
 353       SCM resolved;
 354       SYNC_REGISTER ();
 355       resolved = resolve_variable (what, scm_program_module (program));
 356       if (!VARIABLE_BOUNDP (resolved))
 357         {
 358           finish_args = what;
 359           goto vm_error_unbound;
 360         }
 361       what = resolved;
 362       DEAD (resolved);
 363       OBJECT_SET (objnum, what);
 364     }
 365
 366   PUSH (VARIABLE_REF (what));
 367   DEAD (what);
 368   NEXT;
 369 }
 370
 371 VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
 372 {
 373   SCM what;
 374   unsigned int objnum = FETCH ();
 375   objnum <<= 8;
 376   objnum += FETCH ();
 377   CHECK_OBJECT (objnum);
 378   what = OBJECT_REF (objnum);
 379
 380   if (!SCM_VARIABLEP (what))
 381     {
 382       SCM resolved;
 383       SYNC_REGISTER ();
 384       resolved = resolve_variable (what, scm_program_module (program));
 385       if (!VARIABLE_BOUNDP (resolved))
 386         {
 387           finish_args = what;
 388           goto vm_error_unbound;
 389         }
 390       what = resolved;
 391       DEAD (resolved);
 392       OBJECT_SET (objnum, what);
 393     }
 394
 395   PUSH (VARIABLE_REF (what));
 396   DEAD (what);
 397   NEXT;
 398 }
 399
 400 /* set */
 401
 402 VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
 403 {
 404   SCM x;
 405   POP (x);
 406   LOCAL_SET (FETCH (), x);
 407   DEAD (x);
 408   NEXT;
 409 }
 410
 411 VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
 412 {
 413   SCM x;
 414   unsigned int i = FETCH ();
 415   i <<= 8;
 416   i += FETCH ();
 417   POP (x);
 418   LOCAL_SET (i, x);
 419   DEAD (x);
 420   NEXT;
 421 }
 422
 423 VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
 424 {
 425   if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
 426     {
 427       func_name = "variable-set!";
 428       finish_args = sp[0];
 429       goto vm_error_not_a_variable;
 430     }
 431   VARIABLE_SET (sp[0], sp[-1]);
 432   DROPN (2);
 433   NEXT;
 434 }
 435
 436 VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
 437 {
 438   unsigned objnum = FETCH ();
 439   SCM what;
 440   CHECK_OBJECT (objnum);
 441   what = OBJECT_REF (objnum);
 442
 443   if (!SCM_VARIABLEP (what))
 444     {
 445       SYNC_BEFORE_GC ();
 446       what = resolve_variable (what, scm_program_module (program));
 447       OBJECT_SET (objnum, what);
 448     }
 449
 450   VARIABLE_SET (what, *sp);
 451   DEAD (what);
 452   DROP ();
 453   NEXT;
 454 }
 455
 456 VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
 457 {
 458   SCM what;
 459   unsigned int objnum = FETCH ();
 460   objnum <<= 8;
 461   objnum += FETCH ();
 462   CHECK_OBJECT (objnum);
 463   what = OBJECT_REF (objnum);
 464
 465   if (!SCM_VARIABLEP (what))
 466     {
 467       SYNC_BEFORE_GC ();
 468       what = resolve_variable (what, scm_program_module (program));
 469       OBJECT_SET (objnum, what);
 470     }
 471
 472   VARIABLE_SET (what, *sp);
 473   DEAD (what);
 474   DROP ();
 475   NEXT;
 476 }
 477
 478 \f
 479 /*
 480  * branch and jump
 481  */
 482
 483 /* offset must be at least 24 bits wide, and signed */
 484 #define FETCH_OFFSET(offset)                    \
 485 {                                               \
 486   offset = FETCH () << 16;                      \
 487   offset += FETCH () << 8;                      \
 488   offset += FETCH ();                           \
 489   offset -= (offset & (1<<23)) << 1;            \
 490 }
 491
 492 #define BR(p)                                   \
 493 {                                               \
 494   scm_t_int32 offset;                           \
 495   FETCH_OFFSET (offset);                        \
 496   if (p)                                        \
 497     ip += offset;                               \
 498   if (offset < 0)                               \
 499     VM_HANDLE_INTERRUPTS;                       \
 500 }
 501
 502 VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
 503 {
 504   scm_t_int32 offset;
 505   FETCH_OFFSET (offset);
 506   ip += offset;
 507   if (offset < 0)
 508     VM_HANDLE_INTERRUPTS;
 509   NEXT;
 510 }
 511
 512 VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
 513 {
 514   SCM x;
 515   POP (x);
 516   BR (scm_is_true (x));
 517   DEAD (x);
 518   NEXT;
 519 }
 520
 521 VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
 522 {
 523   SCM x;
 524   POP (x);
 525   BR (scm_is_false (x));
 526   DEAD (x);
 527   NEXT;
 528 }
 529
 530 VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
 531 {
 532   SCM x, y;
 533   POP2 (y, x);
 534   BR (scm_is_eq (x, y));
 535   DEAD (x);
 536   DEAD (y);
 537   NEXT;
 538 }
 539
 540 VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
 541 {
 542   SCM x, y;
 543   POP2 (y, x);
 544   BR (!scm_is_eq (x, y));
 545   DEAD (x);
 546   DEAD (y);
 547   NEXT;
 548 }
 549
 550 VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
 551 {
 552   SCM x;
 553   POP (x);
 554   BR (scm_is_null (x));
 555   DEAD (x);
 556   NEXT;
 557 }
 558
 559 VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
 560 {
 561   SCM x;
 562   POP (x);
 563   BR (!scm_is_null (x));
 564   DEAD (x);
 565   NEXT;
 566 }
 567
 568 \f
 569 /*
 570  * Subprogram call
 571  */
 572
 573 VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
 574 {
 575   scm_t_ptrdiff n;
 576   scm_t_int32 offset;
 577   n = FETCH () << 8;
 578   n += FETCH ();
 579   FETCH_OFFSET (offset);
 580   if (sp - (fp - 1) != n)
 581     ip += offset;
 582   NEXT;
 583 }
 584
 585 VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
 586 {
 587   scm_t_ptrdiff n;
 588   scm_t_int32 offset;
 589   n = FETCH () << 8;
 590   n += FETCH ();
 591   FETCH_OFFSET (offset);
 592   if (sp - (fp - 1) < n)
 593     ip += offset;
 594   NEXT;
 595 }
 596
 597 VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
 598 {
 599   scm_t_ptrdiff n;
 600   scm_t_int32 offset;
 601
 602   n = FETCH () << 8;
 603   n += FETCH ();
 604   FETCH_OFFSET (offset);
 605   if (sp - (fp - 1) > n)
 606     ip += offset;
 607   NEXT;
 608 }
 609
 610 VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
 611 {
 612   scm_t_ptrdiff n;
 613   n = FETCH () << 8;
 614   n += FETCH ();
 615   if (sp - (fp - 1) != n)
 616     goto vm_error_wrong_num_args;
 617   NEXT;
 618 }
 619
 620 VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
 621 {
 622   scm_t_ptrdiff n;
 623   n = FETCH () << 8;
 624   n += FETCH ();
 625   if (sp - (fp - 1) < n)
 626     goto vm_error_wrong_num_args;
 627   NEXT;
 628 }
 629
 630 VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
 631 {
 632   scm_t_ptrdiff n;
 633   n = FETCH () << 8;
 634   n += FETCH ();
 635   while (sp - (fp - 1) < n)
 636     PUSH (SCM_UNDEFINED);
 637   NEXT;
 638 }
 639
 640 VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
 641 {
 642   SCM *walk;
 643   scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
 644   nreq = FETCH () << 8;
 645   nreq += FETCH ();
 646   nreq_and_opt = FETCH () << 8;
 647   nreq_and_opt += FETCH ();
 648   ntotal = FETCH () << 8;
 649   ntotal += FETCH ();
 650
 651   /* look in optionals for first keyword or last positional */
 652   /* starting after the last required positional arg */
 653   walk = fp + nreq;
 654   while (/* while we have args */
 655          walk <= sp
 656          /* and we still have positionals to fill */
 657          && walk - fp < nreq_and_opt
 658          /* and we haven't reached a keyword yet */
 659          && !scm_is_keyword (*walk))
 660     /* bind this optional arg (by leaving it in place) */
 661     walk++;
 662   /* now shuffle up, from walk to ntotal */
 663   {
 664     scm_t_ptrdiff nshuf = sp - walk + 1, i;
 665     sp = (fp - 1) + ntotal + nshuf;
 666     CHECK_OVERFLOW ();
 667     for (i = 0; i < nshuf; i++)
 668       sp[-i] = walk[nshuf-i-1];
 669   }
 670   /* and fill optionals & keyword args with SCM_UNDEFINED */
 671   while (walk <= (fp - 1) + ntotal)
 672     *walk++ = SCM_UNDEFINED;
 673
 674   NEXT;
 675 }
 676
 677 /* Flags that determine whether other keywords are allowed, and whether a
 678    rest argument is expected.  These values must match those used by the
 679    glil->assembly compiler.  */
 680 #define F_ALLOW_OTHER_KEYS  1
 681 #define F_REST              2
 682
 683 VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
 684 {
 685   scm_t_uint16 idx;
 686   scm_t_ptrdiff nkw;
 687   int kw_and_rest_flags;
 688   SCM kw;
 689   idx = FETCH () << 8;
 690   idx += FETCH ();
 691   /* XXX: We don't actually use NKW.  */
 692   nkw = FETCH () << 8;
 693   nkw += FETCH ();
 694   kw_and_rest_flags = FETCH ();
 695
 696   if (!(kw_and_rest_flags & F_REST)
 697       && ((sp - (fp - 1) - nkw) % 2))
 698     goto vm_error_kwargs_length_not_even;
 699
 700   CHECK_OBJECT (idx);
 701   kw = OBJECT_REF (idx);
 702
 703   /* Switch NKW to be a negative index below SP.  */
 704   for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
 705     {
 706       SCM walk;
 707
 708       if (scm_is_keyword (sp[nkw]))
 709         {
 710           for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
 711             {
 712               if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
 713                 {
 714                   SCM si = SCM_CDAR (walk);
 715                   LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
 716                              sp[nkw + 1]);
 717                   break;
 718                 }
 719             }
 720           if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
 721             goto vm_error_kwargs_unrecognized_keyword;
 722
 723           nkw++;
 724         }
 725       else if (!(kw_and_rest_flags & F_REST))
 726         goto vm_error_kwargs_invalid_keyword;
 727     }
 728
 729   DEAD (kw);
 730
 731   NEXT;
 732 }
 733
 734 #undef F_ALLOW_OTHER_KEYS
 735 #undef F_REST
 736
 737
 738 VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
 739 {
 740   scm_t_ptrdiff n;
 741   SCM rest = SCM_EOL;
 742   n = FETCH () << 8;
 743   n += FETCH ();
 744   while (sp - (fp - 1) > n)
 745     /* No need to check for underflow. */
 746     CONS (rest, *sp--, rest);
 747   PUSH (rest);
 748   DEAD (rest);
 749   NEXT;
 750 }
 751
 752 VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
 753 {
 754   scm_t_ptrdiff n;
 755   scm_t_uint32 i;
 756   SCM rest = SCM_EOL;
 757   n = FETCH () << 8;
 758   n += FETCH ();
 759   i = FETCH () << 8;
 760   i += FETCH ();
 761   while (sp - (fp - 1) > n)
 762     /* No need to check for underflow. */
 763     CONS (rest, *sp--, rest);
 764   LOCAL_SET (i, rest);
 765   DEAD (rest);
 766   NEXT;
 767 }
 768
 769 VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
 770 {
 771   SCM *old_sp;
 772   scm_t_int32 n;
 773   n = FETCH () << 8;
 774   n += FETCH ();
 775   old_sp = sp;
 776   sp = (fp - 1) + n;
 777
 778   if (old_sp < sp)
 779     {
 780       CHECK_OVERFLOW ();
 781       while (old_sp < sp)
 782         *++old_sp = SCM_UNDEFINED;
 783     }
 784   else
 785     NULLSTACK (old_sp - sp);
 786
 787   NEXT;
 788 }
 789
 790 VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
 791 {
 792   /* NB: if you change this, see frames.c:vm-frame-num-locals */
 793   /* and frames.h, vm-engine.c, etc of course */
 794
 795   /* We don't initialize the dynamic link here because we don't actually
 796      know that this frame will point to the current fp: it could be
 797      placed elsewhere on the stack if captured in a partial
 798      continuation, and invoked from some other context.  */
 799   PUSH (SCM_PACK (0)); /* dynamic link */
 800   PUSH (SCM_PACK (0)); /* mvra */
 801   PUSH (SCM_PACK (0)); /* ra */
 802   NEXT;
 803 }
 804
 805 VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
 806 {
 807   nargs = FETCH ();
 808
 809  vm_call:
 810   program = sp[-nargs];
 811
 812   VM_HANDLE_INTERRUPTS;
 813
 814   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 815     {
 816       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 817         {
 818           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 819           goto vm_call;
 820         }
 821       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 822                && SCM_SMOB_APPLICABLE_P (program))
 823         {
 824           SYNC_REGISTER ();
 825           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 826           goto vm_call;
 827         }
 828       else
 829         goto vm_error_wrong_type_apply;
 830     }
 831
 832   CACHE_PROGRAM ();
 833
 834   {
 835     SCM *old_fp = fp;
 836
 837     fp = sp - nargs + 1;
 838
 839     ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
 840     ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 841     ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 842     SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
 843     SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 844     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
 845   }
 846
 847   ip = SCM_C_OBJCODE_BASE (bp);
 848   PUSH_CONTINUATION_HOOK ();
 849   APPLY_HOOK ();
 850   NEXT;
 851 }
 852
 853 VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
 854 {
 855   nargs = FETCH ();
 856
 857  vm_tail_call:
 858   program = sp[-nargs];
 859
 860   VM_HANDLE_INTERRUPTS;
 861
 862   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 863     {
 864       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 865         {
 866           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 867           goto vm_tail_call;
 868         }
 869       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 870                && SCM_SMOB_APPLICABLE_P (program))
 871         {
 872           SYNC_REGISTER ();
 873           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 874           goto vm_tail_call;
 875         }
 876       else
 877         goto vm_error_wrong_type_apply;
 878     }
 879   else
 880     {
 881       int i;
 882 #ifdef VM_ENABLE_STACK_NULLING
 883       SCM *old_sp = sp;
 884       CHECK_STACK_LEAK ();
 885 #endif
 886
 887       /* switch programs */
 888       CACHE_PROGRAM ();
 889       /* shuffle down the program and the arguments */
 890       for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
 891         SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 892
 893       sp = fp + i - 1;
 894
 895       NULLSTACK (old_sp - sp);
 896
 897       ip = SCM_C_OBJCODE_BASE (bp);
 898
 899       APPLY_HOOK ();
 900       NEXT;
 901     }
 902 }
 903
 904 VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
 905 {
 906   SCM pointer, ret;
 907   SCM (*subr)();
 908
 909   nargs = FETCH ();
 910   POP (pointer);
 911
 912   subr = SCM_POINTER_VALUE (pointer);
 913
 914   VM_HANDLE_INTERRUPTS;
 915   SYNC_REGISTER ();
 916
 917   switch (nargs)
 918     {
 919     case 0:
 920       ret = subr ();
 921       break;
 922     case 1:
 923       ret = subr (sp[0]);
 924       break;
 925     case 2:
 926       ret = subr (sp[-1], sp[0]);
 927       break;
 928     case 3:
 929       ret = subr (sp[-2], sp[-1], sp[0]);
 930       break;
 931     case 4:
 932       ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
 933       break;
 934     case 5:
 935       ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 936       break;
 937     case 6:
 938       ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 939       break;
 940     case 7:
 941       ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 942       break;
 943     case 8:
 944       ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 945       break;
 946     case 9:
 947       ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 948       break;
 949     case 10:
 950       ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 951       break;
 952     default:
 953       abort ();
 954     }
 955
 956   DEAD (pointer);
 957   NULLSTACK_FOR_NONLOCAL_EXIT ();
 958
 959   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 960     {
 961       /* multiple values returned to continuation */
 962       ret = scm_struct_ref (ret, SCM_INUM0);
 963       nvalues = scm_ilength (ret);
 964       PUSH_LIST (ret, scm_is_null);
 965       DEAD (ret);
 966       goto vm_return_values;
 967     }
 968   else
 969     {
 970       PUSH (ret);
 971       DEAD (ret);
 972       goto vm_return;
 973     }
 974 }
 975
 976 VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
 977 {
 978   SCM smob, ret;
 979   SCM (*subr)();
 980   nargs = FETCH ();
 981   POP (smob);
 982
 983   subr = SCM_SMOB_DESCRIPTOR (smob).apply;
 984
 985   VM_HANDLE_INTERRUPTS;
 986   SYNC_REGISTER ();
 987
 988   switch (nargs)
 989     {
 990     case 0:
 991       ret = subr (smob);
 992       break;
 993     case 1:
 994       ret = subr (smob, sp[0]);
 995       break;
 996     case 2:
 997       ret = subr (smob, sp[-1], sp[0]);
 998       break;
 999     case 3:
1000       ret = subr (smob, sp[-2], sp[-1], sp[0]);
1001       break;
1002     default:
1003       abort ();
1004     }
1005
1006   DEAD (smob);
1007   NULLSTACK_FOR_NONLOCAL_EXIT ();
1008
1009   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1010     {
1011       /* multiple values returned to continuation */
1012       ret = scm_struct_ref (ret, SCM_INUM0);
1013       nvalues = scm_ilength (ret);
1014       PUSH_LIST (ret, scm_is_null);
1015       DEAD (ret);
1016       goto vm_return_values;
1017     }
1018   else
1019     {
1020       PUSH (ret);
1021       DEAD (ret);
1022       goto vm_return;
1023     }
1024 }
1025
1026 VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
1027 {
1028   SCM foreign, ret;
1029   nargs = FETCH ();
1030   POP (foreign);
1031
1032   VM_HANDLE_INTERRUPTS;
1033   SYNC_REGISTER ();
1034
1035   ret = scm_i_foreign_call (foreign, sp - nargs + 1);
1036
1037   DEAD (foreign);
1038   NULLSTACK_FOR_NONLOCAL_EXIT ();
1039
1040   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1041     {
1042       /* multiple values returned to continuation */
1043       ret = scm_struct_ref (ret, SCM_INUM0);
1044       nvalues = scm_ilength (ret);
1045       PUSH_LIST (ret, scm_is_null);
1046       DEAD (ret);
1047       goto vm_return_values;
1048     }
1049   else
1050     {
1051       PUSH (ret);
1052       DEAD (ret);
1053       goto vm_return;
1054     }
1055 }
1056
1057 VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
1058 {
1059   SCM contregs;
1060   POP (contregs);
1061
1062   SYNC_ALL ();
1063   scm_i_check_continuation (contregs);
1064   vm_return_to_continuation (scm_i_contregs_vm (contregs),
1065                              scm_i_contregs_vm_cont (contregs),
1066                              sp - (fp - 1), fp);
1067   scm_i_reinstate_continuation (contregs);
1068
1069   /* no DEAD, no NEXT */
1070   abort ();
1071 }
1072
1073 VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
1074 {
1075   SCM vmcont, intwinds, prevwinds;
1076   POP2 (intwinds, vmcont);
1077   SYNC_REGISTER ();
1078   if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
1079     {
1080       finish_args = vmcont;
1081       goto vm_error_continuation_not_rewindable;
1082     }
1083   prevwinds = scm_i_dynwinds ();
1084   vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
1085                                      vm_cookie);
1086   DEAD (vmcont);
1087   DEAD (intwinds);
1088
1089   /* Rewind prompt jmpbuffers, if any. */
1090   {
1091     SCM winds = scm_i_dynwinds ();
1092     for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
1093       if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
1094         break;
1095     DEAD (winds);
1096   }
1097   DEAD (prevwinds);
1098
1099   CACHE_REGISTER ();
1100   program = SCM_FRAME_PROGRAM (fp);
1101   CACHE_PROGRAM ();
1102   NEXT;
1103 }
1104
1105 VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
1106 {
1107   SCM x;
1108   POP (x);
1109   nargs = scm_to_int (x);
1110   DEAD (x);
1111   /* FIXME: should truncate values? */
1112   goto vm_tail_call;
1113 }
1114
1115 VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
1116 {
1117   SCM x;
1118   POP (x);
1119   nargs = scm_to_int (x);
1120   DEAD (x);
1121   /* FIXME: should truncate values? */
1122   goto vm_call;
1123 }
1124
1125 VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
1126 {
1127   scm_t_int32 offset;
1128   scm_t_uint8 *mvra;
1129
1130   nargs = FETCH ();
1131   FETCH_OFFSET (offset);
1132   mvra = ip + offset;
1133
1134  vm_mv_call:
1135   program = sp[-nargs];
1136
1137   VM_HANDLE_INTERRUPTS;
1138
1139   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
1140     {
1141       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
1142         {
1143           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
1144           goto vm_mv_call;
1145         }
1146       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
1147                && SCM_SMOB_APPLICABLE_P (program))
1148         {
1149           SYNC_REGISTER ();
1150           sp[-nargs] = scm_i_smob_apply_trampoline (program);
1151           goto vm_mv_call;
1152         }
1153       else
1154         goto vm_error_wrong_type_apply;
1155     }
1156
1157   CACHE_PROGRAM ();
1158
1159   {
1160     SCM *old_fp = fp;
1161
1162     fp = sp - nargs + 1;
1163
1164     ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
1165     ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
1166     ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
1167     SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
1168     SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
1169     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
1170   }
1171
1172   ip = SCM_C_OBJCODE_BASE (bp);
1173   PUSH_CONTINUATION_HOOK ();
1174   APPLY_HOOK ();
1175   NEXT;
1176 }
1177
1178 VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
1179 {
1180   int len;
1181   SCM ls;
1182   POP (ls);
1183
1184   nargs = FETCH ();
1185   ASSERT (nargs >= 2);
1186
1187   len = scm_ilength (ls);
1188   if (SCM_UNLIKELY (len < 0))
1189     {
1190       finish_args = ls;
1191       goto vm_error_apply_to_non_list;
1192     }
1193
1194   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1195   DEAD (ls);
1196
1197   nargs += len - 2;
1198   goto vm_call;
1199 }
1200
1201 VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
1202 {
1203   int len;
1204   SCM ls;
1205   POP (ls);
1206
1207   nargs = FETCH ();
1208   ASSERT (nargs >= 2);
1209
1210   len = scm_ilength (ls);
1211   if (SCM_UNLIKELY (len < 0))
1212     {
1213       finish_args = ls;
1214       goto vm_error_apply_to_non_list;
1215     }
1216
1217   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1218   DEAD (ls);
1219
1220   nargs += len - 2;
1221   goto vm_tail_call;
1222 }
1223
1224 VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
1225 {
1226   int first;
1227   SCM proc, vm_cont, cont;
1228   POP (proc);
1229   SYNC_ALL ();
1230   vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
1231   cont = scm_i_make_continuation (&first, vm, vm_cont);
1232   DEAD (vm_cont);
1233   if (first)
1234     {
1235       PUSH (SCM_PACK (0)); /* dynamic link */
1236       PUSH (SCM_PACK (0));  /* mvra */
1237       PUSH (SCM_PACK (0));  /* ra */
1238       PUSH (proc);
1239       DEAD (proc);
1240       PUSH (cont);
1241       DEAD (cont);
1242       nargs = 1;
1243       goto vm_call;
1244     }
1245   else
1246     {
1247       /* Otherwise, the vm continuation was reinstated, and
1248          vm_return_to_continuation pushed on one value. We know only one
1249          value was returned because we are in value context -- the
1250          previous block jumped to vm_call, not vm_mv_call, after all.
1251
1252          So, pull our regs back down from the vp, and march on to the
1253          next instruction. */
1254       DEAD (proc);
1255       DEAD (cont);
1256       CACHE_REGISTER ();
1257       program = SCM_FRAME_PROGRAM (fp);
1258       CACHE_PROGRAM ();
1259       RESTORE_CONTINUATION_HOOK ();
1260       NEXT;
1261     }
1262 }
1263
1264 VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
1265 {
1266   int first;
1267   SCM proc, vm_cont, cont;
1268   POP (proc);
1269   SYNC_ALL ();
1270   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1271      stack frame. */
1272   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1273                                     SCM_FRAME_DYNAMIC_LINK (fp),
1274                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1275                                     SCM_FRAME_RETURN_ADDRESS (fp),
1276                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1277                                     0);
1278   cont = scm_i_make_continuation (&first, vm, vm_cont);
1279   DEAD (vm_cont);
1280   if (first)
1281     {
1282       PUSH (proc);
1283       DEAD (proc);
1284       PUSH (cont);
1285       DEAD (cont);
1286       nargs = 1;
1287       goto vm_tail_call;
1288     }
1289   else
1290     {
1291       DEAD (proc);
1292       DEAD (cont);
1293       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1294          does a return from the frame, either to the RA or
1295          MVRA. */
1296       CACHE_REGISTER ();
1297       program = SCM_FRAME_PROGRAM (fp);
1298       CACHE_PROGRAM ();
1299       /* Unfortunately we don't know whether we are at the RA, and thus
1300          have one value without an nvalues marker, or we are at the
1301          MVRA and thus have multiple values and the nvalues
1302          marker. Instead of adding heuristics here, we will let hook
1303          client code do that. */
1304       RESTORE_CONTINUATION_HOOK ();
1305       NEXT;
1306     }
1307 }
1308
1309 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1310 {
1311  vm_return:
1312   POP_CONTINUATION_HOOK (1);
1313
1314   VM_HANDLE_INTERRUPTS;
1315
1316   {
1317     SCM ret;
1318
1319     POP (ret);
1320
1321 #ifdef VM_ENABLE_STACK_NULLING
1322     SCM *old_sp = sp;
1323 #endif
1324
1325     /* Restore registers */
1326     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1327     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1328     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1329
1330 #ifdef VM_ENABLE_STACK_NULLING
1331     NULLSTACK (old_sp - sp);
1332 #endif
1333
1334     /* Set return value (sp is already pushed) */
1335     *sp = ret;
1336
1337     DEAD (ret);
1338   }
1339
1340   /* Restore the last program */
1341   program = SCM_FRAME_PROGRAM (fp);
1342   CACHE_PROGRAM ();
1343   CHECK_IP ();
1344   NEXT;
1345 }
1346
1347 VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
1348 {
1349   /* nvalues declared at top level, because for some reason gcc seems to think
1350      that perhaps it might be used without declaration. Fooey to that, I say. */
1351   nvalues = FETCH ();
1352  vm_return_values:
1353   POP_CONTINUATION_HOOK (nvalues);
1354
1355   VM_HANDLE_INTERRUPTS;
1356
1357   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1358     {
1359       /* A multiply-valued continuation */
1360       SCM *vals = sp - nvalues;
1361       int i;
1362       /* Restore registers */
1363       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1364       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1365       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1366
1367       /* Push return values, and the number of values */
1368       for (i = 0; i < nvalues; i++)
1369         *++sp = vals[i+1];
1370       *++sp = SCM_I_MAKINUM (nvalues);
1371
1372       /* Finally null the end of the stack */
1373       NULLSTACK (vals + nvalues - sp);
1374     }
1375   else if (nvalues >= 1)
1376     {
1377       /* Multiple values for a single-valued continuation -- here's where I
1378          break with guile tradition and try and do something sensible. (Also,
1379          this block handles the single-valued return to an mv
1380          continuation.) */
1381       SCM *vals = sp - nvalues;
1382       /* Restore registers */
1383       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1384       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1385       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1386
1387       /* Push first value */
1388       *++sp = vals[1];
1389
1390       /* Finally null the end of the stack */
1391       NULLSTACK (vals + nvalues - sp);
1392     }
1393   else
1394     goto vm_error_no_values;
1395
1396   /* Restore the last program */
1397   program = SCM_FRAME_PROGRAM (fp);
1398   CACHE_PROGRAM ();
1399   CHECK_IP ();
1400   NEXT;
1401 }
1402
1403 VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
1404 {
1405   SCM l;
1406
1407   nvalues = FETCH ();
1408   ASSERT (nvalues >= 1);
1409
1410   nvalues--;
1411   POP (l);
1412   while (scm_is_pair (l))
1413     {
1414       PUSH (SCM_CAR (l));
1415       l = SCM_CDR (l);
1416       nvalues++;
1417     }
1418   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1419     finish_args = scm_list_1 (l);
1420     goto vm_error_improper_list;
1421   }
1422
1423   DEAD (l);
1424   goto vm_return_values;
1425 }
1426
1427 VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
1428 {
1429   SCM n;
1430   POP (n);
1431   nvalues = scm_to_int (n);
1432   DEAD (n);
1433   ASSERT (nvalues >= 0);
1434   goto vm_return_values;
1435 }
1436
1437 VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
1438 {
1439   SCM x;
1440   int nbinds, rest;
1441   POP (x);
1442   nvalues = scm_to_int (x);
1443   DEAD (x);
1444   nbinds = FETCH ();
1445   rest = FETCH ();
1446
1447   if (rest)
1448     nbinds--;
1449
1450   if (nvalues < nbinds)
1451     goto vm_error_not_enough_values;
1452
1453   if (rest)
1454     POP_LIST (nvalues - nbinds);
1455   else
1456     DROPN (nvalues - nbinds);
1457
1458   NEXT;
1459 }
1460
1461 VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
1462 {
1463   SCM val;
1464   POP (val);
1465   SYNC_BEFORE_GC ();
1466   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1467   DEAD (val);
1468   NEXT;
1469 }
1470
1471 /* for letrec:
1472    (let ((a *undef*) (b *undef*) ...)
1473      (set! a (lambda () (b ...)))
1474      ...)
1475  */
1476 VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
1477 {
1478   SYNC_BEFORE_GC ();
1479   LOCAL_SET (FETCH (),
1480              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1481   NEXT;
1482 }
1483
1484 VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1485 {
1486   SCM v = LOCAL_REF (FETCH ());
1487   ASSERT_BOUND_VARIABLE (v);
1488   PUSH (VARIABLE_REF (v));
1489   DEAD (v);
1490   NEXT;
1491 }
1492
1493 VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
1494 {
1495   SCM v, val;
1496   v = LOCAL_REF (FETCH ());
1497   POP (val);
1498   ASSERT_VARIABLE (v);
1499   VARIABLE_SET (v, val);
1500   DEAD (v);
1501   DEAD (val);
1502   NEXT;
1503 }
1504
1505 VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
1506 {
1507   scm_t_uint8 idx = FETCH ();
1508
1509   CHECK_FREE_VARIABLE (idx);
1510   PUSH (FREE_VARIABLE_REF (idx));
1511   NEXT;
1512 }
1513
1514 /* no free-set -- if a var is assigned, it should be in a box */
1515
1516 VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1517 {
1518   SCM v;
1519   scm_t_uint8 idx = FETCH ();
1520   CHECK_FREE_VARIABLE (idx);
1521   v = FREE_VARIABLE_REF (idx);
1522   ASSERT_BOUND_VARIABLE (v);
1523   PUSH (VARIABLE_REF (v));
1524   DEAD (v);
1525   NEXT;
1526 }
1527
1528 VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
1529 {
1530   SCM v, val;
1531   scm_t_uint8 idx = FETCH ();
1532   POP (val);
1533   CHECK_FREE_VARIABLE (idx);
1534   v = FREE_VARIABLE_REF (idx);
1535   ASSERT_BOUND_VARIABLE (v);
1536   VARIABLE_SET (v, val);
1537   DEAD (v);
1538   DEAD (val);
1539   NEXT;
1540 }
1541
1542 VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
1543 {
1544   size_t n, len;
1545   SCM closure;
1546
1547   len = FETCH ();
1548   len <<= 8;
1549   len += FETCH ();
1550   SYNC_BEFORE_GC ();
1551   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1552   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1553   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1554   sp[-len] = closure;
1555   for (n = 0; n < len; n++)
1556     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1557   DEAD (closure);
1558   DROPN (len);
1559   NEXT;
1560 }
1561
1562 VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
1563 {
1564   SYNC_BEFORE_GC ();
1565   /* fixme underflow */
1566   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1567   NEXT;
1568 }
1569
1570 VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
1571 {
1572   SCM x;
1573   unsigned int i = FETCH ();
1574   size_t n, len;
1575   i <<= 8;
1576   i += FETCH ();
1577   /* FIXME CHECK_LOCAL (i) */
1578   x = LOCAL_REF (i);
1579   /* FIXME ASSERT_PROGRAM (x); */
1580   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1581   for (n = 0; n < len; n++)
1582     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1583   DEAD (x);
1584   DROPN (len);
1585   NEXT;
1586 }
1587
1588 VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
1589 {
1590   SCM sym, val;
1591   POP2 (sym, val);
1592   SYNC_REGISTER ();
1593   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1594                              SCM_BOOL_T),
1595                 val);
1596   DEAD (sym);
1597   DEAD (val);
1598   NEXT;
1599 }
1600
1601 VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
1602 {
1603   CHECK_UNDERFLOW ();
1604   SYNC_REGISTER ();
1605   *sp = scm_symbol_to_keyword (*sp);
1606   NEXT;
1607 }
1608
1609 VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
1610 {
1611   CHECK_UNDERFLOW ();
1612   SYNC_REGISTER ();
1613   *sp = scm_string_to_symbol (*sp);
1614   NEXT;
1615 }
1616
1617 VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
1618 {
1619   scm_t_int32 offset;
1620   scm_t_uint8 escape_only_p;
1621   SCM k, prompt;
1622
1623   escape_only_p = FETCH ();
1624   FETCH_OFFSET (offset);
1625   POP (k);
1626
1627   SYNC_REGISTER ();
1628   /* Push the prompt onto the dynamic stack. */
1629   prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
1630                               scm_i_dynwinds ());
1631   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
1632   if (SCM_PROMPT_SETJMP (prompt))
1633     {
1634       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1635          to the handler.
1636
1637          Note, at this point, we must assume that any variable local to
1638          vm_engine that can be assigned *has* been assigned. So we need to pull
1639          all our state back from the ip/fp/sp.
1640       */
1641       DEAD (k);
1642       DEAD (prompt);
1643       CACHE_REGISTER ();
1644       program = SCM_FRAME_PROGRAM (fp);
1645       CACHE_PROGRAM ();
1646       /* The stack contains the values returned to this prompt, along
1647          with a number-of-values marker -- like an MV return. */
1648       ABORT_CONTINUATION_HOOK ();
1649       NEXT;
1650     }
1651
1652   DEAD (k);
1653   DEAD (prompt);
1654
1655   /* Otherwise setjmp returned for the first time, so we go to execute the
1656      prompt's body. */
1657   NEXT;
1658 }
1659
1660 VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
1661 {
1662   SCM wind, unwind;
1663   POP2 (unwind, wind);
1664   SYNC_REGISTER ();
1665   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1666      are actually called; the compiler should emit calls to wind and unwind for
1667      the normal dynamic-wind control flow. */
1668   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
1669     {
1670       finish_args = wind;
1671       goto vm_error_not_a_thunk;
1672     }
1673   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
1674     {
1675       finish_args = unwind;
1676       goto vm_error_not_a_thunk;
1677     }
1678   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
1679   DEAD (wind);
1680   DEAD (unwind);
1681   NEXT;
1682 }
1683
1684 VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
1685 {
1686   unsigned n = FETCH ();
1687   SYNC_REGISTER ();
1688   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
1689     goto vm_error_stack_underflow;
1690   vm_abort (vm, n, vm_cookie);
1691   /* vm_abort should not return */
1692   abort ();
1693 }
1694
1695 VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
1696 {
1697   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1698      off of the dynamic stack. */
1699   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1700   NEXT;
1701 }
1702
1703 VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
1704 {
1705   unsigned n = FETCH ();
1706   SCM wf;
1707
1708   SYNC_REGISTER ();
1709   sp -= 2 * n;
1710   CHECK_UNDERFLOW ();
1711   wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
1712   NULLSTACK (2 * n);
1713
1714   scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
1715   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
1716   DEAD (wf);
1717   NEXT;
1718 }
1719
1720 VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
1721 {
1722   SCM wf;
1723   wf = scm_car (scm_i_dynwinds ());
1724   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1725   scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
1726   DEAD (wf);
1727   NEXT;
1728 }
1729
1730 VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
1731 {
1732   size_t num;
1733   SCM fluids;
1734
1735   CHECK_UNDERFLOW ();
1736   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1737   if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
1738       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1739     {
1740       /* Punt dynstate expansion and error handling to the C proc. */
1741       DEAD (fluids);
1742       SYNC_REGISTER ();
1743       *sp = scm_fluid_ref (*sp);
1744     }
1745   else
1746     {
1747       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
1748       DEAD (fluids);
1749       if (scm_is_eq (val, SCM_UNDEFINED))
1750         val = SCM_I_FLUID_DEFAULT (*sp);
1751       if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
1752         {
1753           finish_args = *sp;
1754           goto vm_error_unbound_fluid;
1755         }
1756       *sp = val;
1757     }
1758
1759   NEXT;
1760 }
1761
1762 VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
1763 {
1764   size_t num;
1765   SCM val, fluid, fluids;
1766
1767   POP2 (val, fluid);
1768   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1769   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
1770       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1771     {
1772       /* Punt dynstate expansion and error handling to the C proc. */
1773       SYNC_REGISTER ();
1774       scm_fluid_set_x (fluid, val);
1775     }
1776   else
1777     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1778   DEAD (fluids);
1779   DEAD (fluid);
1780   DEAD (val);
1781   NEXT;
1782 }
1783
1784 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1785 {
1786   scm_t_ptrdiff n;
1787   SCM *old_sp;
1788
1789   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1790   n = FETCH ();
1791
1792   if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
1793     goto vm_error_wrong_num_args;
1794
1795   old_sp = sp;
1796   sp += (n >> 3);
1797   CHECK_OVERFLOW ();
1798   while (old_sp < sp)
1799     *++old_sp = SCM_UNDEFINED;
1800
1801   NEXT;
1802 }
1803
1804
1805 /*
1806 (defun renumber-ops ()
1807   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1808   (interactive "")
1809   (save-excursion
1810     (let ((counter -1)) (goto-char (point-min))
1811       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1812         (replace-match
1813          (number-to-string (setq counter (1+ counter)))
1814           t t nil 1)))))
1815 (renumber-ops)
1816 */
1817 /*
1818   Local Variables:
1819   c-file-style: "gnu"
1820   End:
1821 */