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   PUSH ((SCM)fp); /* dynamic link */
 760   PUSH (0);  /* mvra */
 761   PUSH (0);  /* ra */
 762   NEXT;
 763 }
 764
 765 VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
 766 {
 767   nargs = FETCH ();
 768
 769  vm_call:
 770   program = sp[-nargs];
 771
 772   VM_HANDLE_INTERRUPTS;
 773
 774   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 775     {
 776       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 777         {
 778           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 779           goto vm_call;
 780         }
 781       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 782                && SCM_SMOB_APPLICABLE_P (program))
 783         {
 784           SYNC_REGISTER ();
 785           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 786           goto vm_call;
 787         }
 788       else
 789         goto vm_error_wrong_type_apply;
 790     }
 791
 792   CACHE_PROGRAM ();
 793   fp = sp - nargs + 1;
 794   ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 795   ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 796   SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 797   SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
 798   ip = SCM_C_OBJCODE_BASE (bp);
 799   PUSH_CONTINUATION_HOOK ();
 800   APPLY_HOOK ();
 801   NEXT;
 802 }
 803
 804 VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
 805 {
 806   nargs = FETCH ();
 807
 808  vm_tail_call:
 809   program = sp[-nargs];
 810
 811   VM_HANDLE_INTERRUPTS;
 812
 813   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 814     {
 815       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 816         {
 817           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 818           goto vm_tail_call;
 819         }
 820       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 821                && SCM_SMOB_APPLICABLE_P (program))
 822         {
 823           SYNC_REGISTER ();
 824           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 825           goto vm_tail_call;
 826         }
 827       else
 828         goto vm_error_wrong_type_apply;
 829     }
 830   else
 831     {
 832       int i;
 833 #ifdef VM_ENABLE_STACK_NULLING
 834       SCM *old_sp = sp;
 835       CHECK_STACK_LEAK ();
 836 #endif
 837
 838       /* switch programs */
 839       CACHE_PROGRAM ();
 840       /* shuffle down the program and the arguments */
 841       for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
 842         SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 843
 844       sp = fp + i - 1;
 845
 846       NULLSTACK (old_sp - sp);
 847
 848       ip = SCM_C_OBJCODE_BASE (bp);
 849
 850       APPLY_HOOK ();
 851       NEXT;
 852     }
 853 }
 854
 855 VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
 856 {
 857   SCM pointer, ret;
 858   SCM (*subr)();
 859
 860   nargs = FETCH ();
 861   POP (pointer);
 862
 863   subr = SCM_POINTER_VALUE (pointer);
 864
 865   VM_HANDLE_INTERRUPTS;
 866   SYNC_REGISTER ();
 867
 868   switch (nargs)
 869     {
 870     case 0:
 871       ret = subr ();
 872       break;
 873     case 1:
 874       ret = subr (sp[0]);
 875       break;
 876     case 2:
 877       ret = subr (sp[-1], sp[0]);
 878       break;
 879     case 3:
 880       ret = subr (sp[-2], sp[-1], sp[0]);
 881       break;
 882     case 4:
 883       ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
 884       break;
 885     case 5:
 886       ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 887       break;
 888     case 6:
 889       ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 890       break;
 891     case 7:
 892       ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 893       break;
 894     case 8:
 895       ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 896       break;
 897     case 9:
 898       ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 899       break;
 900     case 10:
 901       ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 902       break;
 903     default:
 904       abort ();
 905     }
 906
 907   NULLSTACK_FOR_NONLOCAL_EXIT ();
 908
 909   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 910     {
 911       /* multiple values returned to continuation */
 912       ret = scm_struct_ref (ret, SCM_INUM0);
 913       nvalues = scm_ilength (ret);
 914       PUSH_LIST (ret, scm_is_null);
 915       goto vm_return_values;
 916     }
 917   else
 918     {
 919       PUSH (ret);
 920       goto vm_return;
 921     }
 922 }
 923
 924 VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
 925 {
 926   SCM smob, ret;
 927   SCM (*subr)();
 928   nargs = FETCH ();
 929   POP (smob);
 930
 931   subr = SCM_SMOB_DESCRIPTOR (smob).apply;
 932
 933   VM_HANDLE_INTERRUPTS;
 934   SYNC_REGISTER ();
 935
 936   switch (nargs)
 937     {
 938     case 0:
 939       ret = subr (smob);
 940       break;
 941     case 1:
 942       ret = subr (smob, sp[0]);
 943       break;
 944     case 2:
 945       ret = subr (smob, sp[-1], sp[0]);
 946       break;
 947     case 3:
 948       ret = subr (smob, sp[-2], sp[-1], sp[0]);
 949       break;
 950     default:
 951       abort ();
 952     }
 953
 954   NULLSTACK_FOR_NONLOCAL_EXIT ();
 955
 956   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 957     {
 958       /* multiple values returned to continuation */
 959       ret = scm_struct_ref (ret, SCM_INUM0);
 960       nvalues = scm_ilength (ret);
 961       PUSH_LIST (ret, scm_is_null);
 962       goto vm_return_values;
 963     }
 964   else
 965     {
 966       PUSH (ret);
 967       goto vm_return;
 968     }
 969 }
 970
 971 VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
 972 {
 973   SCM foreign, ret;
 974   nargs = FETCH ();
 975   POP (foreign);
 976
 977   VM_HANDLE_INTERRUPTS;
 978   SYNC_REGISTER ();
 979
 980   ret = scm_i_foreign_call (foreign, sp - nargs + 1);
 981
 982   NULLSTACK_FOR_NONLOCAL_EXIT ();
 983
 984   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 985     {
 986       /* multiple values returned to continuation */
 987       ret = scm_struct_ref (ret, SCM_INUM0);
 988       nvalues = scm_ilength (ret);
 989       PUSH_LIST (ret, scm_is_null);
 990       goto vm_return_values;
 991     }
 992   else
 993     {
 994       PUSH (ret);
 995       goto vm_return;
 996     }
 997 }
 998
 999 VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
