libguile/vm-i-scheme.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 /* This file is included in vm_engine.c */
  20
  21 \f
  22 /*
  23  * Predicates
  24  */
  25
  26 #define ARGS1(a1)       SCM a1 = sp[0];
  27 #define ARGS2(a1,a2)    SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
  28 #define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
  29
  30 #define RETURN(x)       do { *sp = x; } while (0)
  31
  32 VM_DEFINE_FUNCTION (128, not, "not", 1)
  33 {
  34   ARGS1 (x);
  35   RETURN (scm_from_bool (scm_is_false (x)));
  36   NEXT;
  37 }
  38
  39 VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
  40 {
  41   ARGS1 (x);
  42   RETURN (scm_from_bool (!scm_is_false (x)));
  43   NEXT;
  44 }
  45
  46 VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
  47 {
  48   ARGS2 (x, y);
  49   RETURN (scm_from_bool (scm_is_eq (x, y)));
  50   NEXT;
  51 }
  52
  53 VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
  54 {
  55   ARGS2 (x, y);
  56   RETURN (scm_from_bool (!scm_is_eq (x, y)));
  57   NEXT;
  58 }
  59
  60 VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
  61 {
  62   ARGS1 (x);
  63   RETURN (scm_from_bool (scm_is_null (x)));
  64   NEXT;
  65 }
  66
  67 VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
  68 {
  69   ARGS1 (x);
  70   RETURN (scm_from_bool (!scm_is_null (x)));
  71   NEXT;
  72 }
  73
  74 VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
  75 {
  76   ARGS2 (x, y);
  77   if (scm_is_eq (x, y))
  78     RETURN (SCM_BOOL_T);
  79   else if (SCM_IMP (x) || SCM_IMP (y))
  80     RETURN (SCM_BOOL_F);
  81   else
  82     {
  83       SYNC_REGISTER ();
  84       RETURN (scm_eqv_p (x, y));
  85     }
  86   NEXT;
  87 }
  88
  89 VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
  90 {
  91   ARGS2 (x, y);
  92   if (scm_is_eq (x, y))
  93     RETURN (SCM_BOOL_T);
  94   else if (SCM_IMP (x) || SCM_IMP (y))
  95     RETURN (SCM_BOOL_F);
  96   else
  97     {
  98       SYNC_REGISTER ();
  99       RETURN (scm_equal_p (x, y));
 100     }
 101   NEXT;
 102 }
 103
 104 VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
 105 {
 106   ARGS1 (x);
 107   RETURN (scm_from_bool (scm_is_pair (x)));
 108   NEXT;
 109 }
 110
 111 VM_DEFINE_FUNCTION (137, listp, "list?", 1)
 112 {
 113   ARGS1 (x);
 114   RETURN (scm_from_bool (scm_ilength (x) >= 0));
 115   NEXT;
 116 }
 117
 118 VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
 119 {
 120   ARGS1 (x);
 121   RETURN (scm_from_bool (scm_is_symbol (x)));
 122   NEXT;
 123 }
 124
 125 VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
 126 {
 127   ARGS1 (x);
 128   RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
 129   NEXT;
 130 }
 131
 132 \f
 133 /*
 134  * Basic data
 135  */
 136
 137 VM_DEFINE_FUNCTION (140, cons, "cons", 2)
 138 {
 139   ARGS2 (x, y);
 140   CONS (x, x, y);
 141   RETURN (x);
 142   NEXT;
 143 }
 144
 145 #define VM_VALIDATE_CONS(x, proc)               \
 146   if (SCM_UNLIKELY (!scm_is_pair (x)))          \
 147     {                                           \
 148       func_name = proc;                         \
 149       finish_args = x;                          \
 150       goto vm_error_not_a_pair;                 \
 151     }
 152
 153 VM_DEFINE_FUNCTION (141, car, "car", 1)
 154 {
 155   ARGS1 (x);
 156   VM_VALIDATE_CONS (x, "car");
 157   RETURN (SCM_CAR (x));
 158   NEXT;
 159 }
 160
 161 VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
 162 {
 163   ARGS1 (x);
 164   VM_VALIDATE_CONS (x, "cdr");
 165   RETURN (SCM_CDR (x));
 166   NEXT;
 167 }
 168
 169 VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
 170 {
 171   SCM x, y;
 172   POP2 (y, x);
 173   VM_VALIDATE_CONS (x, "set-car!");
 174   SCM_SETCAR (x, y);
 175   NEXT;
 176 }
 177
 178 VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
 179 {
 180   SCM x, y;
 181   POP2 (y, x);
 182   VM_VALIDATE_CONS (x, "set-cdr!");
 183   SCM_SETCDR (x, y);
 184   NEXT;
 185 }
 186
 187 \f
 188 /*
 189  * Numeric relational tests
 190  */
 191
 192 #undef REL
 193 #define REL(crel,srel)                                                  \
 194   {                                                                     \
 195     ARGS2 (x, y);                                                       \
 196     if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                             \
 197       RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x))       \
 198                              crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
 199     else                                                                \
 200       {                                                                 \
 201         SYNC_REGISTER ();                                               \
 202         RETURN (srel (x, y));                                           \
 203       }                                                                 \
 204     NEXT;                                                               \
 205   }
 206
 207 VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
 208 {
 209   REL (==, scm_num_eq_p);
 210 }
 211
 212 VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
 213 {
 214   REL (<, scm_less_p);
 215 }
 216
 217 VM_DEFINE_FUNCTION (147, le, "le?", 2)
 218 {
 219   REL (<=, scm_leq_p);
 220 }
 221
 222 VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
 223 {
 224   REL (>, scm_gr_p);
 225 }
 226
 227 VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
 228 {
 229   REL (>=, scm_geq_p);
 230 }
 231
 232 \f
 233 /*
 234  * Numeric functions
 235  */
 236
 237 /* The maximum/minimum tagged integers.  */
 238 #undef INUM_MAX
 239 #undef INUM_MIN
 240 #define INUM_MAX (INTPTR_MAX - 1)
 241 #define INUM_MIN (INTPTR_MIN + scm_tc2_int)
 242
 243 #undef FUNC2
 244 #define FUNC2(CFUNC,SFUNC)                                      \
 245   {                                                             \
 246     ARGS2 (x, y);                                               \
 247     if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                     \
 248       {                                                         \
 249         scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);    \
 250         if (SCM_FIXABLE (n))                                    \
 251           {                                                     \
 252             RETURN (SCM_I_MAKINUM (n));                         \
 253             NEXT;                                               \
 254           }                                                     \
 255       }                                                         \
 256     SYNC_REGISTER ();                                           \
 257     RETURN (SFUNC (x, y));                                      \
 258     NEXT;                                                       \
 259   }
 260
 261 /* Assembly tagged integer arithmetic routines.  This code uses the
 262    `asm goto' feature introduced in GCC 4.5.  */
 263
 264 #if defined __x86_64__ && SCM_GNUC_PREREQ (4, 5)
 265
 266 /* The macros below check the CPU's overflow flag to improve fixnum
 267    arithmetic.  The %rcx register is explicitly clobbered because `asm
 268    goto' can't have outputs, in which case the `r' constraint could be
 269    used to let the register allocator choose a register.
 270
 271    TODO: Use `cold' label attribute in GCC 4.6.
 272    http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html  */
 273
 274 # define ASM_ADD(x, y)                                                  \
 275     {                                                                   \
 276       asm volatile goto ("mov %1, %%rcx; "                              \
 277                          "test %[tag], %%cl; je %l[slow_add]; "         \
 278                          "test %[tag], %0;   je %l[slow_add]; "         \
 279                          "add %0, %%rcx;     jo %l[slow_add]; "         \
 280                          "sub %[tag], %%rcx; "                          \
 281                          "mov %%rcx, (%[vsp])\n"                        \
 282                          : /* no outputs */                             \
 283                          : "r" (x), "r" (y),                            \
 284                            [vsp] "r" (sp), [tag] "i" (scm_tc2_int)      \
 285                          : "rcx", "memory"                              \
 286                          : slow_add);                                   \
 287       NEXT;                                                             \
 288     }                                                                   \
 289   slow_add:                                                             \
 290     do { } while (0)
 291
 292 # define ASM_SUB(x, y)                                                  \
 293     {                                                                   \
 294       asm volatile goto ("mov %0, %%rcx; "                              \
 295                          "test %[tag], %%cl; je %l[slow_sub]; "         \
 296                          "test %[tag], %1;   je %l[slow_sub]; "         \
 297                          "sub %1, %%rcx;     jo %l[slow_sub]; "         \
 298                          "add %[tag], %%rcx; "                          \
 299                          "mov %%rcx, (%[vsp])\n"                        \
 300                          : /* no outputs */                             \
 301                          : "r" (x), "r" (y),                            \
 302                            [vsp] "r" (sp), [tag] "i" (scm_tc2_int)      \
 303                          : "rcx", "memory"                              \
 304                          : slow_sub);                                   \
 305       NEXT;                                                             \
 306     }                                                                   \
 307   slow_sub:                                                             \
 308     do { } while (0)
 309
 310 #endif
 311
 312
 313 VM_DEFINE_FUNCTION (150, add, "add", 2)
 314 {
 315 #ifndef ASM_ADD
 316   FUNC2 (+, scm_sum);
 317 #else
 318   ARGS2 (x, y);
 319   ASM_ADD (x, y);
 320   SYNC_REGISTER ();
 321   RETURN (scm_sum (x, y));
 322   NEXT;
 323 #endif
 324 }
 325
 326 VM_DEFINE_FUNCTION (151, add1, "add1", 1)
 327 {
 328   ARGS1 (x);
 329
 330   /* Check for overflow.  */
 331   if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX))
 332     {
 333       SCM result;
 334
 335       /* Add the integers without untagging.  */
 336       result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
 337                          + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
 338                          - scm_tc2_int);
 339
 340       if (SCM_LIKELY (SCM_I_INUMP (result)))
 341         {
 342           RETURN (result);
 343           NEXT;
 344         }
 345     }
 346
 347   SYNC_REGISTER ();
 348   RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
 349   NEXT;
 350 }
 351
 352 VM_DEFINE_FUNCTION (152, sub, "sub", 2)
 353 {
 354 #ifndef ASM_SUB
 355   FUNC2 (-, scm_difference);
 356 #else
 357   ARGS2 (x, y);
 358   ASM_SUB (x, y);
 359   SYNC_REGISTER ();
 360   RETURN (scm_difference (x, y));
 361   NEXT;
 362 #endif
 363 }
 364
 365 VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
 366 {
 367   ARGS1 (x);
 368
 369   /* Check for underflow.  */
 370   if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN))
 371     {
 372       SCM result;
 373
 374       /* Substract the integers without untagging.  */
 375       result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
 376                          - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
 377                          + scm_tc2_int);
 378
 379       if (SCM_LIKELY (SCM_I_INUMP (result)))
 380         {
 381           RETURN (result);
 382           NEXT;
 383         }
 384     }
 385
 386   SYNC_REGISTER ();
 387   RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
 388   NEXT;
 389 }
 390
 391 # undef ASM_ADD
 392 # undef ASM_SUB
 393
 394 VM_DEFINE_FUNCTION (154, mul, "mul", 2)
 395 {
 396   ARGS2 (x, y);
 397   SYNC_REGISTER ();
 398   RETURN (scm_product (x, y));
 399   NEXT;
 400 }
 401
 402 VM_DEFINE_FUNCTION (155, div, "div", 2)
 403 {
 404   ARGS2 (x, y);
 405   SYNC_REGISTER ();
 406   RETURN (scm_divide (x, y));
 407   NEXT;
 408 }
 409
 410 VM_DEFINE_FUNCTION (156, quo, "quo", 2)
 411 {
 412   ARGS2 (x, y);
 413   SYNC_REGISTER ();
 414   RETURN (scm_quotient (x, y));
 415   NEXT;
 416 }
 417
 418 VM_DEFINE_FUNCTION (157, rem, "rem", 2)
 419 {
 420   ARGS2 (x, y);
 421   SYNC_REGISTER ();
 422   RETURN (scm_remainder (x, y));
 423   NEXT;
 424 }
 425
 426 VM_DEFINE_FUNCTION (158, mod, "mod", 2)
 427 {
 428   ARGS2 (x, y);
 429   SYNC_REGISTER ();
 430   RETURN (scm_modulo (x, y));
 431   NEXT;
 432 }
 433
 434 VM_DEFINE_FUNCTION (159, ash, "ash", 2)
 435 {
 436   ARGS2 (x, y);
 437   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 438     {
 439       if (SCM_I_INUM (y) < 0)
 440         /* Right shift, will be a fixnum. */
 441         {
 442           RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
 443           NEXT;
 444         }
 445       else
 446         /* Left shift. See comments in scm_ash. */
 447         {
 448           scm_t_signed_bits nn, bits_to_shift;
 449
 450           nn = SCM_I_INUM (x);
 451           bits_to_shift = SCM_I_INUM (y);
 452
 453           if (bits_to_shift < SCM_I_FIXNUM_BIT-1
 454               && ((scm_t_bits)
 455                   (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
 456                   <= 1))
 457             {
 458               RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
 459               NEXT;
 460             }
 461           /* fall through */
 462         }
 463       /* fall through */
 464     }
 465   SYNC_REGISTER ();
 466   RETURN (scm_ash (x, y));
 467   NEXT;
 468 }
 469
 470 VM_DEFINE_FUNCTION (160, logand, "logand", 2)
 471 {
 472   ARGS2 (x, y);
 473   if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y)))
 474     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
 475   else
 476     {
 477       SYNC_REGISTER ();
 478       RETURN (scm_logand (x, y));
 479     }
 480   NEXT;
 481 }
 482
 483 VM_DEFINE_FUNCTION (161, logior, "logior", 2)
 484 {
 485   ARGS2 (x, y);
 486   if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y)))
 487     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
 488   else
 489     {
 490       SYNC_REGISTER ();
 491       RETURN (scm_logior (x, y));
 492     }
 493   NEXT;
 494 }
 495
 496 VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
 497 {
 498   ARGS2 (x, y);
 499   if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y)))
 500     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
 501   else
 502     {
 503       SYNC_REGISTER ();
 504       RETURN (scm_logxor (x, y));
 505     }
 506   NEXT;
 507 }
 508
 509 \f
 510 /*
 511  * Vectors and arrays
 512  */
 513
 514 VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
 515 {
 516   scm_t_signed_bits i = 0;
 517   ARGS2 (vect, idx);
 518   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 519                   && SCM_I_INUMP (idx)
 520                   && ((i = SCM_I_INUM (idx)) >= 0)
 521                   && i < SCM_I_VECTOR_LENGTH (vect)))
 522     RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
 523   else
 524     {
 525       SYNC_REGISTER ();
 526       RETURN (scm_vector_ref (vect, idx));
 527     }
 528   NEXT;
 529 }
 530
 531 VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
 532 {
 533   scm_t_signed_bits i = 0;
 534   SCM vect, idx, val;
 535   POP3 (val, idx, vect);
 536   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 537                   && SCM_I_INUMP (idx)
 538                   && ((i = SCM_I_INUM (idx)) >= 0)
 539                   && i < SCM_I_VECTOR_LENGTH (vect)))
 540     SCM_I_VECTOR_WELTS (vect)[i] = val;
 541   else
 542     {
 543       SYNC_REGISTER ();
 544       scm_vector_set_x (vect, idx, val);
 545     }
 546   NEXT;
 547 }
 548
 549 VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
 550 {
 551   scm_t_uint32 len;
 552   SCM shape, ret;
 553
 554   len = FETCH ();
 555   len = (len << 8) + FETCH ();
 556   len = (len << 8) + FETCH ();
 557   POP (shape);
 558   SYNC_REGISTER ();
 559   PRE_CHECK_UNDERFLOW (len);
 560   ret = scm_from_contiguous_array (shape, sp - len + 1, len);
 561   DROPN (len);
 562   PUSH (ret);
 563   NEXT;
 564 }
 565
 566 \f
 567 /*
 568  * Structs
 569  */
 570 #define VM_VALIDATE_STRUCT(obj, proc)           \
 571   if (SCM_UNLIKELY (!SCM_STRUCTP (obj)))        \
 572     {                                           \
 573       func_name = proc;                         \
 574       finish_args = (obj);                      \
 575       goto vm_error_not_a_struct;               \
 576     }
 577
 578 VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
 579 {
 580   ARGS1 (obj);
 581   RETURN (scm_from_bool (SCM_STRUCTP (obj)));
 582   NEXT;
 583 }
 584
 585 VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
 586 {
 587   ARGS1 (obj);
 588   VM_VALIDATE_STRUCT (obj, "struct_vtable");
 589   RETURN (SCM_STRUCT_VTABLE (obj));
 590   NEXT;
 591 }
 592
 593 VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
 594 {
 595   unsigned h = FETCH ();
 596   unsigned l = FETCH ();
 597   scm_t_bits n = ((h << 8U) + l);
 598   SCM vtable = sp[-(n - 1)];
 599   const SCM *inits = sp - n + 2;
 600   SCM ret;
 601
 602   SYNC_REGISTER ();
 603
 604   if (SCM_LIKELY (SCM_STRUCTP (vtable)
 605                   && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
 606                   && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
 607                       == n)
 608                   && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
 609     {
 610       /* Verily, we are making a simple struct with the right number of
 611          initializers, and no finalizer. */
 612       ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
 613                        n + 1);
 614       SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
 615       memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
 616     }
 617   else
 618     ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
 619
 620   DROPN (n);
 621   PUSH (ret);
 622
 623   NEXT;
 624 }
 625
 626 VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
 627 {
 628   ARGS2 (obj, pos);
 629
 630   if (SCM_LIKELY (SCM_STRUCTP (obj)
 631                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 632                                                     SCM_VTABLE_FLAG_SIMPLE)
 633                   && SCM_I_INUMP (pos)))
 634     {
 635       SCM vtable;
 636       scm_t_bits index, len;
 637
 638       /* True, an inum is a signed value, but cast to unsigned it will
 639          certainly be more than the length, so we will fall through if
 640          index is negative. */
 641       index = SCM_I_INUM (pos);
 642       vtable = SCM_STRUCT_VTABLE (obj);
 643       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 644
 645       if (SCM_LIKELY (index < len))
 646         {
 647           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 648           RETURN (SCM_PACK (data[index]));
 649           NEXT;
 650         }
 651     }
 652
 653   SYNC_REGISTER ();
 654   RETURN (scm_struct_ref (obj, pos));
 655   NEXT;
 656 }
 657
 658 VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
 659 {
 660   ARGS3 (obj, pos, val);
 661
 662   if (SCM_LIKELY (SCM_STRUCTP (obj)
 663                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 664                                                     SCM_VTABLE_FLAG_SIMPLE)
 665                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 666                                                     SCM_VTABLE_FLAG_SIMPLE_RW)
 667                   && SCM_I_INUMP (pos)))
 668     {
 669       SCM vtable;
 670       scm_t_bits index, len;
 671
 672       /* See above regarding index being >= 0. */
 673       index = SCM_I_INUM (pos);
 674       vtable = SCM_STRUCT_VTABLE (obj);
 675       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 676       if (SCM_LIKELY (index < len))
 677         {
 678           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 679           data[index] = SCM_UNPACK (val);
 680           RETURN (val);
 681           NEXT;
 682         }
 683     }
 684
 685   SYNC_REGISTER ();
 686   RETURN (scm_struct_set_x (obj, pos, val));
 687   NEXT;
 688 }
 689
 690 \f
 691 /*
 692  * GOOPS support
 693  */
 694 VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
 695 {
 696   ARGS1 (obj);
 697   if (SCM_INSTANCEP (obj))
 698     RETURN (SCM_CLASS_OF (obj));
 699   else
 700     {
 701       SYNC_REGISTER ();
 702       RETURN (scm_class_of (obj));
 703     }
 704   NEXT;
 705 }
 706
 707 /* FIXME: No checking whatsoever. */
 708 VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
 709 {
 710   size_t slot;
 711   ARGS2 (instance, idx);
 712   slot = SCM_I_INUM (idx);
 713   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 714   NEXT;
 715 }
 716
 717 /* FIXME: No checking whatsoever. */
 718 VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
 719 {
 720   SCM instance, idx, val;
 721   size_t slot;
 722   POP3 (val, idx, instance);
 723   slot = SCM_I_INUM (idx);
 724   SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
 725   NEXT;
 726 }
 727
 728 \f
 729 /*
 730  * Bytevectors
 731  */
 732 #define VM_VALIDATE_BYTEVECTOR(x, proc)         \
 733   do                                            \
 734     {                                           \
 735       if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
 736         {                                       \
 737           func_name = proc;                     \
 738           finish_args = x;                      \
 739           goto vm_error_not_a_bytevector;       \
 740         }                                       \
 741     }                                           \
 742   while (0)
 743
 744 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
 745 {                                                                       \
 746   SCM endianness;                                                       \
 747   POP (endianness);                                                     \
 748   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 749     goto VM_LABEL (bv_##stem##_native_ref);                             \
 750   {                                                                     \
 751     ARGS2 (bv, idx);                                                    \
 752     SYNC_REGISTER ();                                                   \
 753     RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness));      \
 754     NEXT;                                                               \
 755   }                                                                     \
 756 }
 757
 758 /* Return true (non-zero) if PTR has suitable alignment for TYPE.  */
 759 #define ALIGNED_P(ptr, type)                    \
 760   ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
 761
 762 VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
 763 BV_REF_WITH_ENDIANNESS (u16, u16)
 764 VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
 765 BV_REF_WITH_ENDIANNESS (s16, s16)
 766 VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
 767 BV_REF_WITH_ENDIANNESS (u32, u32)
 768 VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
 769 BV_REF_WITH_ENDIANNESS (s32, s32)
 770 VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
 771 BV_REF_WITH_ENDIANNESS (u64, u64)
 772 VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
 773 BV_REF_WITH_ENDIANNESS (s64, s64)
 774 VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
 775 BV_REF_WITH_ENDIANNESS (f32, ieee_single)
 776 VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
 777 BV_REF_WITH_ENDIANNESS (f64, ieee_double)
 778
 779 #undef BV_REF_WITH_ENDIANNESS
 780
 781 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size)                   \
 782 {                                                                       \
 783   scm_t_signed_bits i;                                                  \
 784   const scm_t_ ## type *int_ptr;                                        \
 785   ARGS2 (bv, idx);                                                      \
 786                                                                         \
 787   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 788   i = SCM_I_INUM (idx);                                                 \
 789   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 790                                                                         \
 791   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 792                   && (i >= 0)                                           \
 793                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 794                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 795     RETURN (SCM_I_MAKINUM (*int_ptr));                                  \
 796   else                                                                  \
 797     {                                                                   \
 798       SYNC_REGISTER ();                                                 \
 799       RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx));            \
 800     }                                                                   \
 801   NEXT;                                                                 \
 802 }
 803
 804 #define BV_INT_REF(stem, type, size)                                    \
 805 {                                                                       \
 806   scm_t_signed_bits i;                                                  \
 807   const scm_t_ ## type *int_ptr;                                        \
 808   ARGS2 (bv, idx);                                                      \
 809                                                                         \
 810   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 811   i = SCM_I_INUM (idx);                                                 \
 812   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 813                                                                         \
 814   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 815                   && (i >= 0)                                           \
 816                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 817                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 818     {                                                                   \
 819       scm_t_ ## type x = *int_ptr;                                      \
 820       if (SCM_FIXABLE (x))                                              \
 821         RETURN (SCM_I_MAKINUM (x));                                     \
 822       else                                                              \
 823         {                                                               \
 824           SYNC_REGISTER ();                                             \
 825           RETURN (scm_from_ ## type (x));                               \
 826         }                                                               \
 827     }                                                                   \
 828   else                                                                  \
 829     {                                                                   \
 830       SYNC_REGISTER ();                                                 \
 831       RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx));        \
 832     }                                                                   \
 833   NEXT;                                                                 \
 834 }
 835
 836 #define BV_FLOAT_REF(stem, fn_stem, type, size)                         \
 837 {                                                                       \
 838   scm_t_signed_bits i;                                                  \
 839   const type *float_ptr;                                                \
 840   ARGS2 (bv, idx);                                                      \
 841                                                                         \
 842   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
 843   i = SCM_I_INUM (idx);                                                 \
 844   float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);              \
 845                                                                         \
 846   SYNC_REGISTER ();                                                     \
 847   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 848                   && (i >= 0)                                           \
 849                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 850                   && (ALIGNED_P (float_ptr, type))))                    \
 851     RETURN (scm_from_double (*float_ptr));                              \
 852   else                                                                  \
 853     RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx));       \
 854   NEXT;                                                                 \
 855 }
 856
 857 VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
 858 BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
 859 VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
 860 BV_FIXABLE_INT_REF (s8, s8, int8, 1)
 861 VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
 862 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
 863 VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
 864 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
 865 VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
 866 #if SIZEOF_VOID_P > 4
 867 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
 868 #else
 869 BV_INT_REF (u32, uint32, 4)
 870 #endif
 871 VM_DEFINE_FUNCTION (187, bv_s32_native_ref, "bv-s32-native-ref", 2)
 872 #if SIZEOF_VOID_P > 4
 873 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
 874 #else
 875 BV_INT_REF (s32, int32, 4)
 876 #endif
 877 VM_DEFINE_FUNCTION (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
 878 BV_INT_REF (u64, uint64, 8)
 879 VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
 880 BV_INT_REF (s64, int64, 8)
 881 VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
 882 BV_FLOAT_REF (f32, ieee_single, float, 4)
 883 VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
 884 BV_FLOAT_REF (f64, ieee_double, double, 8)
 885
 886 #undef BV_FIXABLE_INT_REF
 887 #undef BV_INT_REF
 888 #undef BV_FLOAT_REF
 889
 890
 891
 892 #define BV_SET_WITH_ENDIANNESS(stem, fn_stem)                           \
 893 {                                                                       \
 894   SCM endianness;                                                       \
 895   POP (endianness);                                                     \
 896   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 897     goto VM_LABEL (bv_##stem##_native_set);                             \
 898   {                                                                     \
 899     SCM bv, idx, val; POP3 (val, idx, bv);                              \
 900     SYNC_REGISTER ();                                                   \
 901     scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness);        \
 902     NEXT;                                                               \
 903   }                                                                     \
 904 }
 905
 906 VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
 907 BV_SET_WITH_ENDIANNESS (u16, u16)
 908 VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
 909 BV_SET_WITH_ENDIANNESS (s16, s16)
 910 VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
 911 BV_SET_WITH_ENDIANNESS (u32, u32)
 912 VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
 913 BV_SET_WITH_ENDIANNESS (s32, s32)
 914 VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
 915 BV_SET_WITH_ENDIANNESS (u64, u64)
 916 VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
 917 BV_SET_WITH_ENDIANNESS (s64, s64)
 918 VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
 919 BV_SET_WITH_ENDIANNESS (f32, ieee_single)
 920 VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
 921 BV_SET_WITH_ENDIANNESS (f64, ieee_double)
 922
 923 #undef BV_SET_WITH_ENDIANNESS
 924
 925 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size)         \
 926 {                                                                       \
 927   scm_t_signed_bits i, j = 0;                                           \
 928   SCM bv, idx, val;                                                     \
 929   scm_t_ ## type *int_ptr;                                              \
 930                                                                         \
 931   POP3 (val, idx, bv);                                                  \
 932   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 933   i = SCM_I_INUM (idx);                                                 \
 934   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 935                                                                         \
 936   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 937                   && (i >= 0)                                           \
 938                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 939                   && (ALIGNED_P (int_ptr, scm_t_ ## type))              \
 940                   && (SCM_I_INUMP (val))                                \
 941                   && ((j = SCM_I_INUM (val)) >= min)                    \
 942                   && (j <= max)))                                       \
 943     *int_ptr = (scm_t_ ## type) j;                                      \
 944   else                                                                  \
 945     {                                                                   \
 946       SYNC_REGISTER ();                                                 \
 947       scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val);              \
 948     }                                                                   \
 949   NEXT;                                                                 \
 950 }
 951
 952 #define BV_INT_SET(stem, type, size)                                    \
 953 {                                                                       \
 954   scm_t_signed_bits i = 0;                                              \
 955   SCM bv, idx, val;                                                     \
 956   scm_t_ ## type *int_ptr;                                              \
 957                                                                         \
 958   POP3 (val, idx, bv);                                                  \
 959   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 960   i = SCM_I_INUM (idx);                                                 \
 961   int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);      \
 962                                                                         \
 963   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 964                   && (i >= 0)                                           \
 965                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 966                   && (ALIGNED_P (int_ptr, scm_t_ ## type))))            \
 967     *int_ptr = scm_to_ ## type (val);                                   \
 968   else                                                                  \
 969     {                                                                   \
 970       SYNC_REGISTER ();                                                 \
 971       scm_bytevector_ ## stem ## _native_set_x (bv, idx, val);          \
 972     }                                                                   \
 973   NEXT;                                                                 \
 974 }
 975
 976 #define BV_FLOAT_SET(stem, fn_stem, type, size)                         \
 977 {                                                                       \
 978   scm_t_signed_bits i = 0;                                              \
 979   SCM bv, idx, val;                                                     \
 980   type *float_ptr;                                                      \
 981                                                                         \
 982   POP3 (val, idx, bv);                                                  \
 983   VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
 984   i = SCM_I_INUM (idx);                                                 \
 985   float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);              \
 986                                                                         \
 987   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 988                   && (i >= 0)                                           \
 989                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 990                   && (ALIGNED_P (float_ptr, type))))                    \
 991     *float_ptr = scm_to_double (val);                                   \
 992   else                                                                  \
 993     {                                                                   \
 994       SYNC_REGISTER ();                                                 \
 995       scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val);       \
 996     }                                                                   \
 997   NEXT;                                                                 \
 998 }
 999
