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
 542 #undef BR
 543
 544 \f
 545 /*
 546  * Subprogram call
 547  */
 548
 549 VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
 550 {
 551   scm_t_ptrdiff n;
 552   scm_t_int32 offset;
 553   n = FETCH () << 8;
 554   n += FETCH ();
 555   FETCH_OFFSET (offset);
 556   if (sp - (fp - 1) != n)
 557     ip += offset;
 558   NEXT;
 559 }
 560
 561 VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
 562 {
 563   scm_t_ptrdiff n;
 564   scm_t_int32 offset;
 565   n = FETCH () << 8;
 566   n += FETCH ();
 567   FETCH_OFFSET (offset);
 568   if (sp - (fp - 1) < n)
 569     ip += offset;
 570   NEXT;
 571 }
 572
 573 VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
 574 {
 575   scm_t_ptrdiff n;
 576   scm_t_int32 offset;
 577
 578   n = FETCH () << 8;
 579   n += FETCH ();
 580   FETCH_OFFSET (offset);
 581   if (sp - (fp - 1) > n)
 582     ip += offset;
 583   NEXT;
 584 }
 585
 586 VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
 587 {
 588   scm_t_ptrdiff n;
 589   n = FETCH () << 8;
 590   n += FETCH ();
 591   VM_ASSERT (sp - (fp - 1) == n,
 592              vm_error_wrong_num_args (program));
 593   NEXT;
 594 }
 595
 596 VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
 597 {
 598   scm_t_ptrdiff n;
 599   n = FETCH () << 8;
 600   n += FETCH ();
 601   VM_ASSERT (sp - (fp - 1) >= n,
 602              vm_error_wrong_num_args (program));
 603   NEXT;
 604 }
 605
 606 VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1)
 607 {
 608   scm_t_ptrdiff n;
 609   n = FETCH () << 8;
 610   n += FETCH ();
 611   while (sp - (fp - 1) < n)
 612     PUSH (SCM_UNDEFINED);
 613   NEXT;
 614 }
 615
 616 VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
 617 {
 618   SCM *walk;
 619   scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
 620   nreq = FETCH () << 8;
 621   nreq += FETCH ();
 622   nreq_and_opt = FETCH () << 8;
 623   nreq_and_opt += FETCH ();
 624   ntotal = FETCH () << 8;
 625   ntotal += FETCH ();
 626
 627   /* look in optionals for first keyword or last positional */
 628   /* starting after the last required positional arg */
 629   walk = fp + nreq;
 630   while (/* while we have args */
 631          walk <= sp
 632          /* and we still have positionals to fill */
 633          && walk - fp < nreq_and_opt
 634          /* and we haven't reached a keyword yet */
 635          && !scm_is_keyword (*walk))
 636     /* bind this optional arg (by leaving it in place) */
 637     walk++;
 638   /* now shuffle up, from walk to ntotal */
 639   {
 640     scm_t_ptrdiff nshuf = sp - walk + 1, i;
 641     sp = (fp - 1) + ntotal + nshuf;
 642     CHECK_OVERFLOW ();
 643     for (i = 0; i < nshuf; i++)
 644       sp[-i] = walk[nshuf-i-1];
 645   }
 646   /* and fill optionals & keyword args with SCM_UNDEFINED */
 647   while (walk <= (fp - 1) + ntotal)
 648     *walk++ = SCM_UNDEFINED;
 649
 650   NEXT;
 651 }
 652
 653 /* See also bind-optionals/shuffle-or-br below.  */
 654
 655 /* Flags that determine whether other keywords are allowed, and whether a
 656    rest argument is expected.  These values must match those used by the
 657    glil->assembly compiler.  */
 658 #define F_ALLOW_OTHER_KEYS  1
 659 #define F_REST              2
 660
 661 VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
 662 {
 663   scm_t_uint16 idx;
 664   scm_t_ptrdiff nkw;
 665   int kw_and_rest_flags;
 666   SCM kw;
 667   idx = FETCH () << 8;
 668   idx += FETCH ();
 669   /* XXX: We don't actually use NKW.  */
 670   nkw = FETCH () << 8;
 671   nkw += FETCH ();
 672   kw_and_rest_flags = FETCH ();
 673
 674   VM_ASSERT ((kw_and_rest_flags & F_REST)
 675              || ((sp - (fp - 1) - nkw) % 2) == 0,
 676              vm_error_kwargs_length_not_even (program))
 677
 678   CHECK_OBJECT (idx);
 679   kw = OBJECT_REF (idx);
 680
 681   /* Switch NKW to be a negative index below SP.  */
 682   for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
 683     {
 684       SCM walk;
 685
 686       if (scm_is_keyword (sp[nkw]))
 687         {
 688           for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
 689             {
 690               if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
 691                 {
 692                   SCM si = SCM_CDAR (walk);
 693                   LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
 694                              sp[nkw + 1]);
 695                   break;
 696                 }
 697             }
 698           VM_ASSERT (scm_is_pair (walk)
 699                      || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
 700                      vm_error_kwargs_unrecognized_keyword (program));
 701           nkw++;
 702         }
 703       else
 704         VM_ASSERT (kw_and_rest_flags & F_REST,
 705                    vm_error_kwargs_invalid_keyword (program));
 706     }
 707
 708   NEXT;
 709 }
 710
 711 #undef F_ALLOW_OTHER_KEYS
 712 #undef F_REST
 713
 714
 715 VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1)
 716 {
 717   scm_t_ptrdiff n;
 718   SCM rest = SCM_EOL;
 719   n = FETCH () << 8;
 720   n += FETCH ();
 721   SYNC_BEFORE_GC ();
 722   while (sp - (fp - 1) > n)
 723     /* No need to check for underflow. */
 724     rest = scm_cons (*sp--, rest);
 725   PUSH (rest);
 726   NEXT;
 727 }
 728
 729 VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1)
 730 {
 731   scm_t_ptrdiff n;
 732   scm_t_uint32 i;
 733   SCM rest = SCM_EOL;
 734   n = FETCH () << 8;
 735   n += FETCH ();
 736   i = FETCH () << 8;
 737   i += FETCH ();
 738   SYNC_BEFORE_GC ();
 739   while (sp - (fp - 1) > n)
 740     /* No need to check for underflow. */
 741     rest = scm_cons (*sp--, rest);
 742   LOCAL_SET (i, rest);
 743   NEXT;
 744 }
 745
 746 VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1)
 747 {
 748   SCM *old_sp;
 749   scm_t_int32 n;
 750   n = FETCH () << 8;
 751   n += FETCH ();
 752   old_sp = sp;
 753   sp = (fp - 1) + n;
 754
 755   if (old_sp < sp)
 756     {
 757       CHECK_OVERFLOW ();
 758       while (old_sp < sp)
 759         *++old_sp = SCM_UNDEFINED;
 760     }
 761   else
 762     NULLSTACK (old_sp - sp);
 763
 764   NEXT;
 765 }
 766
 767 VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3)
 768 {
 769   /* NB: if you change this, see frames.c:vm-frame-num-locals */
 770   /* and frames.h, vm-engine.c, etc of course */
 771
 772   /* We don't initialize the dynamic link here because we don't actually
 773      know that this frame will point to the current fp: it could be
 774      placed elsewhere on the stack if captured in a partial
 775      continuation, and invoked from some other context.  */
 776   PUSH (SCM_PACK (0)); /* dynamic link */
 777   PUSH (SCM_PACK (0)); /* mvra */
 778   PUSH (SCM_PACK (0)); /* ra */
 779   NEXT;
 780 }
 781
 782 VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
 783 {
 784   nargs = FETCH ();
 785
 786  vm_call:
 787   VM_HANDLE_INTERRUPTS;
 788
 789   {
 790     SCM *old_fp = fp;
 791
 792     fp = sp - nargs + 1;
 793
 794     ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
 795     ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 796     ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 797     SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
 798     SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 799     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
 800   }
 801
 802   PUSH_CONTINUATION_HOOK ();
 803
 804   program = fp[-1];
 805
 806   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 807     goto apply;
 808
 809   CACHE_PROGRAM ();
 810   ip = SCM_C_OBJCODE_BASE (bp);
 811
 812   APPLY_HOOK ();
 813   NEXT;
 814 }
 815
 816 VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
 817 {
 818   nargs = FETCH ();
 819
 820  vm_tail_call:
 821   VM_HANDLE_INTERRUPTS;
 822
 823   {
 824     int i;
 825 #ifdef VM_ENABLE_STACK_NULLING
 826     SCM *old_sp = sp;
 827     CHECK_STACK_LEAK ();
 828 #endif
 829
 830     /* shuffle down the program and the arguments */
 831     for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
 832       SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 833
 834     sp = fp + i - 1;
 835
 836     NULLSTACK (old_sp - sp);
 837   }
 838
 839   program = fp[-1];
 840
 841   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 842     goto apply;
 843
 844   CACHE_PROGRAM ();
 845   ip = SCM_C_OBJCODE_BASE (bp);
 846
 847   APPLY_HOOK ();
 848   NEXT;
 849 }
 850
 851 VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
 852 {
 853   SCM pointer, ret;
 854   SCM (*subr)();
 855
 856   nargs = FETCH ();
 857   POP (pointer);
 858
 859   subr = SCM_POINTER_VALUE (pointer);
 860
 861   VM_HANDLE_INTERRUPTS;
 862   SYNC_REGISTER ();
 863
 864   switch (nargs)
 865     {
 866     case 0:
 867       ret = subr ();
 868       break;
 869     case 1:
 870       ret = subr (sp[0]);
 871       break;
 872     case 2:
 873       ret = subr (sp[-1], sp[0]);
 874       break;
 875     case 3:
 876       ret = subr (sp[-2], sp[-1], sp[0]);
 877       break;
 878     case 4:
 879       ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
 880       break;
 881     case 5:
 882       ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 883       break;
 884     case 6:
 885       ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 886       break;
 887     case 7:
 888       ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 889       break;
 890     case 8:
 891       ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 892       break;
 893     case 9:
 894       ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 895       break;
 896     case 10:
 897       ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 898       break;
 899     default:
 900       abort ();
 901     }
 902
 903   NULLSTACK_FOR_NONLOCAL_EXIT ();
 904
 905   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 906     {
 907       /* multiple values returned to continuation */
 908       ret = scm_struct_ref (ret, SCM_INUM0);
 909       nvalues = scm_ilength (ret);
 910       PUSH_LIST (ret, scm_is_null);
 911       goto vm_return_values;
 912     }
 913   else
 914     {
 915       PUSH (ret);
 916       goto vm_return;
 917     }
 918 }
 919
 920 /* Instruction 58 used to be smob-call.  */
 921
 922 VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
 923 {
 924   SCM foreign, ret;
 925   nargs = FETCH ();
 926   POP (foreign);
 927
 928   VM_HANDLE_INTERRUPTS;
 929   SYNC_REGISTER ();
 930
 931   ret = scm_i_foreign_call (foreign, sp - nargs + 1);
 932
 933   NULLSTACK_FOR_NONLOCAL_EXIT ();
 934
 935   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 936     {
 937       /* multiple values returned to continuation */
 938       ret = scm_struct_ref (ret, SCM_INUM0);
 939       nvalues = scm_ilength (ret);
 940       PUSH_LIST (ret, scm_is_null);
 941       goto vm_return_values;
 942     }
 943   else
 944     {
 945       PUSH (ret);
 946       goto vm_return;
 947     }
 948 }
 949
 950 VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0)
 951 {
 952   SCM contregs;
 953   POP (contregs);
 954
 955   SYNC_ALL ();
 956   scm_i_check_continuation (contregs);
 957   vm_return_to_continuation (scm_i_contregs_vm (contregs),
 958                              scm_i_contregs_vm_cont (contregs),
 959                              sp - (fp - 1), fp);
 960   scm_i_reinstate_continuation (contregs);
 961
 962   /* no NEXT */
 963   abort ();
 964 }
 965
 966 VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
 967 {
 968   SCM vmcont;
 969   POP (vmcont);
 970   SYNC_REGISTER ();
 971   VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
 972              vm_error_continuation_not_rewindable (vmcont));
 973   vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
 974                                      &current_thread->dynstack,
 975                                      &registers);
 976
 977   CACHE_REGISTER ();
 978   program = SCM_FRAME_PROGRAM (fp);
 979   CACHE_PROGRAM ();
 980   NEXT;
 981 }
 982
 983 VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
 984 {
 985   SCM x;
 986   POP (x);
 987   nargs = scm_to_int (x);
 988   /* FIXME: should truncate values? */
 989   goto vm_tail_call;
 990 }
 991
 992 VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1)
 993 {
 994   SCM x;
 995   POP (x);
 996   nargs = scm_to_int (x);
 997   /* FIXME: should truncate values? */
 998   goto vm_call;
 999 }
