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