libguile/vm-i-system.c

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