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 (SCM_UNLIKELY (len < 0))
1098     {
1099       finish_args = ls;
1100       goto vm_error_apply_to_non_list;
1101     }
1102
1103   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1104
1105   nargs += len - 2;
1106   goto vm_call;
1107 }
1108
1109 VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
1110 {
1111   int len;
1112   SCM ls;
1113   POP (ls);
1114
1115   nargs = FETCH ();
1116   ASSERT (nargs >= 2);
1117
1118   len = scm_ilength (ls);
1119   if (SCM_UNLIKELY (len < 0))
1120     {
1121       finish_args = ls;
1122       goto vm_error_apply_to_non_list;
1123     }
1124
1125   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1126
1127   nargs += len - 2;
1128   goto vm_tail_call;
1129 }
1130
1131 VM_DEFINE_INSTRUCTION (64, call_cc, "call/cc", 0, 1, 1)
1132 {
1133   int first;
1134   SCM proc, vm_cont, cont;
1135   POP (proc);
1136   SYNC_ALL ();
1137   vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
1138   cont = scm_i_make_continuation (&first, vm, vm_cont);
1139   if (first)
1140     {
1141       PUSH ((SCM)fp); /* dynamic link */
1142       PUSH (0);  /* mvra */
1143       PUSH (0);  /* ra */
1144       PUSH (proc);
1145       PUSH (cont);
1146       nargs = 1;
1147       goto vm_call;
1148     }
1149   else
1150     {
1151       /* otherwise, the vm continuation was reinstated, and
1152          scm_i_vm_return_to_continuation pushed on one value. So pull our regs
1153          back down from the vp, and march on to the next instruction. */
1154       CACHE_REGISTER ();
1155       program = SCM_FRAME_PROGRAM (fp);
1156       CACHE_PROGRAM ();
1157       NEXT;
1158     }
1159 }
1160
1161 VM_DEFINE_INSTRUCTION (65, tail_call_cc, "tail-call/cc", 0, 1, 1)
1162 {
1163   int first;
1164   SCM proc, vm_cont, cont;
1165   POP (proc);
1166   SYNC_ALL ();
1167   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1168      stack frame. */
1169   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1170                                     SCM_FRAME_DYNAMIC_LINK (fp),
1171                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1172                                     SCM_FRAME_RETURN_ADDRESS (fp),
1173                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1174                                     0);
1175   cont = scm_i_make_continuation (&first, vm, vm_cont);
1176   if (first)
1177     {
1178       PUSH (proc);
1179       PUSH (cont);
1180       nargs = 1;
1181       goto vm_tail_call;
1182     }
1183   else
1184     {
1185       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1186          does a return from the frame, either to the RA or MVRA. */
1187       CACHE_REGISTER ();
1188       program = SCM_FRAME_PROGRAM (fp);
1189       CACHE_PROGRAM ();
1190       NEXT;
1191     }
1192 }
1193
1194 VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
1195 {
1196  vm_return:
1197   EXIT_HOOK ();
1198   RETURN_HOOK (1);
1199
1200   VM_HANDLE_INTERRUPTS;
1201
1202   {
1203     SCM ret;
1204
1205     POP (ret);
1206
1207 #ifdef VM_ENABLE_STACK_NULLING
1208     SCM *old_sp = sp;
1209 #endif
1210
1211     /* Restore registers */
1212     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1213     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1214     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1215
1216 #ifdef VM_ENABLE_STACK_NULLING
1217     NULLSTACK (old_sp - sp);
1218 #endif
1219
1220     /* Set return value (sp is already pushed) */
1221     *sp = ret;
1222   }
1223
1224   /* Restore the last program */
1225   program = SCM_FRAME_PROGRAM (fp);
1226   CACHE_PROGRAM ();
1227   CHECK_IP ();
1228   NEXT;
1229 }
1230
1231 VM_DEFINE_INSTRUCTION (67, return_values, "return/values", 1, -1, -1)
1232 {
1233   /* nvalues declared at top level, because for some reason gcc seems to think
1234      that perhaps it might be used without declaration. Fooey to that, I say. */
1235   nvalues = FETCH ();
1236  vm_return_values:
1237   EXIT_HOOK ();
1238   RETURN_HOOK (nvalues);
1239
1240   VM_HANDLE_INTERRUPTS;
1241
1242   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1243     {
1244       /* A multiply-valued continuation */
1245       SCM *vals = sp - nvalues;
1246       int i;
1247       /* Restore registers */
1248       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1249       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1250       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1251
1252       /* Push return values, and the number of values */
1253       for (i = 0; i < nvalues; i++)
1254         *++sp = vals[i+1];
1255       *++sp = SCM_I_MAKINUM (nvalues);
1256
1257       /* Finally null the end of the stack */
1258       NULLSTACK (vals + nvalues - sp);
1259     }
1260   else if (nvalues >= 1)
1261     {
1262       /* Multiple values for a single-valued continuation -- here's where I
1263          break with guile tradition and try and do something sensible. (Also,
1264          this block handles the single-valued return to an mv
1265          continuation.) */
1266       SCM *vals = sp - nvalues;
1267       /* Restore registers */
1268       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1269       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1270       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1271
1272       /* Push first value */
1273       *++sp = vals[1];
1274
1275       /* Finally null the end of the stack */
1276       NULLSTACK (vals + nvalues - sp);
1277     }
1278   else
1279     goto vm_error_no_values;
1280
1281   /* Restore the last program */
1282   program = SCM_FRAME_PROGRAM (fp);
1283   CACHE_PROGRAM ();
1284   CHECK_IP ();
1285   NEXT;
1286 }
1287
1288 VM_DEFINE_INSTRUCTION (68, return_values_star, "return/values*", 1, -1, -1)
1289 {
1290   SCM l;
1291
1292   nvalues = FETCH ();
1293   ASSERT (nvalues >= 1);
1294
1295   nvalues--;
1296   POP (l);
1297   while (scm_is_pair (l))
1298     {
1299       PUSH (SCM_CAR (l));
1300       l = SCM_CDR (l);
1301       nvalues++;
1302     }
1303   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1304     finish_args = scm_list_1 (l);
1305     goto vm_error_improper_list;
1306   }
1307
1308   goto vm_return_values;
1309 }
1310
1311 VM_DEFINE_INSTRUCTION (88, return_nvalues, "return/nvalues", 0, 1, -1)
1312 {
1313   SCM n;
1314   POP (n);
1315   nvalues = scm_to_int (n);
1316   ASSERT (nvalues >= 0);
1317   goto vm_return_values;
1318 }
1319
1320 VM_DEFINE_INSTRUCTION (69, truncate_values, "truncate-values", 2, -1, -1)
1321 {
1322   SCM x;
1323   int nbinds, rest;
1324   POP (x);
1325   nvalues = scm_to_int (x);
1326   nbinds = FETCH ();
1327   rest = FETCH ();
1328
1329   if (rest)
1330     nbinds--;
1331
1332   if (nvalues < nbinds)
1333     goto vm_error_not_enough_values;
1334
1335   if (rest)
1336     POP_LIST (nvalues - nbinds);
1337   else
1338     DROPN (nvalues - nbinds);
1339
1340   NEXT;
1341 }
1342
1343 VM_DEFINE_INSTRUCTION (70, box, "box", 1, 1, 0)
1344 {
1345   SCM val;
1346   POP (val);
1347   SYNC_BEFORE_GC ();
1348   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1349   NEXT;
1350 }
1351
1352 /* for letrec:
1353    (let ((a *undef*) (b *undef*) ...)
1354      (set! a (lambda () (b ...)))
1355      ...)
1356  */
1357 VM_DEFINE_INSTRUCTION (71, empty_box, "empty-box", 1, 0, 0)
1358 {
1359   SYNC_BEFORE_GC ();
1360   LOCAL_SET (FETCH (),
1361              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1362   NEXT;
1363 }
1364
1365 VM_DEFINE_INSTRUCTION (72, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1366 {
1367   SCM v = LOCAL_REF (FETCH ());
1368   ASSERT_BOUND_VARIABLE (v);
1369   PUSH (VARIABLE_REF (v));
1370   NEXT;
1371 }
1372
1373 VM_DEFINE_INSTRUCTION (73, local_boxed_set, "local-boxed-set", 1, 1, 0)
1374 {
1375   SCM v, val;
1376   v = LOCAL_REF (FETCH ());
1377   POP (val);
1378   ASSERT_VARIABLE (v);
1379   VARIABLE_SET (v, val);
1380   NEXT;
1381 }
1382
1383 VM_DEFINE_INSTRUCTION (74, free_ref, "free-ref", 1, 0, 1)
1384 {
1385   scm_t_uint8 idx = FETCH ();
1386
1387   CHECK_FREE_VARIABLE (idx);
1388   PUSH (FREE_VARIABLE_REF (idx));
1389   NEXT;
1390 }
1391
1392 /* no free-set -- if a var is assigned, it should be in a box */
1393
1394 VM_DEFINE_INSTRUCTION (75, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1395 {
1396   SCM v;
1397   scm_t_uint8 idx = FETCH ();
1398   CHECK_FREE_VARIABLE (idx);
1399   v = FREE_VARIABLE_REF (idx);
1400   ASSERT_BOUND_VARIABLE (v);
1401   PUSH (VARIABLE_REF (v));
1402   NEXT;
1403 }
1404
1405 VM_DEFINE_INSTRUCTION (76, free_boxed_set, "free-boxed-set", 1, 1, 0)
1406 {
1407   SCM v, val;
1408   scm_t_uint8 idx = FETCH ();
1409   POP (val);
1410   CHECK_FREE_VARIABLE (idx);
1411   v = FREE_VARIABLE_REF (idx);
1412   ASSERT_BOUND_VARIABLE (v);
1413   VARIABLE_SET (v, val);
1414   NEXT;
1415 }
1416
1417 VM_DEFINE_INSTRUCTION (77, make_closure, "make-closure", 2, -1, 1)
1418 {
1419   size_t n, len;
1420   SCM closure;
1421
1422   len = FETCH ();
1423   len <<= 8;
1424   len += FETCH ();
1425   SYNC_BEFORE_GC ();
1426   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1427   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1428   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1429   sp[-len] = closure;
1430   for (n = 0; n < len; n++)
1431     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1432   DROPN (len);
1433   NEXT;
1434 }
1435
1436 VM_DEFINE_INSTRUCTION (78, make_variable, "make-variable", 0, 0, 1)
1437 {
1438   SYNC_BEFORE_GC ();
1439   /* fixme underflow */
1440   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1441   NEXT;
1442 }
1443
1444 VM_DEFINE_INSTRUCTION (79, fix_closure, "fix-closure", 2, -1, 0)
1445 {
1446   SCM x;
1447   unsigned int i = FETCH ();
1448   size_t n, len;
1449   i <<= 8;
1450   i += FETCH ();
1451   /* FIXME CHECK_LOCAL (i) */
1452   x = LOCAL_REF (i);
1453   /* FIXME ASSERT_PROGRAM (x); */
1454   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1455   for (n = 0; n < len; n++)
1456     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1457   DROPN (len);
1458   NEXT;
1459 }
1460
1461 VM_DEFINE_INSTRUCTION (80, define, "define", 0, 0, 2)
1462 {
1463   SCM sym, val;
1464   POP (sym);
1465   POP (val);
1466   SYNC_REGISTER ();
1467   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1468                              SCM_BOOL_T),
1469                 val);
1470   NEXT;
1471 }
1472
1473 VM_DEFINE_INSTRUCTION (81, make_keyword, "make-keyword", 0, 1, 1)
1474 {
1475   CHECK_UNDERFLOW ();
1476   SYNC_REGISTER ();
1477   *sp = scm_symbol_to_keyword (*sp);
1478   NEXT;
1479 }
1480
1481 VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 0, 1, 1)
1482 {
1483   CHECK_UNDERFLOW ();
1484   SYNC_REGISTER ();
1485   *sp = scm_string_to_symbol (*sp);
1486   NEXT;
1487 }
1488
1489 VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
1490 {
1491   scm_t_int32 offset;
1492   scm_t_uint8 escape_only_p;
1493   SCM k, prompt;
1494
1495   escape_only_p = FETCH ();
1496   FETCH_OFFSET (offset);
1497   POP (k);
1498
1499   SYNC_REGISTER ();
1500   /* Push the prompt onto the dynamic stack. */
1501   prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
1502                               scm_i_dynwinds ());
1503   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
1504   if (SCM_PROMPT_SETJMP (prompt))
1505     {
1506       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1507          to the handler.
1508
1509          Note, at this point, we must assume that any variable local to
1510          vm_engine that can be assigned *has* been assigned. So we need to pull
1511          all our state back from the ip/fp/sp.
1512       */
1513       CACHE_REGISTER ();
1514       program = SCM_FRAME_PROGRAM (fp);
1515       CACHE_PROGRAM ();
1516       NEXT;
1517     }
1518
1519   /* Otherwise setjmp returned for the first time, so we go to execute the
1520      prompt's body. */
1521   NEXT;
1522 }
1523
1524 VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
1525 {
1526   SCM wind, unwind;
1527   POP (unwind);
1528   POP (wind);
1529   SYNC_REGISTER ();
1530   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1531      are actually called; the compiler should emit calls to wind and unwind for
1532      the normal dynamic-wind control flow. */
1533   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
1534     {
1535       finish_args = wind;
1536       goto vm_error_not_a_thunk;
1537     }
1538   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
1539     {
1540       finish_args = unwind;
1541       goto vm_error_not_a_thunk;
1542     }
1543   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
1544   NEXT;
1545 }
1546
1547 VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
1548 {
1549   unsigned n = FETCH ();
1550   SYNC_REGISTER ();
1551   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
1552     goto vm_error_stack_underflow;
1553   vm_abort (vm, n, vm_cookie);
1554   /* vm_abort should not return */
1555   abort ();
1556 }
1557
1558 VM_DEFINE_INSTRUCTION (87, unwind, "unwind", 0, 0, 0)
1559 {
1560   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1561      off of the dynamic stack. */
1562   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1563   NEXT;
1564 }
1565
1566 VM_DEFINE_INSTRUCTION (90, wind_fluids, "wind-fluids", 1, -1, 0)
1567 {
1568   unsigned n = FETCH ();
1569   SCM wf;
1570
1571   if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp))
1572     goto vm_error_stack_underflow;
1573
1574   SYNC_REGISTER ();
1575   wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n);
1576   scm_i_swap_with_fluids (wf, dynstate);
1577   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
1578   NEXT;
1579 }
1580
1581 VM_DEFINE_INSTRUCTION (91, unwind_fluids, "unwind-fluids", 0, 0, 0)
1582 {
1583   SCM wf;
1584   wf = scm_car (scm_i_dynwinds ());
1585   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1586   scm_i_swap_with_fluids (wf, dynstate);
1587   NEXT;
1588 }
1589
1590 VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1)
1591 {
1592   size_t num;
1593   SCM fluids;
1594
1595   CHECK_UNDERFLOW ();
1596   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1597   if (SCM_UNLIKELY (!SCM_I_FLUID_P (*sp))
1598       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1599     {
1600       /* Punt dynstate expansion and error handling to the C proc. */
1601       SYNC_REGISTER ();
1602       *sp = scm_fluid_ref (*sp);
1603     }
1604   else
1605     *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
1606
1607   NEXT;
1608 }
1609
1610 VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2, 0)
1611 {
1612   size_t num;
1613   SCM val, fluid, fluids;
1614
1615   POP (val);
1616   POP (fluid);
1617   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1618   if (SCM_UNLIKELY (!SCM_I_FLUID_P (fluid))
1619       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1620     {
1621       /* Punt dynstate expansion and error handling to the C proc. */
1622       SYNC_REGISTER ();
1623       scm_fluid_set_x (fluid, val);
1624     }
1625   else
1626     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1627
1628   NEXT;
1629 }
1630
1631 VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1632 {
1633   scm_t_ptrdiff n;
1634   SCM *old_sp;
1635
1636   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1637   n = FETCH ();
1638
1639   if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
1640     goto vm_error_wrong_num_args;
1641
1642   old_sp = sp;
1643   sp += (n >> 3);
1644   CHECK_OVERFLOW ();
1645   while (old_sp < sp)
1646     *++old_sp = SCM_UNDEFINED;
1647
1648   NEXT;
1649 }
1650
1651
1652 /*
1653 (defun renumber-ops ()
1654   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1655   (interactive "")
1656   (save-excursion
1657     (let ((counter -1)) (goto-char (point-min))
1658       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1659         (replace-match
1660          (number-to-string (setq counter (1+ counter)))
1661           t t nil 1)))))
1662 (renumber-ops)
1663 */
1664 /*
1665   Local Variables:
1666   c-file-style: "gnu"
1667   End:
1668 */