libguile/vm-i-system.c

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