libguile/vm-i-system.c

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