1000 {
1001   SCM contregs;
1002   POP (contregs);
1003
1004   SYNC_ALL ();
1005   scm_i_check_continuation (contregs);
1006   vm_return_to_continuation (scm_i_contregs_vm (contregs),
1007                              scm_i_contregs_vm_cont (contregs),
1008                              sp - (fp - 1), fp);
1009   scm_i_reinstate_continuation (contregs);
1010
1011   /* no NEXT */
1012   abort ();
1013 }
1014
1015 VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
1016 {
1017   SCM vmcont, intwinds, prevwinds;
1018   POP (intwinds);
1019   POP (vmcont);
1020   SYNC_REGISTER ();
1021   if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
1022     { finish_args = vmcont;
1023       goto vm_error_continuation_not_rewindable;
1024     }
1025   prevwinds = scm_i_dynwinds ();
1026   vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
1027                                      vm_cookie);
1028
1029   /* Rewind prompt jmpbuffers, if any. */
1030   {
1031     SCM winds = scm_i_dynwinds ();
1032     for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
1033       if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
1034         break;
1035   }
1036
1037   CACHE_REGISTER ();
1038   program = SCM_FRAME_PROGRAM (fp);
1039   CACHE_PROGRAM ();
1040   NEXT;
1041 }
1042
1043 VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
1044 {
1045   SCM x;
1046   POP (x);
1047   nargs = scm_to_int (x);
1048   /* FIXME: should truncate values? */
1049   goto vm_tail_call;
1050 }
1051
1052 VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
1053 {
1054   SCM x;
1055   POP (x);
1056   nargs = scm_to_int (x);
1057   /* FIXME: should truncate values? */
1058   goto vm_call;
1059 }
1060
1061 VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
1062 {
1063   scm_t_int32 offset;
1064   scm_t_uint8 *mvra;
1065
1066   nargs = FETCH ();
1067   FETCH_OFFSET (offset);
1068   mvra = ip + offset;
1069
1070  vm_mv_call:
1071   program = sp[-nargs];
1072
1073   VM_HANDLE_INTERRUPTS;
1074
1075   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
1076     {
1077       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
1078         {
1079           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
1080           goto vm_mv_call;
1081         }
1082       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
1083                && SCM_SMOB_APPLICABLE_P (program))
1084         {
1085           SYNC_REGISTER ();
1086           sp[-nargs] = scm_i_smob_apply_trampoline (program);
1087           goto vm_mv_call;
1088         }
1089       else
1090         goto vm_error_wrong_type_apply;
1091     }
1092
1093   CACHE_PROGRAM ();
1094   fp = sp - nargs + 1;
1095   ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
1096   ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
1097   SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
1098   SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
1099   ip = SCM_C_OBJCODE_BASE (bp);
1100   PUSH_CONTINUATION_HOOK ();
1101   APPLY_HOOK ();
1102   NEXT;
1103 }
1104
1105 VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
1106 {
1107   int len;
1108   SCM ls;
1109   POP (ls);
1110
1111   nargs = FETCH ();
1112   ASSERT (nargs >= 2);
1113
1114   len = scm_ilength (ls);
1115   if (SCM_UNLIKELY (len < 0))
1116     {
1117       finish_args = ls;
1118       goto vm_error_apply_to_non_list;
1119     }
1120
1121   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1122
1123   nargs += len - 2;
1124   goto vm_call;
1125 }
1126
1127 VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
1128 {
1129   int len;
1130   SCM ls;
1131   POP (ls);
1132
1133   nargs = FETCH ();
1134   ASSERT (nargs >= 2);
1135
1136   len = scm_ilength (ls);
1137   if (SCM_UNLIKELY (len < 0))
1138     {
1139       finish_args = ls;
1140       goto vm_error_apply_to_non_list;
1141     }
1142
1143   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1144
1145   nargs += len - 2;
1146   goto vm_tail_call;
1147 }
1148
1149 VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
1150 {
1151   int first;
1152   SCM proc, vm_cont, cont;
1153   POP (proc);
1154   SYNC_ALL ();
1155   vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
1156   cont = scm_i_make_continuation (&first, vm, vm_cont);
1157   if (first)
1158     {
1159       PUSH ((SCM)fp); /* dynamic link */
1160       PUSH (0);  /* mvra */
1161       PUSH (0);  /* ra */
1162       PUSH (proc);
1163       PUSH (cont);
1164       nargs = 1;
1165       goto vm_call;
1166     }
1167   else
1168     {
1169       /* Otherwise, the vm continuation was reinstated, and
1170          vm_return_to_continuation pushed on one value. We know only one
1171          value was returned because we are in value context -- the
1172          previous block jumped to vm_call, not vm_mv_call, after all.
1173
1174          So, pull our regs back down from the vp, and march on to the
1175          next instruction. */
1176       CACHE_REGISTER ();
1177       program = SCM_FRAME_PROGRAM (fp);
1178       CACHE_PROGRAM ();
1179       RESTORE_CONTINUATION_HOOK ();
1180       NEXT;
1181     }
1182 }
1183
1184 VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
1185 {
1186   int first;
1187   SCM proc, vm_cont, cont;
1188   POP (proc);
1189   SYNC_ALL ();
1190   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1191      stack frame. */
1192   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1193                                     SCM_FRAME_DYNAMIC_LINK (fp),
1194                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1195                                     SCM_FRAME_RETURN_ADDRESS (fp),
1196                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1197                                     0);
1198   cont = scm_i_make_continuation (&first, vm, vm_cont);
1199   if (first)
1200     {
1201       PUSH (proc);
1202       PUSH (cont);
1203       nargs = 1;
1204       goto vm_tail_call;
1205     }
1206   else
1207     {
1208       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1209          does a return from the frame, either to the RA or
1210          MVRA. */
1211       CACHE_REGISTER ();
1212       program = SCM_FRAME_PROGRAM (fp);
1213       CACHE_PROGRAM ();
1214       /* Unfortunately we don't know whether we are at the RA, and thus
1215          have one value without an nvalues marker, or we are at the
1216          MVRA and thus have multiple values and the nvalues
1217          marker. Instead of adding heuristics here, we will let hook
1218          client code do that. */
1219       RESTORE_CONTINUATION_HOOK ();
1220       NEXT;
1221     }
1222 }
1223
1224 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1225 {
1226  vm_return:
1227   POP_CONTINUATION_HOOK (1);
1228
1229   VM_HANDLE_INTERRUPTS;
1230
1231   {
1232     SCM ret;
1233
1234     POP (ret);
1235
1236 #ifdef VM_ENABLE_STACK_NULLING
1237     SCM *old_sp = sp;
1238 #endif
1239
1240     /* Restore registers */
1241     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1242     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1243     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1244
1245 #ifdef VM_ENABLE_STACK_NULLING
1246     NULLSTACK (old_sp - sp);
1247 #endif
1248
1249     /* Set return value (sp is already pushed) */
1250     *sp = ret;
1251   }
1252
1253   /* Restore the last program */
1254   program = SCM_FRAME_PROGRAM (fp);
1255   CACHE_PROGRAM ();
1256   CHECK_IP ();
1257   NEXT;
1258 }
1259
1260 VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
1261 {
1262   /* nvalues declared at top level, because for some reason gcc seems to think
1263      that perhaps it might be used without declaration. Fooey to that, I say. */
1264   nvalues = FETCH ();
1265  vm_return_values:
1266   POP_CONTINUATION_HOOK (nvalues);
1267
1268   VM_HANDLE_INTERRUPTS;
1269
1270   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1271     {
1272       /* A multiply-valued continuation */
1273       SCM *vals = sp - nvalues;
1274       int i;
1275       /* Restore registers */
1276       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1277       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1278       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1279
1280       /* Push return values, and the number of values */
1281       for (i = 0; i < nvalues; i++)
1282         *++sp = vals[i+1];
1283       *++sp = SCM_I_MAKINUM (nvalues);
1284
1285       /* Finally null the end of the stack */
1286       NULLSTACK (vals + nvalues - sp);
1287     }
1288   else if (nvalues >= 1)
1289     {
1290       /* Multiple values for a single-valued continuation -- here's where I
1291          break with guile tradition and try and do something sensible. (Also,
1292          this block handles the single-valued return to an mv
1293          continuation.) */
1294       SCM *vals = sp - nvalues;
1295       /* Restore registers */
1296       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1297       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1298       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1299
1300       /* Push first value */
1301       *++sp = vals[1];
1302
1303       /* Finally null the end of the stack */
1304       NULLSTACK (vals + nvalues - sp);
1305     }
1306   else
1307     goto vm_error_no_values;
1308
1309   /* Restore the last program */
1310   program = SCM_FRAME_PROGRAM (fp);
1311   CACHE_PROGRAM ();
1312   CHECK_IP ();
1313   NEXT;
1314 }
1315
1316 VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
1317 {
1318   SCM l;
1319
1320   nvalues = FETCH ();
1321   ASSERT (nvalues >= 1);
1322
1323   nvalues--;
1324   POP (l);
1325   while (scm_is_pair (l))
1326     {
1327       PUSH (SCM_CAR (l));
1328       l = SCM_CDR (l);
1329       nvalues++;
1330     }
1331   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1332     finish_args = scm_list_1 (l);
1333     goto vm_error_improper_list;
1334   }
1335
1336   goto vm_return_values;
1337 }
1338
1339 VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
1340 {
1341   SCM n;
1342   POP (n);
1343   nvalues = scm_to_int (n);
1344   ASSERT (nvalues >= 0);
1345   goto vm_return_values;
1346 }
1347
1348 VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
1349 {
1350   SCM x;
1351   int nbinds, rest;
1352   POP (x);
1353   nvalues = scm_to_int (x);
1354   nbinds = FETCH ();
1355   rest = FETCH ();
1356
1357   if (rest)
1358     nbinds--;
1359
1360   if (nvalues < nbinds)
1361     goto vm_error_not_enough_values;
1362
1363   if (rest)
1364     POP_LIST (nvalues - nbinds);
1365   else
1366     DROPN (nvalues - nbinds);
1367
1368   NEXT;
1369 }
1370
1371 VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
1372 {
1373   SCM val;
1374   POP (val);
1375   SYNC_BEFORE_GC ();
1376   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1377   NEXT;
1378 }
1379
1380 /* for letrec:
1381    (let ((a *undef*) (b *undef*) ...)
1382      (set! a (lambda () (b ...)))
1383      ...)
1384  */
1385 VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
1386 {
1387   SYNC_BEFORE_GC ();
1388   LOCAL_SET (FETCH (),
1389              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1390   NEXT;
1391 }
1392
1393 VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1394 {
1395   SCM v = LOCAL_REF (FETCH ());
1396   ASSERT_BOUND_VARIABLE (v);
1397   PUSH (VARIABLE_REF (v));
1398   NEXT;
1399 }
1400
1401 VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
1402 {
1403   SCM v, val;
1404   v = LOCAL_REF (FETCH ());
1405   POP (val);
1406   ASSERT_VARIABLE (v);
1407   VARIABLE_SET (v, val);
1408   NEXT;
1409 }
1410
1411 VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
1412 {
1413   scm_t_uint8 idx = FETCH ();
1414
1415   CHECK_FREE_VARIABLE (idx);
1416   PUSH (FREE_VARIABLE_REF (idx));
1417   NEXT;
1418 }
1419
1420 /* no free-set -- if a var is assigned, it should be in a box */
1421
1422 VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1423 {
1424   SCM v;
1425   scm_t_uint8 idx = FETCH ();
1426   CHECK_FREE_VARIABLE (idx);
1427   v = FREE_VARIABLE_REF (idx);
1428   ASSERT_BOUND_VARIABLE (v);
1429   PUSH (VARIABLE_REF (v));
1430   NEXT;
1431 }
1432
1433 VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
1434 {
1435   SCM v, val;
1436   scm_t_uint8 idx = FETCH ();
1437   POP (val);
1438   CHECK_FREE_VARIABLE (idx);
1439   v = FREE_VARIABLE_REF (idx);
1440   ASSERT_BOUND_VARIABLE (v);
1441   VARIABLE_SET (v, val);
1442   NEXT;
1443 }
1444
1445 VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
1446 {
1447   size_t n, len;
1448   SCM closure;
1449
1450   len = FETCH ();
1451   len <<= 8;
1452   len += FETCH ();
1453   SYNC_BEFORE_GC ();
1454   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1455   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1456   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1457   sp[-len] = closure;
1458   for (n = 0; n < len; n++)
1459     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1460   DROPN (len);
1461   NEXT;
1462 }
1463
1464 VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
1465 {
1466   SYNC_BEFORE_GC ();
1467   /* fixme underflow */
1468   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1469   NEXT;
1470 }
1471
1472 VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
1473 {
1474   SCM x;
1475   unsigned int i = FETCH ();
1476   size_t n, len;
1477   i <<= 8;
1478   i += FETCH ();
1479   /* FIXME CHECK_LOCAL (i) */
1480   x = LOCAL_REF (i);
1481   /* FIXME ASSERT_PROGRAM (x); */
1482   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1483   for (n = 0; n < len; n++)
1484     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1485   DROPN (len);
1486   NEXT;
1487 }
1488
1489 VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
1490 {
1491   SCM sym, val;
1492   POP (sym);
1493   POP (val);
1494   SYNC_REGISTER ();
1495   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1496                              SCM_BOOL_T),
1497                 val);
1498   NEXT;
1499 }
1500
1501 VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
1502 {
1503   CHECK_UNDERFLOW ();
1504   SYNC_REGISTER ();
1505   *sp = scm_symbol_to_keyword (*sp);
1506   NEXT;
1507 }
1508
1509 VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
1510 {
1511   CHECK_UNDERFLOW ();
1512   SYNC_REGISTER ();
1513   *sp = scm_string_to_symbol (*sp);
1514   NEXT;
1515 }
1516
1517 VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
1518 {
1519   scm_t_int32 offset;
1520   scm_t_uint8 escape_only_p;
1521   SCM k, prompt;
1522
1523   escape_only_p = FETCH ();
1524   FETCH_OFFSET (offset);
1525   POP (k);
1526
1527   SYNC_REGISTER ();
1528   /* Push the prompt onto the dynamic stack. */
1529   prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
1530                               scm_i_dynwinds ());
1531   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
1532   if (SCM_PROMPT_SETJMP (prompt))
1533     {
1534       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1535          to the handler.
1536
1537          Note, at this point, we must assume that any variable local to
1538          vm_engine that can be assigned *has* been assigned. So we need to pull
1539          all our state back from the ip/fp/sp.
1540       */
1541       CACHE_REGISTER ();
1542       program = SCM_FRAME_PROGRAM (fp);
1543       CACHE_PROGRAM ();
1544       /* The stack contains the values returned to this prompt, along
1545          with a number-of-values marker -- like an MV return. */
1546       ABORT_CONTINUATION_HOOK ();
1547       NEXT;
1548     }
1549
1550   /* Otherwise setjmp returned for the first time, so we go to execute the
1551      prompt's body. */
1552   NEXT;
1553 }
1554
1555 VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
1556 {
1557   SCM wind, unwind;
1558   POP (unwind);
1559   POP (wind);
1560   SYNC_REGISTER ();
1561   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1562      are actually called; the compiler should emit calls to wind and unwind for
1563      the normal dynamic-wind control flow. */
1564   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
1565     {
1566       finish_args = wind;
1567       goto vm_error_not_a_thunk;
1568     }
1569   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
1570     {
1571       finish_args = unwind;
1572       goto vm_error_not_a_thunk;
1573     }
1574   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
1575   NEXT;
1576 }
1577
1578 VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
1579 {
1580   unsigned n = FETCH ();
1581   SYNC_REGISTER ();
1582   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
1583     goto vm_error_stack_underflow;
1584   vm_abort (vm, n, vm_cookie);
1585   /* vm_abort should not return */
1586   abort ();
1587 }
1588
1589 VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
1590 {
1591   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1592      off of the dynamic stack. */
1593   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1594   NEXT;
1595 }
1596
1597 VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
1598 {
1599   unsigned n = FETCH ();
1600   SCM wf;
1601
1602   SYNC_REGISTER ();
1603   sp -= 2 * n;
1604   CHECK_UNDERFLOW ();
1605   wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
1606   NULLSTACK (2 * n);
1607
1608   scm_i_swap_with_fluids (wf, dynstate);
1609   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
1610   NEXT;
1611 }
1612
1613 VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
1614 {
1615   SCM wf;
1616   wf = scm_car (scm_i_dynwinds ());
1617   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1618   scm_i_swap_with_fluids (wf, dynstate);
1619   NEXT;
1620 }
1621
1622 VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
1623 {
1624   size_t num;
1625   SCM fluids;
1626
1627   CHECK_UNDERFLOW ();
1628   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1629   if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
1630       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1631     {
1632       /* Punt dynstate expansion and error handling to the C proc. */
1633       SYNC_REGISTER ();
1634       *sp = scm_fluid_ref (*sp);
1635     }
1636   else
1637     {
1638       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
1639       if (SCM_UNLIKELY (val == SCM_UNDEFINED))
1640         {
1641           finish_args = *sp;
1642           goto vm_error_unbound_fluid;
1643         }
1644       *sp = val;
1645     }
1646
1647   NEXT;
1648 }
1649
1650 VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
1651 {
1652   size_t num;
1653   SCM val, fluid, fluids;
1654
1655   POP (val);
1656   POP (fluid);
1657   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1658   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
1659       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1660     {
1661       /* Punt dynstate expansion and error handling to the C proc. */
1662       SYNC_REGISTER ();
1663       scm_fluid_set_x (fluid, val);
1664     }
1665   else
1666     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1667
1668   NEXT;
1669 }
1670
1671 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1672 {
1673   scm_t_ptrdiff n;
1674   SCM *old_sp;
1675
1676   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1677   n = FETCH ();
1678
1679   if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
1680     goto vm_error_wrong_num_args;
1681
1682   old_sp = sp;
1683   sp += (n >> 3);
1684   CHECK_OVERFLOW ();
1685   while (old_sp < sp)
1686     *++old_sp = SCM_UNDEFINED;
1687
1688   NEXT;
1689 }
1690
1691
1692 /*
1693 (defun renumber-ops ()
1694   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1695   (interactive "")
1696   (save-excursion
1697     (let ((counter -1)) (goto-char (point-min))
1698       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1699         (replace-match
1700          (number-to-string (setq counter (1+ counter)))
1701           t t nil 1)))))
1702 (renumber-ops)
1703 */
1704 /*
1705   Local Variables:
1706   c-file-style: "gnu"
1707   End:
1708 */