1000 VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
1001 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
1002 VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
1003 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
1004 VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
1005 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
1006 VM_DEFINE_INSTRUCTION (203, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
1007 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
1008 VM_DEFINE_INSTRUCTION (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
1009 #if SIZEOF_VOID_P > 4
1010 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
1011 #else
1012 BV_INT_SET (u32, uint32, 4)
1013 #endif
1014 VM_DEFINE_INSTRUCTION (205, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
1015 #if SIZEOF_VOID_P > 4
1016 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
1017 #else
1018 BV_INT_SET (s32, int32, 4)
1019 #endif
1020 VM_DEFINE_INSTRUCTION (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
1021 BV_INT_SET (u64, uint64, 8)
1022 VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
1023 BV_INT_SET (s64, int64, 8)
1024 VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
1025 BV_FLOAT_SET (f32, ieee_single, float, 4)
1026 VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
1027 BV_FLOAT_SET (f64, ieee_double, double, 8)
1028
1029 #undef BV_FIXABLE_INT_SET
1030 #undef BV_INT_SET
1031 #undef BV_FLOAT_SET
1032
1033 /*
1034 (defun renumber-ops ()
1035   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1036   (interactive "")
1037   (save-excursion
1038     (let ((counter 127)) (goto-char (point-min))
1039       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1040         (replace-match
1041          (number-to-string (setq counter (1+ counter)))
1042           t t nil 1)))))
1043 */
1044
1045 /*
1046   Local Variables:
1047   c-file-style: "gnu"
1048   End:
1049 */