1000
1001 VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
1002 {
1003   scm_t_int32 offset;
1004   scm_t_uint8 *mvra;
1005   SCM *old_fp = fp;
1006
1007   nargs = FETCH ();
1008   FETCH_OFFSET (offset);
1009   mvra = ip + offset;
1010
1011   VM_HANDLE_INTERRUPTS;
1012
1013   fp = sp - nargs + 1;
1014
1015   ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
1016   ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
1017   ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
1018   SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
1019   SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
1020   SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
1021
1022   PUSH_CONTINUATION_HOOK ();
1023
1024   program = fp[-1];
1025
1026   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
1027     goto apply;
1028
1029   CACHE_PROGRAM ();
1030   ip = SCM_C_OBJCODE_BASE (bp);
1031
1032   APPLY_HOOK ();
1033   NEXT;
1034 }
1035
1036 VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
1037 {
1038   int len;
1039   SCM ls;
1040   POP (ls);
1041
1042   nargs = FETCH ();
1043   ASSERT (nargs >= 2);
1044
1045   len = scm_ilength (ls);
1046   VM_ASSERT (len >= 0,
1047              vm_error_apply_to_non_list (ls));
1048   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1049
1050   nargs += len - 2;
1051   goto vm_call;
1052 }
1053
1054 VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1)
1055 {
1056   int len;
1057   SCM ls;
1058   POP (ls);
1059
1060   nargs = FETCH ();
1061   ASSERT (nargs >= 2);
1062
1063   len = scm_ilength (ls);
1064   VM_ASSERT (len >= 0,
1065              vm_error_apply_to_non_list (ls));
1066   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1067
1068   nargs += len - 2;
1069   goto vm_tail_call;
1070 }
1071
1072 VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1)
1073 {
1074   int first;
1075   SCM proc, vm_cont, cont;
1076   scm_t_dynstack *dynstack;
1077   POP (proc);
1078   SYNC_ALL ();
1079   dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
1080   vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL,
1081                                     dynstack, 0);
1082   cont = scm_i_make_continuation (&first, vm, vm_cont);
1083   if (first)
1084     {
1085       PUSH (SCM_PACK (0)); /* dynamic link */
1086       PUSH (SCM_PACK (0));  /* mvra */
1087       PUSH (SCM_PACK (0));  /* ra */
1088       PUSH (proc);
1089       PUSH (cont);
1090       nargs = 1;
1091       goto vm_call;
1092     }
1093   else
1094     {
1095       /* Otherwise, the vm continuation was reinstated, and
1096          vm_return_to_continuation pushed on one value. We know only one
1097          value was returned because we are in value context -- the
1098          previous block jumped to vm_call, not vm_mv_call, after all.
1099
1100          So, pull our regs back down from the vp, and march on to the
1101          next instruction. */
1102       CACHE_REGISTER ();
1103       program = SCM_FRAME_PROGRAM (fp);
1104       CACHE_PROGRAM ();
1105       RESTORE_CONTINUATION_HOOK ();
1106       NEXT;
1107     }
1108 }
1109
1110 VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
1111 {
1112   int first;
1113   SCM proc, vm_cont, cont;
1114   scm_t_dynstack *dynstack;
1115   POP (proc);
1116   SYNC_ALL ();
1117   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1118      stack frame. */
1119   dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
1120   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1121                                     SCM_FRAME_DYNAMIC_LINK (fp),
1122                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1123                                     SCM_FRAME_RETURN_ADDRESS (fp),
1124                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1125                                     dynstack,
1126                                     0);
1127   cont = scm_i_make_continuation (&first, vm, vm_cont);
1128   if (first)
1129     {
1130       PUSH (proc);
1131       PUSH (cont);
1132       nargs = 1;
1133       goto vm_tail_call;
1134     }
1135   else
1136     {
1137       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1138          does a return from the frame, either to the RA or
1139          MVRA. */
1140       CACHE_REGISTER ();
1141       program = SCM_FRAME_PROGRAM (fp);
1142       CACHE_PROGRAM ();
1143       /* Unfortunately we don't know whether we are at the RA, and thus
1144          have one value without an nvalues marker, or we are at the
1145          MVRA and thus have multiple values and the nvalues
1146          marker. Instead of adding heuristics here, we will let hook
1147          client code do that. */
1148       RESTORE_CONTINUATION_HOOK ();
1149       NEXT;
1150     }
1151 }
1152
1153 VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
1154 {
1155  vm_return:
1156   POP_CONTINUATION_HOOK (sp, 1);
1157
1158   VM_HANDLE_INTERRUPTS;
1159
1160   {
1161     SCM ret;
1162
1163     POP (ret);
1164
1165 #ifdef VM_ENABLE_STACK_NULLING
1166     SCM *old_sp = sp;
1167 #endif
1168
1169     /* Restore registers */
1170     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1171     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1172     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1173
1174 #ifdef VM_ENABLE_STACK_NULLING
1175     NULLSTACK (old_sp - sp);
1176 #endif
1177
1178     /* Set return value (sp is already pushed) */
1179     *sp = ret;
1180   }
1181
1182   /* Restore the last program */
1183   program = SCM_FRAME_PROGRAM (fp);
1184   CACHE_PROGRAM ();
1185   CHECK_IP ();
1186   NEXT;
1187 }
1188
1189 VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1)
1190 {
1191   /* nvalues declared at top level, because for some reason gcc seems to think
1192      that perhaps it might be used without declaration. Fooey to that, I say. */
1193   nvalues = FETCH ();
1194  vm_return_values:
1195   POP_CONTINUATION_HOOK (sp + 1 - nvalues, nvalues);
1196
1197   VM_HANDLE_INTERRUPTS;
1198
1199   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1200     {
1201       /* A multiply-valued continuation */
1202       SCM *vals = sp - nvalues;
1203       int i;
1204       /* Restore registers */
1205       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1206       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1207       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1208
1209       /* Push return values, and the number of values */
1210       for (i = 0; i < nvalues; i++)
1211         *++sp = vals[i+1];
1212       *++sp = SCM_I_MAKINUM (nvalues);
1213
1214       /* Finally null the end of the stack */
1215       NULLSTACK (vals + nvalues - sp);
1216     }
1217   else if (nvalues >= 1)
1218     {
1219       /* Multiple values for a single-valued continuation -- here's where I
1220          break with guile tradition and try and do something sensible. (Also,
1221          this block handles the single-valued return to an mv
1222          continuation.) */
1223       SCM *vals = sp - nvalues;
1224       /* Restore registers */
1225       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1226       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1227       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1228
1229       /* Push first value */
1230       *++sp = vals[1];
1231
1232       /* Finally null the end of the stack */
1233       NULLSTACK (vals + nvalues - sp);
1234     }
1235   else
1236     {
1237       SYNC_ALL ();
1238       vm_error_no_values ();
1239     }
1240
1241   /* Restore the last program */
1242   program = SCM_FRAME_PROGRAM (fp);
1243   CACHE_PROGRAM ();
1244   CHECK_IP ();
1245   NEXT;
1246 }
1247
1248 VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1)
1249 {
1250   SCM l;
1251
1252   nvalues = FETCH ();
1253   ASSERT (nvalues >= 1);
1254
1255   nvalues--;
1256   POP (l);
1257   while (scm_is_pair (l))
1258     {
1259       PUSH (SCM_CAR (l));
1260       l = SCM_CDR (l);
1261       nvalues++;
1262     }
1263   VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
1264
1265   goto vm_return_values;
1266 }
1267
1268 VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1)
1269 {
1270   SCM n;
1271   POP (n);
1272   nvalues = scm_to_int (n);
1273   ASSERT (nvalues >= 0);
1274   goto vm_return_values;
1275 }
1276
1277 VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1)
1278 {
1279   SCM x;
1280   int nbinds, rest;
1281   POP (x);
1282   nvalues = scm_to_int (x);
1283   nbinds = FETCH ();
1284   rest = FETCH ();
1285
1286   if (rest)
1287     nbinds--;
1288
1289   VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
1290
1291   if (rest)
1292     POP_LIST (nvalues - nbinds);
1293   else
1294     DROPN (nvalues - nbinds);
1295
1296   NEXT;
1297 }
1298
1299 VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
1300 {
1301   SCM val;
1302   POP (val);
1303   SYNC_BEFORE_GC ();
1304   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1305   NEXT;
1306 }
1307
1308 /* for letrec:
1309    (let ((a *undef*) (b *undef*) ...)
1310      (set! a (lambda () (b ...)))
1311      ...)
1312  */
1313 VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0)
1314 {
1315   SYNC_BEFORE_GC ();
1316   LOCAL_SET (FETCH (),
1317              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1318   NEXT;
1319 }
1320
1321 VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1322 {
1323   SCM v = LOCAL_REF (FETCH ());
1324   ASSERT_BOUND_VARIABLE (v);
1325   PUSH (VARIABLE_REF (v));
1326   NEXT;
1327 }
1328
1329 VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0)
1330 {
1331   SCM v, val;
1332   v = LOCAL_REF (FETCH ());
1333   POP (val);
1334   ASSERT_VARIABLE (v);
1335   VARIABLE_SET (v, val);
1336   NEXT;
1337 }
1338
1339 VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1)
1340 {
1341   scm_t_uint8 idx = FETCH ();
1342
1343   CHECK_FREE_VARIABLE (idx);
1344   PUSH (FREE_VARIABLE_REF (idx));
1345   NEXT;
1346 }
1347
1348 /* no free-set -- if a var is assigned, it should be in a box */
1349
1350 VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1351 {
1352   SCM v;
1353   scm_t_uint8 idx = FETCH ();
1354   CHECK_FREE_VARIABLE (idx);
1355   v = FREE_VARIABLE_REF (idx);
1356   ASSERT_BOUND_VARIABLE (v);
1357   PUSH (VARIABLE_REF (v));
1358   NEXT;
1359 }
1360
1361 VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0)
1362 {
1363   SCM v, val;
1364   scm_t_uint8 idx = FETCH ();
1365   POP (val);
1366   CHECK_FREE_VARIABLE (idx);
1367   v = FREE_VARIABLE_REF (idx);
1368   ASSERT_BOUND_VARIABLE (v);
1369   VARIABLE_SET (v, val);
1370   NEXT;
1371 }
1372
1373 VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1)
1374 {
1375   size_t n, len;
1376   SCM closure;
1377
1378   len = FETCH ();
1379   len <<= 8;
1380   len += FETCH ();
1381   SYNC_BEFORE_GC ();
1382   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1383   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1384   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1385   sp[-len] = closure;
1386   for (n = 0; n < len; n++)
1387     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1388   DROPN (len);
1389   NEXT;
1390 }
1391
1392 VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1)
1393 {
1394   SYNC_BEFORE_GC ();
1395   /* fixme underflow */
1396   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1397   NEXT;
1398 }
1399
1400 VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0)
1401 {
1402   SCM x;
1403   unsigned int i = FETCH ();
1404   size_t n, len;
1405   i <<= 8;
1406   i += FETCH ();
1407   /* FIXME CHECK_LOCAL (i) */
1408   x = LOCAL_REF (i);
1409   /* FIXME ASSERT_PROGRAM (x); */
1410   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1411   for (n = 0; n < len; n++)
1412     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1413   DROPN (len);
1414   NEXT;
1415 }
1416
1417 VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2)
1418 {
1419   SCM sym, val;
1420   POP2 (sym, val);
1421   SYNC_REGISTER ();
1422   scm_define (sym, val);
1423   NEXT;
1424 }
1425
1426 VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1)
1427 {
1428   CHECK_UNDERFLOW ();
1429   SYNC_REGISTER ();
1430   *sp = scm_symbol_to_keyword (*sp);
1431   NEXT;
1432 }
1433
1434 VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1)
1435 {
1436   CHECK_UNDERFLOW ();
1437   SYNC_REGISTER ();
1438   *sp = scm_string_to_symbol (*sp);
1439   NEXT;
1440 }
1441
1442 VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
1443 {
1444   scm_t_int32 offset;
1445   scm_t_uint8 escape_only_p;
1446   SCM k;
1447   scm_t_dynstack_prompt_flags flags;
1448
1449   escape_only_p = FETCH ();
1450   FETCH_OFFSET (offset);
1451   POP (k);
1452
1453   SYNC_REGISTER ();
1454   /* Push the prompt onto the dynamic stack. */
1455   flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
1456   scm_dynstack_push_prompt (&current_thread->dynstack, flags, k,
1457                             fp, sp, ip + offset, &registers);
1458   NEXT;
1459 }
1460
1461 VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
1462 {
1463   SCM wind, unwind;
1464   POP2 (unwind, wind);
1465   SYNC_REGISTER ();
1466   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1467      are actually called; the compiler should emit calls to wind and unwind for
1468      the normal dynamic-wind control flow.  Also note that the compiler
1469      should have inserted checks that they wind and unwind procs are
1470      thunks, if it could not prove that to be the case.  */
1471   scm_dynstack_push_dynwind (&current_thread->dynstack, wind, unwind);
1472   NEXT;
1473 }
1474
1475 VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
1476 {
1477   unsigned n = FETCH ();
1478   SYNC_REGISTER ();
1479   PRE_CHECK_UNDERFLOW (n + 2);
1480   vm_abort (vm, n, &registers);
1481   /* vm_abort should not return */
1482   abort ();
1483 }
1484
1485 VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
1486 {
1487   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1488      off of the dynamic stack. */
1489   scm_dynstack_pop (&current_thread->dynstack);
1490   NEXT;
1491 }
1492
1493 VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
1494 {
1495   SCM fluid, val;
1496   POP2 (val, fluid);
1497   SYNC_REGISTER ();
1498   scm_dynstack_push_fluids (&current_thread->dynstack, 1, &fluid, &val,
1499                             current_thread->dynamic_state);
1500   NEXT;
1501 }
1502
1503 VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
1504 {
1505   /* This function must not allocate.  */
1506   scm_dynstack_unwind_fluids (&current_thread->dynstack,
1507                               current_thread->dynamic_state);
1508   NEXT;
1509 }
1510
1511 VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1)
1512 {
1513   size_t num;
1514   SCM fluids;
1515
1516   CHECK_UNDERFLOW ();
1517   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1518   if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
1519       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1520     {
1521       /* Punt dynstate expansion and error handling to the C proc. */
1522       SYNC_REGISTER ();
1523       *sp = scm_fluid_ref (*sp);
1524     }
1525   else
1526     {
1527       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
1528       if (scm_is_eq (val, SCM_UNDEFINED))
1529         val = SCM_I_FLUID_DEFAULT (*sp);
1530       VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
1531                  vm_error_unbound_fluid (program, *sp));
1532       *sp = val;
1533     }
1534
1535   NEXT;
1536 }
1537
1538 VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0)
1539 {
1540   size_t num;
1541   SCM val, fluid, fluids;
1542
1543   POP2 (val, fluid);
1544   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1545   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
1546       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1547     {
1548       /* Punt dynstate expansion and error handling to the C proc. */
1549       SYNC_REGISTER ();
1550       scm_fluid_set_x (fluid, val);
1551     }
1552   else
1553     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1554
1555   NEXT;
1556 }
1557
1558 VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1559 {
1560   scm_t_ptrdiff n;
1561   SCM *old_sp;
1562
1563   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1564   n = FETCH ();
1565
1566   VM_ASSERT (sp - (fp - 1) == (n & 0x7),
1567              vm_error_wrong_num_args (program));
1568
1569   old_sp = sp;
1570   sp += (n >> 3);
1571   CHECK_OVERFLOW ();
1572   while (old_sp < sp)
1573     *++old_sp = SCM_UNDEFINED;
1574
1575   NEXT;
1576 }
1577
1578 /* Like bind-optionals/shuffle, but if there are too many positional
1579    arguments, jumps to the next case-lambda clause.  */
1580 VM_DEFINE_INSTRUCTION (96, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
1581 {
1582   SCM *walk;
1583   scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
1584   scm_t_int32 offset;
1585   nreq = FETCH () << 8;
1586   nreq += FETCH ();
1587   nreq_and_opt = FETCH () << 8;
1588   nreq_and_opt += FETCH ();
1589   ntotal = FETCH () << 8;
1590   ntotal += FETCH ();
1591   FETCH_OFFSET (offset);
1592
1593   /* look in optionals for first keyword or last positional */
1594   /* starting after the last required positional arg */
1595   walk = fp + nreq;
1596   while (/* while we have args */
1597          walk <= sp
1598          /* and we still have positionals to fill */
1599          && walk - fp < nreq_and_opt
1600          /* and we haven't reached a keyword yet */
1601          && !scm_is_keyword (*walk))
1602     /* bind this optional arg (by leaving it in place) */
1603     walk++;
1604   if (/* If we have filled all the positionals */
1605       walk - fp == nreq_and_opt
1606       /* and there are still more arguments */
1607       && walk <= sp
1608       /* and the next argument is not a keyword, */
1609       && !scm_is_keyword (*walk))
1610     {
1611       /* Jump to the next case-lambda* clause. */
1612       ip += offset;
1613     }
1614   else
1615     {
1616       /* Otherwise, finish as in bind-optionals/shuffle: shuffle up,
1617          from walk to ntotal */
1618       scm_t_ptrdiff nshuf = sp - walk + 1, i;
1619       sp = (fp - 1) + ntotal + nshuf;
1620       CHECK_OVERFLOW ();
1621       for (i = 0; i < nshuf; i++)
1622         sp[-i] = walk[nshuf-i-1];
1623
1624       /* and fill optionals & keyword args with SCM_UNDEFINED */
1625       while (walk <= (fp - 1) + ntotal)
1626         *walk++ = SCM_UNDEFINED;
1627     }
1628
1629   NEXT;
1630 }
1631
1632
1633 /*
1634 (defun renumber-ops ()
1635   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1636   (interactive "")
1637   (save-excursion
1638     (let ((counter -1)) (goto-char (point-min))
1639       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1640         (replace-match
1641          (number-to-string (setq counter (1+ counter)))
1642           t t nil 1)))))
1643 (renumber-ops)
1644 */
1645 /*
1646   Local Variables:
1647   c-file-style: "gnu"
1648   End:
1649 */