libguile/vm-i-system.c

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