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