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