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