libguile/vm-i-system.c

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