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   NULLSTACK (1);                                \
 470   DROP ();                                      \
 471   NEXT;                                         \
 472 }
 473
 474 VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
 475 {
 476   scm_t_int32 offset;
 477   FETCH_OFFSET (offset);
 478   ip += offset;
 479   NEXT;
 480 }
 481
 482 VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
 483 {
 484   BR (scm_is_true_and_not_nil (*sp));
 485 }
 486
 487 VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
 488 {
 489   BR (scm_is_false_or_nil (*sp));
 490 }
 491
 492 VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
 493 {
 494   sp--; /* underflow? */
 495   BR (scm_is_eq (sp[0], sp[1]));
 496 }
 497
 498 VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
 499 {
 500   sp--; /* underflow? */
 501   BR (!scm_is_eq (sp[0], sp[1]));
 502 }
 503
 504 VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
 505 {
 506   BR (scm_is_null_or_nil (*sp));
 507 }
 508
 509 VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
 510 {
 511   BR (!scm_is_null_or_nil (*sp));
 512 }
 513
 514 \f
 515 /*
 516  * Subprogram call
 517  */
 518
 519 VM_DEFINE_INSTRUCTION (42, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
 520 {
 521   scm_t_ptrdiff n;
 522   scm_t_int32 offset;
 523   n = FETCH () << 8;
 524   n += FETCH ();
 525   FETCH_OFFSET (offset);
 526   if (sp - (fp - 1) != n)
 527     ip += offset;
 528   NEXT;
 529 }
 530
 531 VM_DEFINE_INSTRUCTION (43, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
 532 {
 533   scm_t_ptrdiff n;
 534   scm_t_int32 offset;
 535   n = FETCH () << 8;
 536   n += FETCH ();
 537   FETCH_OFFSET (offset);
 538   if (sp - (fp - 1) < n)
 539     ip += offset;
 540   NEXT;
 541 }
 542
 543 VM_DEFINE_INSTRUCTION (44, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
 544 {
 545   scm_t_ptrdiff n;
 546   scm_t_int32 offset;
 547
 548   n = FETCH () << 8;
 549   n += FETCH ();
 550   FETCH_OFFSET (offset);
 551   if (sp - (fp - 1) > n)
 552     ip += offset;
 553   NEXT;
 554 }
 555
 556 VM_DEFINE_INSTRUCTION (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
 557 {
 558   scm_t_ptrdiff n;
 559   n = FETCH () << 8;
 560   n += FETCH ();
 561   if (sp - (fp - 1) != n)
 562     goto vm_error_wrong_num_args;
 563   NEXT;
 564 }
 565
 566 VM_DEFINE_INSTRUCTION (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
 567 {
 568   scm_t_ptrdiff n;
 569   n = FETCH () << 8;
 570   n += FETCH ();
 571   if (sp - (fp - 1) < n)
 572     goto vm_error_wrong_num_args;
 573   NEXT;
 574 }
 575
 576 VM_DEFINE_INSTRUCTION (47, bind_optionals, "bind-optionals", 2, -1, -1)
 577 {
 578   scm_t_ptrdiff n;
 579   n = FETCH () << 8;
 580   n += FETCH ();
 581   while (sp - (fp - 1) < n)
 582     PUSH (SCM_UNDEFINED);
 583   NEXT;
 584 }
 585
 586 VM_DEFINE_INSTRUCTION (48, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
 587 {
 588   SCM *walk;
 589   scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
 590   nreq = FETCH () << 8;
 591   nreq += FETCH ();
 592   nreq_and_opt = FETCH () << 8;
 593   nreq_and_opt += FETCH ();
 594   ntotal = FETCH () << 8;
 595   ntotal += FETCH ();
 596
 597   /* look in optionals for first keyword or last positional */
 598   /* starting after the last required positional arg */
 599   walk = fp + nreq;
 600   while (/* while we have args */
 601          walk <= sp
 602          /* and we still have positionals to fill */
 603          && walk - fp < nreq_and_opt
 604          /* and we haven't reached a keyword yet */
 605          && !scm_is_keyword (*walk))
 606     /* bind this optional arg (by leaving it in place) */
 607     walk++;
 608   /* now shuffle up, from walk to ntotal */
 609   {
 610     scm_t_ptrdiff nshuf = sp - walk + 1, i;
 611     sp = (fp - 1) + ntotal + nshuf;
 612     CHECK_OVERFLOW ();
 613     for (i = 0; i < nshuf; i++)
 614       sp[-i] = walk[nshuf-i-1];
 615   }
 616   /* and fill optionals & keyword args with SCM_UNDEFINED */
 617   while (walk <= (fp - 1) + ntotal)
 618     *walk++ = SCM_UNDEFINED;
 619
 620   NEXT;
 621 }
 622
 623 /* Flags that determine whether other keywords are allowed, and whether a
 624    rest argument is expected.  These values must match those used by the
 625    glil->assembly compiler.  */
 626 #define F_ALLOW_OTHER_KEYS  1
 627 #define F_REST              2
 628
 629 VM_DEFINE_INSTRUCTION (49, bind_kwargs, "bind-kwargs", 5, 0, 0)
 630 {
 631   scm_t_uint16 idx;
 632   scm_t_ptrdiff nkw;
 633   int kw_and_rest_flags;
 634   SCM kw;
 635   idx = FETCH () << 8;
 636   idx += FETCH ();
 637   /* XXX: We don't actually use NKW.  */
 638   nkw = FETCH () << 8;
 639   nkw += FETCH ();
 640   kw_and_rest_flags = FETCH ();
 641
 642   if (!(kw_and_rest_flags & F_REST)
 643       && ((sp - (fp - 1) - nkw) % 2))
 644     goto vm_error_kwargs_length_not_even;
 645
 646   CHECK_OBJECT (idx);
 647   kw = OBJECT_REF (idx);
 648
 649   /* Switch NKW to be a negative index below SP.  */
 650   for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
 651     {
 652       SCM walk;
 653
 654       if (scm_is_keyword (sp[nkw]))
 655         {
 656           for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
 657             {
 658               if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
 659                 {
 660                   SCM si = SCM_CDAR (walk);
 661                   LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
 662                              sp[nkw + 1]);
 663                   break;
 664                 }
 665             }
 666           if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
 667             goto vm_error_kwargs_unrecognized_keyword;
 668
 669           nkw++;
 670         }
 671       else if (!(kw_and_rest_flags & F_REST))
 672         goto vm_error_kwargs_invalid_keyword;
 673     }
 674
 675   NEXT;
 676 }
 677
 678 #undef F_ALLOW_OTHER_KEYS
 679 #undef F_REST
 680
 681
 682 VM_DEFINE_INSTRUCTION (50, push_rest, "push-rest", 2, -1, -1)
 683 {
 684   scm_t_ptrdiff n;
 685   SCM rest = SCM_EOL;
 686   n = FETCH () << 8;
 687   n += FETCH ();
 688   while (sp - (fp - 1) > n)
 689     /* No need to check for underflow. */
 690     CONS (rest, *sp--, rest);
 691   PUSH (rest);
 692   NEXT;
 693 }
 694
 695 VM_DEFINE_INSTRUCTION (51, bind_rest, "bind-rest", 4, -1, -1)
 696 {
 697   scm_t_ptrdiff n;
 698   scm_t_uint32 i;
 699   SCM rest = SCM_EOL;
 700   n = FETCH () << 8;
 701   n += FETCH ();
 702   i = FETCH () << 8;
 703   i += FETCH ();
 704   while (sp - (fp - 1) > n)
 705     /* No need to check for underflow. */
 706     CONS (rest, *sp--, rest);
 707   LOCAL_SET (i, rest);
 708   NEXT;
 709 }
 710
 711 VM_DEFINE_INSTRUCTION (52, reserve_locals, "reserve-locals", 2, -1, -1)
 712 {
 713   SCM *old_sp;
 714   scm_t_int32 n;
 715   n = FETCH () << 8;
 716   n += FETCH ();
 717   old_sp = sp;
 718   sp = (fp - 1) + n;
 719
 720   if (old_sp < sp)
 721     {
 722       CHECK_OVERFLOW ();
 723       while (old_sp < sp)
 724         *++old_sp = SCM_UNDEFINED;
 725     }
 726   else
 727     NULLSTACK (old_sp - sp);
 728
 729   NEXT;
 730 }
 731
 732 VM_DEFINE_INSTRUCTION (53, new_frame, "new-frame", 0, 0, 3)
 733 {
 734   /* NB: if you change this, see frames.c:vm-frame-num-locals */
 735   /* and frames.h, vm-engine.c, etc of course */
 736   PUSH ((SCM)fp); /* dynamic link */
 737   PUSH (0);  /* mvra */
 738   PUSH (0);  /* ra */
 739   NEXT;
 740 }
 741
 742 VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
 743 {
 744   SCM x;
 745   nargs = FETCH ();
 746
 747  vm_call:
 748   x = sp[-nargs];
 749
 750   SYNC_REGISTER ();
 751   SCM_TICK;     /* allow interrupt here */
 752
 753   /*
 754    * Subprogram call
 755    */
 756   if (SCM_PROGRAM_P (x))
 757     {
 758       program = x;
 759       CACHE_PROGRAM ();
 760       fp = sp - nargs + 1;
 761       ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 762       ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 763       SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 764       SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
 765       ip = bp->base;
 766       ENTER_HOOK ();
 767       APPLY_HOOK ();
 768       NEXT;
 769     }
 770   if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
 771     {
 772       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
 773       goto vm_call;
 774     }
 775   /*
 776    * Other interpreted or compiled call
 777    */
 778   if (!scm_is_false (scm_procedure_p (x)))
 779     {
 780       SCM ret;
 781       /* At this point, the stack contains the frame, the procedure and each one
 782          of its arguments. */
 783       SYNC_REGISTER ();
 784       ret = apply_foreign (sp[-nargs],
 785                            sp - nargs + 1,
 786                            nargs,
 787                            vp->stack_limit - sp + 1);
 788       NULLSTACK_FOR_NONLOCAL_EXIT ();
 789       DROPN (nargs + 1); /* drop args and procedure */
 790       DROP_FRAME ();
 791
 792       if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 793         {
 794           /* truncate values */
 795           ret = scm_struct_ref (ret, SCM_INUM0);
 796           if (scm_is_null (ret))
 797             goto vm_error_not_enough_values;
 798           PUSH (SCM_CAR (ret));
 799         }
 800       else
 801         PUSH (ret);
 802       NEXT;
 803     }
 804
 805   program = x;
 806   goto vm_error_wrong_type_apply;
 807 }
 808
 809 VM_DEFINE_INSTRUCTION (55, goto_args, "goto/args", 1, -1, 1)
 810 {
 811   register SCM x;
 812   nargs = FETCH ();
 813  vm_goto_args:
 814   x = sp[-nargs];
 815
 816   SYNC_REGISTER ();
 817   SCM_TICK;     /* allow interrupt here */
 818
 819   /*
 820    * Tail call
 821    */
 822   if (SCM_PROGRAM_P (x))
 823     {
 824       int i;
 825 #ifdef VM_ENABLE_STACK_NULLING
 826       SCM *old_sp = sp;
 827       CHECK_STACK_LEAK ();
 828 #endif
 829
 830       EXIT_HOOK ();
 831
 832       /* switch programs */
 833       program = x;
 834       CACHE_PROGRAM ();
 835       /* shuffle down the program and the arguments */
 836       for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
 837         SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 838
 839       sp = fp + i - 1;
 840
 841       NULLSTACK (old_sp - sp);
 842
 843       ip = bp->base;
 844
 845       ENTER_HOOK ();
 846       APPLY_HOOK ();
 847       NEXT;
 848     }
 849   if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
 850     {
 851       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
 852       goto vm_goto_args;
 853     }
 854   /*
 855    * Other interpreted or compiled call
 856    */
 857   if (!scm_is_false (scm_procedure_p (x)))
 858     {
 859       SCM ret;
 860       SYNC_REGISTER ();
 861       ret = apply_foreign (sp[-nargs],
 862                            sp - nargs + 1,
 863                            nargs,
 864                            vp->stack_limit - sp + 1);
 865       NULLSTACK_FOR_NONLOCAL_EXIT ();
 866       DROPN (nargs + 1); /* drop args and procedure */
 867
 868       if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 869         {
 870           /* multiple values returned to continuation */
 871           ret = scm_struct_ref (ret, SCM_INUM0);
 872           nvalues = scm_ilength (ret);
 873           PUSH_LIST (ret, scm_is_null);
 874           goto vm_return_values;
 875         }
 876       else
 877         {
 878           PUSH (ret);
 879           goto vm_return;
 880         }
 881     }
 882
 883   program = x;
 884
 885   goto vm_error_wrong_type_apply;
 886 }
 887
 888 VM_DEFINE_INSTRUCTION (56, goto_nargs, "goto/nargs", 0, 0, 1)
 889 {
 890   SCM x;
 891   POP (x);
 892   nargs = scm_to_int (x);
 893   /* FIXME: should truncate values? */
 894   goto vm_goto_args;
 895 }
 896
 897 VM_DEFINE_INSTRUCTION (57, call_nargs, "call/nargs", 0, 0, 1)
 898 {
 899   SCM x;
 900   POP (x);
 901   nargs = scm_to_int (x);
 902   /* FIXME: should truncate values? */
 903   goto vm_call;
 904 }
 905
 906 VM_DEFINE_INSTRUCTION (58, mv_call, "mv-call", 4, -1, 1)
 907 {
 908   SCM x;
 909   scm_t_int32 offset;
 910   scm_t_uint8 *mvra;
 911
 912   nargs = FETCH ();
 913   FETCH_OFFSET (offset);
 914   mvra = ip + offset;
 915
 916  vm_mv_call:
 917   x = sp[-nargs];
 918
 919   /*
 920    * Subprogram call
 921    */
 922   if (SCM_PROGRAM_P (x))
 923     {
 924       program = x;
 925       CACHE_PROGRAM ();
 926       fp = sp - nargs + 1;
 927       ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 928       ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 929       SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 930       SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
 931       ip = bp->base;
 932       ENTER_HOOK ();
 933       APPLY_HOOK ();
 934       NEXT;
 935     }
 936   if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
 937     {
 938       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
 939       goto vm_mv_call;
 940     }
 941   /*
 942    * Other interpreted or compiled call
 943    */
 944   if (!scm_is_false (scm_procedure_p (x)))
 945     {
 946       SCM ret;
 947       /* At this point, the stack contains the frame, the procedure and each one
 948          of its arguments. */
 949       SYNC_REGISTER ();
 950       ret = apply_foreign (sp[-nargs],
 951                            sp - nargs + 1,
 952                            nargs,
 953                            vp->stack_limit - sp + 1);
 954       NULLSTACK_FOR_NONLOCAL_EXIT ();
 955       DROPN (nargs + 1); /* drop args and procedure */
 956       DROP_FRAME ();
 957
 958       if (SCM_VALUESP (ret))
 959         {
 960           SCM len;
 961           ret = scm_struct_ref (ret, SCM_INUM0);
 962           len = scm_length (ret);
 963           PUSH_LIST (ret, scm_is_null);
 964           PUSH (len);
 965           ip = mvra;
 966         }
 967       else
 968         PUSH (ret);
 969       NEXT;
 970     }
 971
 972   program = x;
 973   goto vm_error_wrong_type_apply;
 974 }
 975
 976 VM_DEFINE_INSTRUCTION (59, apply, "apply", 1, -1, 1)
 977 {
 978   int len;
 979   SCM ls;
 980   POP (ls);
 981
 982   nargs = FETCH ();
 983   ASSERT (nargs >= 2);
 984
 985   len = scm_ilength (ls);
 986   if (len < 0)
 987     goto vm_error_wrong_type_arg;
 988
 989   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 990
 991   nargs += len - 2;
 992   goto vm_call;
 993 }
 994
 995 VM_DEFINE_INSTRUCTION (60, goto_apply, "goto/apply", 1, -1, 1)
 996 {
 997   int len;
 998   SCM ls;
 999   POP (ls);
1000
1001   nargs = FETCH ();
1002   ASSERT (nargs >= 2);
1003
1004   len = scm_ilength (ls);
1005   if (len < 0)
1006     goto vm_error_wrong_type_arg;
1007
1008   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1009
1010   nargs += len - 2;
1011   goto vm_goto_args;
1012 }
1013
1014 VM_DEFINE_INSTRUCTION (61, call_cc, "call/cc", 0, 1, 1)
1015 {
1016   int first;
1017   SCM proc, cont;
1018   POP (proc);
1019   SYNC_ALL ();
1020   cont = scm_make_continuation (&first);
1021   if (first)
1022     {
1023       PUSH ((SCM)fp); /* dynamic link */
1024       PUSH (0);  /* mvra */
1025       PUSH (0);  /* ra */
1026       PUSH (proc);
1027       PUSH (cont);
1028       nargs = 1;
1029       goto vm_call;
1030     }
1031   ASSERT (sp == vp->sp);
1032   ASSERT (fp == vp->fp);
1033   else if (SCM_VALUESP (cont))
1034     {
1035       /* multiple values returned to continuation */
1036       SCM values;
1037       values = scm_struct_ref (cont, SCM_INUM0);
1038       if (scm_is_null (values))
1039         goto vm_error_no_values;
1040       /* non-tail context does not accept multiple values? */
1041       PUSH (SCM_CAR (values));
1042       NEXT;
1043     }
1044   else
1045     {
1046       PUSH (cont);
1047       NEXT;
1048     }
1049 }
1050
1051 VM_DEFINE_INSTRUCTION (62, goto_cc, "goto/cc", 0, 1, 1)
1052 {
1053   int first;
1054   SCM proc, cont;
1055   POP (proc);
1056   SYNC_ALL ();
1057   cont = scm_make_continuation (&first);
1058   ASSERT (sp == vp->sp);
1059   ASSERT (fp == vp->fp);
1060   if (first)
1061     {
1062       PUSH (proc);
1063       PUSH (cont);
1064       nargs = 1;
1065       goto vm_goto_args;
1066     }
1067   else if (SCM_VALUESP (cont))
1068     {
1069       /* multiple values returned to continuation */
1070       SCM values;
1071       values = scm_struct_ref (cont, SCM_INUM0);
1072       nvalues = scm_ilength (values);
1073       PUSH_LIST (values, scm_is_null);
1074       goto vm_return_values;
1075     }
1076   else
1077     {
1078       PUSH (cont);
1079       goto vm_return;
1080     }
1081 }
1082
1083 VM_DEFINE_INSTRUCTION (63, return, "return", 0, 1, 1)
1084 {
1085  vm_return:
1086   EXIT_HOOK ();
1087   RETURN_HOOK ();
1088   SYNC_REGISTER ();
1089   SCM_TICK;     /* allow interrupt here */
1090   {
1091     SCM ret;
1092
1093     POP (ret);
1094
1095 #ifdef VM_ENABLE_STACK_NULLING
1096     SCM *old_sp = sp;
1097 #endif
1098
1099     /* Restore registers */
1100     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1101     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1102     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1103
1104 #ifdef VM_ENABLE_STACK_NULLING
1105     NULLSTACK (old_sp - sp);
1106 #endif
1107
1108     /* Set return value (sp is already pushed) */
1109     *sp = ret;
1110   }
1111
1112   /* Restore the last program */
1113   program = SCM_FRAME_PROGRAM (fp);
1114   CACHE_PROGRAM ();
1115   CHECK_IP ();
1116   NEXT;
1117 }
1118
1119 VM_DEFINE_INSTRUCTION (64, return_values, "return/values", 1, -1, -1)
1120 {
1121   /* nvalues declared at top level, because for some reason gcc seems to think
1122      that perhaps it might be used without declaration. Fooey to that, I say. */
1123   nvalues = FETCH ();
1124  vm_return_values:
1125   EXIT_HOOK ();
1126   RETURN_HOOK ();
1127
1128   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1129     {
1130       /* A multiply-valued continuation */
1131       SCM *vals = sp - nvalues;
1132       int i;
1133       /* Restore registers */
1134       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1135       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1136       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1137
1138       /* Push return values, and the number of values */
1139       for (i = 0; i < nvalues; i++)
1140         *++sp = vals[i+1];
1141       *++sp = SCM_I_MAKINUM (nvalues);
1142
1143       /* Finally null the end of the stack */
1144       NULLSTACK (vals + nvalues - sp);
1145     }
1146   else if (nvalues >= 1)
1147     {
1148       /* Multiple values for a single-valued continuation -- here's where I
1149          break with guile tradition and try and do something sensible. (Also,
1150          this block handles the single-valued return to an mv
1151          continuation.) */
1152       SCM *vals = sp - nvalues;
1153       /* Restore registers */
1154       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1155       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1156       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1157
1158       /* Push first value */
1159       *++sp = vals[1];
1160
1161       /* Finally null the end of the stack */
1162       NULLSTACK (vals + nvalues - sp);
1163     }
1164   else
1165     goto vm_error_no_values;
1166
1167   /* Restore the last program */
1168   program = SCM_FRAME_PROGRAM (fp);
1169   CACHE_PROGRAM ();
1170   CHECK_IP ();
1171   NEXT;
1172 }
1173
1174 VM_DEFINE_INSTRUCTION (65, return_values_star, "return/values*", 1, -1, -1)
1175 {
1176   SCM l;
1177
1178   nvalues = FETCH ();
1179   ASSERT (nvalues >= 1);
1180
1181   nvalues--;
1182   POP (l);
1183   while (scm_is_pair (l))
1184     {
1185       PUSH (SCM_CAR (l));
1186       l = SCM_CDR (l);
1187       nvalues++;
1188     }
1189   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1190     finish_args = scm_list_1 (l);
1191     goto vm_error_improper_list;
1192   }
1193
1194   goto vm_return_values;
1195 }
1196
1197 VM_DEFINE_INSTRUCTION (66, truncate_values, "truncate-values", 2, -1, -1)
1198 {
1199   SCM x;
1200   int nbinds, rest;
1201   POP (x);
1202   nvalues = scm_to_int (x);
1203   nbinds = FETCH ();
1204   rest = FETCH ();
1205
1206   if (rest)
1207     nbinds--;
1208
1209   if (nvalues < nbinds)
1210     goto vm_error_not_enough_values;
1211
1212   if (rest)
1213     POP_LIST (nvalues - nbinds);
1214   else
1215     DROPN (nvalues - nbinds);
1216
1217   NEXT;
1218 }
1219
1220 VM_DEFINE_INSTRUCTION (67, box, "box", 1, 1, 0)
1221 {
1222   SCM val;
1223   POP (val);
1224   SYNC_BEFORE_GC ();
1225   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1226   NEXT;
1227 }
1228
1229 /* for letrec:
1230    (let ((a *undef*) (b *undef*) ...)
1231      (set! a (lambda () (b ...)))
1232      ...)
1233  */
1234 VM_DEFINE_INSTRUCTION (68, empty_box, "empty-box", 1, 0, 0)
1235 {
1236   SYNC_BEFORE_GC ();
1237   LOCAL_SET (FETCH (),
1238              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1239   NEXT;
1240 }
1241
1242 VM_DEFINE_INSTRUCTION (69, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1243 {
1244   SCM v = LOCAL_REF (FETCH ());
1245   ASSERT_BOUND_VARIABLE (v);
1246   PUSH (VARIABLE_REF (v));
1247   NEXT;
1248 }
1249
1250 VM_DEFINE_INSTRUCTION (70, local_boxed_set, "local-boxed-set", 1, 1, 0)
1251 {
1252   SCM v, val;
1253   v = LOCAL_REF (FETCH ());
1254   POP (val);
1255   ASSERT_VARIABLE (v);
1256   VARIABLE_SET (v, val);
1257   NEXT;
1258 }
1259
1260 VM_DEFINE_INSTRUCTION (71, free_ref, "free-ref", 1, 0, 1)
1261 {
1262   scm_t_uint8 idx = FETCH ();
1263
1264   CHECK_FREE_VARIABLE (idx);
1265   PUSH (FREE_VARIABLE_REF (idx));
1266   NEXT;
1267 }
1268
1269 /* no free-set -- if a var is assigned, it should be in a box */
1270
1271 VM_DEFINE_INSTRUCTION (72, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1272 {
1273   SCM v;
1274   scm_t_uint8 idx = FETCH ();
1275   CHECK_FREE_VARIABLE (idx);
1276   v = FREE_VARIABLE_REF (idx);
1277   ASSERT_BOUND_VARIABLE (v);
1278   PUSH (VARIABLE_REF (v));
1279   NEXT;
1280 }
1281
1282 VM_DEFINE_INSTRUCTION (73, free_boxed_set, "free-boxed-set", 1, 1, 0)
1283 {
1284   SCM v, val;
1285   scm_t_uint8 idx = FETCH ();
1286   POP (val);
1287   CHECK_FREE_VARIABLE (idx);
1288   v = FREE_VARIABLE_REF (idx);
1289   ASSERT_BOUND_VARIABLE (v);
1290   VARIABLE_SET (v, val);
1291   NEXT;
1292 }
1293
1294 VM_DEFINE_INSTRUCTION (74, make_closure, "make-closure", 0, 2, 1)
1295 {
1296   SCM vect;
1297   POP (vect);
1298   SYNC_BEFORE_GC ();
1299   /* fixme underflow */
1300   *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp),
1301                          (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect);
1302   NEXT;
1303 }
1304
1305 VM_DEFINE_INSTRUCTION (75, make_variable, "make-variable", 0, 0, 1)
1306 {
1307   SYNC_BEFORE_GC ();
1308   /* fixme underflow */
1309   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1310   NEXT;
1311 }
1312
1313 VM_DEFINE_INSTRUCTION (76, fix_closure, "fix-closure", 2, 0, 1)
1314 {
1315   SCM x, vect;
1316   unsigned int i = FETCH ();
1317   i <<= 8;
1318   i += FETCH ();
1319   POP (vect);
1320   /* FIXME CHECK_LOCAL (i) */
1321   x = LOCAL_REF (i);
1322   /* FIXME ASSERT_PROGRAM (x); */
1323   SCM_SET_CELL_WORD_3 (x, vect);
1324   NEXT;
1325 }
1326
1327 VM_DEFINE_INSTRUCTION (77, define, "define", 0, 0, 2)
1328 {
1329   SCM sym, val;
1330   POP (sym);
1331   POP (val);
1332   SYNC_REGISTER ();
1333   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1334                              SCM_BOOL_T),
1335                 val);
1336   NEXT;
1337 }
1338
1339 VM_DEFINE_INSTRUCTION (78, make_keyword, "make-keyword", 0, 1, 1)
1340 {
1341   CHECK_UNDERFLOW ();
1342   SYNC_REGISTER ();
1343   *sp = scm_symbol_to_keyword (*sp);
1344   NEXT;
1345 }
1346
1347 VM_DEFINE_INSTRUCTION (79, make_symbol, "make-symbol", 0, 1, 1)
1348 {
1349   CHECK_UNDERFLOW ();
1350   SYNC_REGISTER ();
1351   *sp = scm_string_to_symbol (*sp);
1352   NEXT;
1353 }
1354
1355
1356 /*
1357 (defun renumber-ops ()
1358   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1359   (interactive "")
1360   (save-excursion
1361     (let ((counter -1)) (goto-char (point-min))
1362       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1363         (replace-match
1364          (number-to-string (setq counter (1+ counter)))
1365           t t nil 1)))))
1366 (renumber-ops)
1367 */
1368 /*
1369   Local Variables:
1370   c-file-style: "gnu"
1371   End:
1372 */