libguile/vm-i-system.c

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