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