libguile/vm-i-system.c

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