libguile/vm-i-system.c

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