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