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_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 (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;
 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 (28, 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 (29, local_set, "local-set", 1, 1, 0)
 381 {
 382   LOCAL_SET (FETCH (), *sp);
 383   DROP ();
 384   NEXT;
 385 }
 386
 387 VM_DEFINE_INSTRUCTION (30, 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 (31, 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 (32, 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 (33, 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 (34, 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 (35, br_if, "br-if", 3, 0, 0)
 482 {
 483   BR (scm_is_true (*sp));
 484 }
 485
 486 VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
 487 {
 488   BR (scm_is_false (*sp));
 489 }
 490
 491 VM_DEFINE_INSTRUCTION (37, 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 (38, 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 (39, br_if_null, "br-if-null", 3, 0, 0)
 504 {
 505   BR (scm_is_null (*sp));
 506 }
 507
 508 VM_DEFINE_INSTRUCTION (40, 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 (41, 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 (42, 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 (43, 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 (44, 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 (45, 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 (46, 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 (47, 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 (48, 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 (49, 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 (50, 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 (51, 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 (52, 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 (53, 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 (54, 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 (55, 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 (56, 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 (57, 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 (58, 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 (59, 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 (60, 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 (61, 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 (62, 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 (63, 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 (64, 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 (65, 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          vm_return_to_continuation pushed on one value. We know only one
1147          value was returned because we are in value context -- the
1148          previous block jumped to vm_call, not vm_mv_call, after all.
1149
1150          So, pull our regs back down from the vp, and march on to the
1151          next instruction. */
1152       CACHE_REGISTER ();
1153       program = SCM_FRAME_PROGRAM (fp);
1154       CACHE_PROGRAM ();
1155       RESTORE_CONTINUATION_HOOK ();
1156       NEXT;
1157     }
1158 }
1159
1160 VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
1161 {
1162   int first;
1163   SCM proc, vm_cont, cont;
1164   POP (proc);
1165   SYNC_ALL ();
1166   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1167      stack frame. */
1168   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1169                                     SCM_FRAME_DYNAMIC_LINK (fp),
1170                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1171                                     SCM_FRAME_RETURN_ADDRESS (fp),
1172                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1173                                     0);
1174   cont = scm_i_make_continuation (&first, vm, vm_cont);
1175   if (first)
1176     {
1177       PUSH (proc);
1178       PUSH (cont);
1179       nargs = 1;
1180       goto vm_tail_call;
1181     }
1182   else
1183     {
1184       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1185          does a return from the frame, either to the RA or
1186          MVRA. */
1187       CACHE_REGISTER ();
1188       program = SCM_FRAME_PROGRAM (fp);
1189       CACHE_PROGRAM ();
1190       /* Unfortunately we don't know whether we are at the RA, and thus
1191          have one value without an nvalues marker, or we are at the
1192          MVRA and thus have multiple values and the nvalues
1193          marker. Instead of adding heuristics here, we will let hook
1194          client code do that. */
1195       RESTORE_CONTINUATION_HOOK ();
1196       NEXT;
1197     }
1198 }
1199
1200 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1201 {
1202  vm_return:
1203   POP_CONTINUATION_HOOK (1);
1204
1205   VM_HANDLE_INTERRUPTS;
1206
1207   {
1208     SCM ret;
1209
1210     POP (ret);
1211
1212 #ifdef VM_ENABLE_STACK_NULLING
1213     SCM *old_sp = sp;
1214 #endif
1215
1216     /* Restore registers */
1217     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1218     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1219     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1220
1221 #ifdef VM_ENABLE_STACK_NULLING
1222     NULLSTACK (old_sp - sp);
1223 #endif
1224
1225     /* Set return value (sp is already pushed) */
1226     *sp = ret;
1227   }
1228
1229   /* Restore the last program */
1230   program = SCM_FRAME_PROGRAM (fp);
1231   CACHE_PROGRAM ();
1232   CHECK_IP ();
1233   NEXT;
1234 }
1235
1236 VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
1237 {
1238   /* nvalues declared at top level, because for some reason gcc seems to think
1239      that perhaps it might be used without declaration. Fooey to that, I say. */
1240   nvalues = FETCH ();
1241  vm_return_values:
1242   POP_CONTINUATION_HOOK (nvalues);
1243
1244   VM_HANDLE_INTERRUPTS;
1245
1246   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1247     {
1248       /* A multiply-valued continuation */
1249       SCM *vals = sp - nvalues;
1250       int i;
1251       /* Restore registers */
1252       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1253       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1254       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1255
1256       /* Push return values, and the number of values */
1257       for (i = 0; i < nvalues; i++)
1258         *++sp = vals[i+1];
1259       *++sp = SCM_I_MAKINUM (nvalues);
1260
1261       /* Finally null the end of the stack */
1262       NULLSTACK (vals + nvalues - sp);
1263     }
1264   else if (nvalues >= 1)
1265     {
1266       /* Multiple values for a single-valued continuation -- here's where I
1267          break with guile tradition and try and do something sensible. (Also,
1268          this block handles the single-valued return to an mv
1269          continuation.) */
1270       SCM *vals = sp - nvalues;
1271       /* Restore registers */
1272       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1273       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1274       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1275
1276       /* Push first value */
1277       *++sp = vals[1];
1278
1279       /* Finally null the end of the stack */
1280       NULLSTACK (vals + nvalues - sp);
1281     }
1282   else
1283     goto vm_error_no_values;
1284
1285   /* Restore the last program */
1286   program = SCM_FRAME_PROGRAM (fp);
1287   CACHE_PROGRAM ();
1288   CHECK_IP ();
1289   NEXT;
1290 }
1291
1292 VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
1293 {
1294   SCM l;
1295
1296   nvalues = FETCH ();
1297   ASSERT (nvalues >= 1);
1298
1299   nvalues--;
1300   POP (l);
1301   while (scm_is_pair (l))
1302     {
1303       PUSH (SCM_CAR (l));
1304       l = SCM_CDR (l);
1305       nvalues++;
1306     }
1307   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1308     finish_args = scm_list_1 (l);
1309     goto vm_error_improper_list;
1310   }
1311
1312   goto vm_return_values;
1313 }
1314
1315 VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
1316 {
1317   SCM n;
1318   POP (n);
1319   nvalues = scm_to_int (n);
1320   ASSERT (nvalues >= 0);
1321   goto vm_return_values;
1322 }
1323
1324 VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
1325 {
1326   SCM x;
1327   int nbinds, rest;
1328   POP (x);
1329   nvalues = scm_to_int (x);
1330   nbinds = FETCH ();
1331   rest = FETCH ();
1332
1333   if (rest)
1334     nbinds--;
1335
1336   if (nvalues < nbinds)
1337     goto vm_error_not_enough_values;
1338
1339   if (rest)
1340     POP_LIST (nvalues - nbinds);
1341   else
1342     DROPN (nvalues - nbinds);
1343
1344   NEXT;
1345 }
1346
1347 VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
1348 {
1349   SCM val;
1350   POP (val);
1351   SYNC_BEFORE_GC ();
1352   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1353   NEXT;
1354 }
1355
1356 /* for letrec:
1357    (let ((a *undef*) (b *undef*) ...)
1358      (set! a (lambda () (b ...)))
1359      ...)
1360  */
1361 VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
1362 {
1363   SYNC_BEFORE_GC ();
1364   LOCAL_SET (FETCH (),
1365              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1366   NEXT;
1367 }
1368
1369 VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1370 {
1371   SCM v = LOCAL_REF (FETCH ());
1372   ASSERT_BOUND_VARIABLE (v);
1373   PUSH (VARIABLE_REF (v));
1374   NEXT;
1375 }
1376
1377 VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
1378 {
1379   SCM v, val;
1380   v = LOCAL_REF (FETCH ());
1381   POP (val);
1382   ASSERT_VARIABLE (v);
1383   VARIABLE_SET (v, val);
1384   NEXT;
1385 }
1386
1387 VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
1388 {
1389   scm_t_uint8 idx = FETCH ();
1390
1391   CHECK_FREE_VARIABLE (idx);
1392   PUSH (FREE_VARIABLE_REF (idx));
1393   NEXT;
1394 }
1395
1396 /* no free-set -- if a var is assigned, it should be in a box */
1397
1398 VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1399 {
1400   SCM v;
1401   scm_t_uint8 idx = FETCH ();
1402   CHECK_FREE_VARIABLE (idx);
1403   v = FREE_VARIABLE_REF (idx);
1404   ASSERT_BOUND_VARIABLE (v);
1405   PUSH (VARIABLE_REF (v));
1406   NEXT;
1407 }
1408
1409 VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
1410 {
1411   SCM v, val;
1412   scm_t_uint8 idx = FETCH ();
1413   POP (val);
1414   CHECK_FREE_VARIABLE (idx);
1415   v = FREE_VARIABLE_REF (idx);
1416   ASSERT_BOUND_VARIABLE (v);
1417   VARIABLE_SET (v, val);
1418   NEXT;
1419 }
1420
1421 VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
1422 {
1423   size_t n, len;
1424   SCM closure;
1425
1426   len = FETCH ();
1427   len <<= 8;
1428   len += FETCH ();
1429   SYNC_BEFORE_GC ();
1430   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1431   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1432   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1433   sp[-len] = closure;
1434   for (n = 0; n < len; n++)
1435     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1436   DROPN (len);
1437   NEXT;
1438 }
1439
1440 VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
1441 {
1442   SYNC_BEFORE_GC ();
1443   /* fixme underflow */
1444   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1445   NEXT;
1446 }
1447
1448 VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
1449 {
1450   SCM x;
1451   unsigned int i = FETCH ();
1452   size_t n, len;
1453   i <<= 8;
1454   i += FETCH ();
1455   /* FIXME CHECK_LOCAL (i) */
1456   x = LOCAL_REF (i);
1457   /* FIXME ASSERT_PROGRAM (x); */
1458   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1459   for (n = 0; n < len; n++)
1460     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1461   DROPN (len);
1462   NEXT;
1463 }
1464
1465 VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
1466 {
1467   SCM sym, val;
1468   POP (sym);
1469   POP (val);
1470   SYNC_REGISTER ();
1471   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1472                              SCM_BOOL_T),
1473                 val);
1474   NEXT;
1475 }
1476
1477 VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
1478 {
1479   CHECK_UNDERFLOW ();
1480   SYNC_REGISTER ();
1481   *sp = scm_symbol_to_keyword (*sp);
1482   NEXT;
1483 }
1484
1485 VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
1486 {
1487   CHECK_UNDERFLOW ();
1488   SYNC_REGISTER ();
1489   *sp = scm_string_to_symbol (*sp);
1490   NEXT;
1491 }
1492
1493 VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
1494 {
1495   scm_t_int32 offset;
1496   scm_t_uint8 escape_only_p;
1497   SCM k, prompt;
1498
1499   escape_only_p = FETCH ();
1500   FETCH_OFFSET (offset);
1501   POP (k);
1502
1503   SYNC_REGISTER ();
1504   /* Push the prompt onto the dynamic stack. */
1505   prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
1506                               scm_i_dynwinds ());
1507   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
1508   if (SCM_PROMPT_SETJMP (prompt))
1509     {
1510       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1511          to the handler.
1512
1513          Note, at this point, we must assume that any variable local to
1514          vm_engine that can be assigned *has* been assigned. So we need to pull
1515          all our state back from the ip/fp/sp.
1516       */
1517       CACHE_REGISTER ();
1518       program = SCM_FRAME_PROGRAM (fp);
1519       CACHE_PROGRAM ();
1520       /* The stack contains the values returned to this prompt, along
1521          with a number-of-values marker -- like an MV return. */
1522       ABORT_CONTINUATION_HOOK ();
1523       NEXT;
1524     }
1525
1526   /* Otherwise setjmp returned for the first time, so we go to execute the
1527      prompt's body. */
1528   NEXT;
1529 }
1530
1531 VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
1532 {
1533   SCM wind, unwind;
1534   POP (unwind);
1535   POP (wind);
1536   SYNC_REGISTER ();
1537   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1538      are actually called; the compiler should emit calls to wind and unwind for
1539      the normal dynamic-wind control flow. */
1540   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
1541     {
1542       finish_args = wind;
1543       goto vm_error_not_a_thunk;
1544     }
1545   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
1546     {
1547       finish_args = unwind;
1548       goto vm_error_not_a_thunk;
1549     }
1550   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
1551   NEXT;
1552 }
1553
1554 VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
1555 {
1556   unsigned n = FETCH ();
1557   SYNC_REGISTER ();
1558   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
1559     goto vm_error_stack_underflow;
1560   vm_abort (vm, n, vm_cookie);
1561   /* vm_abort should not return */
1562   abort ();
1563 }
1564
1565 VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
1566 {
1567   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1568      off of the dynamic stack. */
1569   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1570   NEXT;
1571 }
1572
1573 VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
1574 {
1575   unsigned n = FETCH ();
1576   SCM wf;
1577
1578   if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp))
1579     goto vm_error_stack_underflow;
1580
1581   SYNC_REGISTER ();
1582   wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n);
1583   scm_i_swap_with_fluids (wf, dynstate);
1584   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
1585   NEXT;
1586 }
1587
1588 VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
1589 {
1590   SCM wf;
1591   wf = scm_car (scm_i_dynwinds ());
1592   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1593   scm_i_swap_with_fluids (wf, dynstate);
1594   NEXT;
1595 }
1596
1597 VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
1598 {
1599   size_t num;
1600   SCM fluids;
1601
1602   CHECK_UNDERFLOW ();
1603   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1604   if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
1605       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1606     {
1607       /* Punt dynstate expansion and error handling to the C proc. */
1608       SYNC_REGISTER ();
1609       *sp = scm_fluid_ref (*sp);
1610     }
1611   else
1612     *sp = SCM_SIMPLE_VECTOR_REF (fluids, num);
1613
1614   NEXT;
1615 }
1616
1617 VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
1618 {
1619   size_t num;
1620   SCM val, fluid, fluids;
1621
1622   POP (val);
1623   POP (fluid);
1624   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
1625   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
1626       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1627     {
1628       /* Punt dynstate expansion and error handling to the C proc. */
1629       SYNC_REGISTER ();
1630       scm_fluid_set_x (fluid, val);
1631     }
1632   else
1633     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1634
1635   NEXT;
1636 }
1637
1638 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1639 {
1640   scm_t_ptrdiff n;
1641   SCM *old_sp;
1642
1643   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1644   n = FETCH ();
1645
1646   if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
1647     goto vm_error_wrong_num_args;
1648
1649   old_sp = sp;
1650   sp += (n >> 3);
1651   CHECK_OVERFLOW ();
1652   while (old_sp < sp)
1653     *++old_sp = SCM_UNDEFINED;
1654
1655   NEXT;
1656 }
1657
1658
1659 /*
1660 (defun renumber-ops ()
1661   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1662   (interactive "")
1663   (save-excursion
1664     (let ((counter -1)) (goto-char (point-min))
1665       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1666         (replace-match
1667          (number-to-string (setq counter (1+ counter)))
1668           t t nil 1)))))
1669 (renumber-ops)
1670 */
1671 /*
1672   Local Variables:
1673   c-file-style: "gnu"
1674   End:
1675 */