libguile/vm-i-scheme.c

   1 /* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 /* 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; NEXT; } 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 }
  37
  38 VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
  39 {
  40   ARGS1 (x);
  41   RETURN (scm_from_bool (!scm_is_false (x)));
  42 }
  43
  44 VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
  45 {
  46   ARGS2 (x, y);
  47   RETURN (scm_from_bool (scm_is_eq (x, y)));
  48 }
  49
  50 VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
  51 {
  52   ARGS2 (x, y);
  53   RETURN (scm_from_bool (!scm_is_eq (x, y)));
  54 }
  55
  56 VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
  57 {
  58   ARGS1 (x);
  59   RETURN (scm_from_bool (scm_is_null (x)));
  60 }
  61
  62 VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
  63 {
  64   ARGS1 (x);
  65   RETURN (scm_from_bool (!scm_is_null (x)));
  66 }
  67
  68 VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
  69 {
  70   ARGS2 (x, y);
  71   if (scm_is_eq (x, y))
  72     RETURN (SCM_BOOL_T);
  73   if (SCM_IMP (x) || SCM_IMP (y))
  74     RETURN (SCM_BOOL_F);
  75   SYNC_REGISTER ();
  76   RETURN (scm_eqv_p (x, y));
  77 }
  78
  79 VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
  80 {
  81   ARGS2 (x, y);
  82   if (scm_is_eq (x, y))
  83     RETURN (SCM_BOOL_T);
  84   if (SCM_IMP (x) || SCM_IMP (y))
  85     RETURN (SCM_BOOL_F);
  86   SYNC_REGISTER ();
  87   RETURN (scm_equal_p (x, y));
  88 }
  89
  90 VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
  91 {
  92   ARGS1 (x);
  93   RETURN (scm_from_bool (scm_is_pair (x)));
  94 }
  95
  96 VM_DEFINE_FUNCTION (137, listp, "list?", 1)
  97 {
  98   ARGS1 (x);
  99   RETURN (scm_from_bool (scm_ilength (x) >= 0));
 100 }
 101
 102 \f
 103 /*
 104  * Basic data
 105  */
 106
 107 VM_DEFINE_FUNCTION (138, cons, "cons", 2)
 108 {
 109   ARGS2 (x, y);
 110   CONS (x, x, y);
 111   RETURN (x);
 112 }
 113
 114 #define VM_VALIDATE_CONS(x)                     \
 115   if (SCM_UNLIKELY (!scm_is_pair (x)))          \
 116     { finish_args = x;                          \
 117       goto vm_error_not_a_pair;                 \
 118     }
 119
 120 VM_DEFINE_FUNCTION (139, car, "car", 1)
 121 {
 122   ARGS1 (x);
 123   VM_VALIDATE_CONS (x);
 124   RETURN (SCM_CAR (x));
 125 }
 126
 127 VM_DEFINE_FUNCTION (140, cdr, "cdr", 1)
 128 {
 129   ARGS1 (x);
 130   VM_VALIDATE_CONS (x);
 131   RETURN (SCM_CDR (x));
 132 }
 133
 134 VM_DEFINE_INSTRUCTION (141, set_car, "set-car!", 0, 2, 0)
 135 {
 136   SCM x, y;
 137   POP (y);
 138   POP (x);
 139   VM_VALIDATE_CONS (x);
 140   SCM_SETCAR (x, y);
 141   NEXT;
 142 }
 143
 144 VM_DEFINE_INSTRUCTION (142, set_cdr, "set-cdr!", 0, 2, 0)
 145 {
 146   SCM x, y;
 147   POP (y);
 148   POP (x);
 149   VM_VALIDATE_CONS (x);
 150   SCM_SETCDR (x, y);
 151   NEXT;
 152 }
 153
 154 \f
 155 /*
 156  * Numeric relational tests
 157  */
 158
 159 #undef REL
 160 #define REL(crel,srel)                                          \
 161 {                                                               \
 162   ARGS2 (x, y);                                                 \
 163   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))                       \
 164     RETURN (scm_from_bool (SCM_I_INUM (x) crel SCM_I_INUM (y)));  \
 165   SYNC_REGISTER ();                                             \
 166   RETURN (srel (x, y));                                         \
 167 }
 168
 169 VM_DEFINE_FUNCTION (143, ee, "ee?", 2)
 170 {
 171   REL (==, scm_num_eq_p);
 172 }
 173
 174 VM_DEFINE_FUNCTION (144, lt, "lt?", 2)
 175 {
 176   REL (<, scm_less_p);
 177 }
 178
 179 VM_DEFINE_FUNCTION (145, le, "le?", 2)
 180 {
 181   REL (<=, scm_leq_p);
 182 }
 183
 184 VM_DEFINE_FUNCTION (146, gt, "gt?", 2)
 185 {
 186   REL (>, scm_gr_p);
 187 }
 188
 189 VM_DEFINE_FUNCTION (147, ge, "ge?", 2)
 190 {
 191   REL (>=, scm_geq_p);
 192 }
 193
 194 \f
 195 /*
 196  * Numeric functions
 197  */
 198
 199 #undef FUNC2
 200 #define FUNC2(CFUNC,SFUNC)                              \
 201 {                                                       \
 202   ARGS2 (x, y);                                         \
 203   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))               \
 204     {                                                   \
 205       scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
 206       if (SCM_FIXABLE (n))                              \
 207         RETURN (SCM_I_MAKINUM (n));                     \
 208     }                                                   \
 209   SYNC_REGISTER ();                                     \
 210   RETURN (SFUNC (x, y));                                \
 211 }
 212
 213 VM_DEFINE_FUNCTION (148, add, "add", 2)
 214 {
 215   FUNC2 (+, scm_sum);
 216 }
 217
 218 VM_DEFINE_FUNCTION (149, add1, "add1", 1)
 219 {
 220   ARGS1 (x);
 221   if (SCM_I_INUMP (x))
 222     {
 223       scm_t_int64 n = SCM_I_INUM (x) + 1;
 224       if (SCM_FIXABLE (n))
 225         RETURN (SCM_I_MAKINUM (n));
 226     }
 227   SYNC_REGISTER ();
 228   RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
 229 }
 230
 231 VM_DEFINE_FUNCTION (150, sub, "sub", 2)
 232 {
 233   FUNC2 (-, scm_difference);
 234 }
 235
 236 VM_DEFINE_FUNCTION (151, sub1, "sub1", 1)
 237 {
 238   ARGS1 (x);
 239   if (SCM_I_INUMP (x))
 240     {
 241       scm_t_int64 n = SCM_I_INUM (x) - 1;
 242       if (SCM_FIXABLE (n))
 243         RETURN (SCM_I_MAKINUM (n));
 244     }
 245   SYNC_REGISTER ();
 246   RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
 247 }
 248
 249 VM_DEFINE_FUNCTION (152, mul, "mul", 2)
 250 {
 251   ARGS2 (x, y);
 252   SYNC_REGISTER ();
 253   RETURN (scm_product (x, y));
 254 }
 255
 256 VM_DEFINE_FUNCTION (153, div, "div", 2)
 257 {
 258   ARGS2 (x, y);
 259   SYNC_REGISTER ();
 260   RETURN (scm_divide (x, y));
 261 }
 262
 263 VM_DEFINE_FUNCTION (154, quo, "quo", 2)
 264 {
 265   ARGS2 (x, y);
 266   SYNC_REGISTER ();
 267   RETURN (scm_quotient (x, y));
 268 }
 269
 270 VM_DEFINE_FUNCTION (155, rem, "rem", 2)
 271 {
 272   ARGS2 (x, y);
 273   SYNC_REGISTER ();
 274   RETURN (scm_remainder (x, y));
 275 }
 276
 277 VM_DEFINE_FUNCTION (156, mod, "mod", 2)
 278 {
 279   ARGS2 (x, y);
 280   SYNC_REGISTER ();
 281   RETURN (scm_modulo (x, y));
 282 }
 283
 284 VM_DEFINE_FUNCTION (157, ash, "ash", 2)
 285 {
 286   ARGS2 (x, y);
 287   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 288     {
 289       if (SCM_I_INUM (y) < 0)
 290         /* Right shift, will be a fixnum. */
 291         RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
 292       else
 293         /* Left shift. See comments in scm_ash. */
 294         {
 295           long nn, bits_to_shift;
 296
 297           nn = SCM_I_INUM (x);
 298           bits_to_shift = SCM_I_INUM (y);
 299
 300           if (bits_to_shift < SCM_I_FIXNUM_BIT-1
 301               && ((unsigned long)
 302                   (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
 303                   <= 1))
 304             RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
 305           /* fall through */
 306         }
 307       /* fall through */
 308     }
 309   SYNC_REGISTER ();
 310   RETURN (scm_ash (x, y));
 311 }
 312
 313 VM_DEFINE_FUNCTION (158, logand, "logand", 2)
 314 {
 315   ARGS2 (x, y);
 316   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 317     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
 318   SYNC_REGISTER ();
 319   RETURN (scm_logand (x, y));
 320 }
 321
 322 VM_DEFINE_FUNCTION (159, logior, "logior", 2)
 323 {
 324   ARGS2 (x, y);
 325   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 326     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
 327   SYNC_REGISTER ();
 328   RETURN (scm_logior (x, y));
 329 }
 330
 331 VM_DEFINE_FUNCTION (160, logxor, "logxor", 2)
 332 {
 333   ARGS2 (x, y);
 334   if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
 335     RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
 336   SYNC_REGISTER ();
 337   RETURN (scm_logxor (x, y));
 338 }
 339
 340 \f
 341 /*
 342  * Vectors and arrays
 343  */
 344
 345 VM_DEFINE_FUNCTION (161, vector_ref, "vector-ref", 2)
 346 {
 347   long i = 0;
 348   ARGS2 (vect, idx);
 349   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 350                   && SCM_I_INUMP (idx)
 351                   && ((i = SCM_I_INUM (idx)) >= 0)
 352                   && i < SCM_I_VECTOR_LENGTH (vect)))
 353     RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
 354   else
 355     {
 356       SYNC_REGISTER ();
 357       RETURN (scm_vector_ref (vect, idx));
 358     }
 359 }
 360
 361 VM_DEFINE_INSTRUCTION (162, vector_set, "vector-set", 0, 3, 0)
 362 {
 363   long i = 0;
 364   SCM vect, idx, val;
 365   POP (val); POP (idx); POP (vect);
 366   if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
 367                   && SCM_I_INUMP (idx)
 368                   && ((i = SCM_I_INUM (idx)) >= 0)
 369                   && i < SCM_I_VECTOR_LENGTH (vect)))
 370     SCM_I_VECTOR_WELTS (vect)[i] = val;
 371   else
 372     {
 373       SYNC_REGISTER ();
 374       scm_vector_set_x (vect, idx, val);
 375     }
 376   NEXT;
 377 }
 378
 379 VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3, -1, 1)
 380 {
 381   scm_t_uint32 len;
 382   SCM shape, ret;
 383
 384   len = FETCH ();
 385   len = (len << 8) + FETCH ();
 386   len = (len << 8) + FETCH ();
 387   POP (shape);
 388   SYNC_REGISTER ();
 389   PRE_CHECK_UNDERFLOW (len);
 390   ret = scm_from_contiguous_array (shape, sp - len + 1, len);
 391   DROPN (len);
 392   PUSH (ret);
 393   NEXT;
 394 }
 395
 396 \f
 397 /*
 398  * Structs
 399  */
 400 #define VM_VALIDATE_STRUCT(obj)                 \
 401   if (SCM_UNLIKELY (!SCM_STRUCTP (obj)))        \
 402     {                                           \
 403       finish_args = (obj);                      \
 404       goto vm_error_not_a_struct;               \
 405     }
 406
 407 VM_DEFINE_FUNCTION (164, struct_p, "struct?", 1)
 408 {
 409   ARGS1 (obj);
 410   RETURN (scm_from_bool (SCM_STRUCTP (obj)));
 411 }
 412
 413 VM_DEFINE_FUNCTION (165, struct_vtable, "struct-vtable", 1)
 414 {
 415   ARGS1 (obj);
 416   VM_VALIDATE_STRUCT (obj);
 417   RETURN (SCM_STRUCT_VTABLE (obj));
 418 }
 419
 420 VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1)
 421 {
 422   unsigned h = FETCH ();
 423   unsigned l = FETCH ();
 424   scm_t_bits n = ((h << 8U) + l);
 425   SCM vtable = sp[-(n - 1)];
 426   const SCM *inits = sp - n + 2;
 427   SCM ret;
 428
 429   SYNC_REGISTER ();
 430
 431   if (SCM_LIKELY (SCM_STRUCTP (vtable)
 432                   && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
 433                   && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
 434                       == n)
 435                   && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
 436     {
 437       /* Verily, we are making a simple struct with the right number of
 438          initializers, and no finalizer. */
 439       ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
 440                        n + 1);
 441       SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
 442       memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
 443     }
 444   else
 445     ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
 446
 447   DROPN (n);
 448   PUSH (ret);
 449
 450   NEXT;
 451 }
 452
 453 VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2)
 454 {
 455   ARGS2 (obj, pos);
 456
 457   if (SCM_LIKELY (SCM_STRUCTP (obj)
 458                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 459                                                     SCM_VTABLE_FLAG_SIMPLE)
 460                   && SCM_I_INUMP (pos)))
 461     {
 462       SCM vtable;
 463       scm_t_bits index, len;
 464
 465       index = SCM_I_INUM (pos);
 466       vtable = SCM_STRUCT_VTABLE (obj);
 467       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 468
 469       if (SCM_LIKELY (index < len))
 470         {
 471           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 472           RETURN (SCM_PACK (data[index]));
 473         }
 474     }
 475
 476   SYNC_REGISTER ();
 477   RETURN (scm_struct_ref (obj, pos));
 478 }
 479
 480 VM_DEFINE_FUNCTION (168, struct_set, "struct-set", 3)
 481 {
 482   ARGS3 (obj, pos, val);
 483
 484   if (SCM_LIKELY (SCM_STRUCTP (obj)
 485                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 486                                                     SCM_VTABLE_FLAG_SIMPLE)
 487                   && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
 488                                                     SCM_VTABLE_FLAG_SIMPLE_RW)
 489                   && SCM_I_INUMP (pos)))
 490     {
 491       SCM vtable;
 492       scm_t_bits index, len;
 493
 494       index = SCM_I_INUM (pos);
 495       vtable = SCM_STRUCT_VTABLE (obj);
 496       len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
 497       if (SCM_LIKELY (index < len))
 498         {
 499           scm_t_bits *data = SCM_STRUCT_DATA (obj);
 500           data[index] = SCM_UNPACK (val);
 501           RETURN (val);
 502         }
 503     }
 504
 505   SYNC_REGISTER ();
 506   RETURN (scm_struct_set_x (obj, pos, val));
 507 }
 508
 509 \f
 510 /*
 511  * GOOPS support
 512  */
 513 VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
 514 {
 515   ARGS1 (obj);
 516   if (SCM_INSTANCEP (obj))
 517     RETURN (SCM_CLASS_OF (obj));
 518   SYNC_REGISTER ();
 519   RETURN (scm_class_of (obj));
 520 }
 521
 522 VM_DEFINE_FUNCTION (170, slot_ref, "slot-ref", 2)
 523 {
 524   size_t slot;
 525   ARGS2 (instance, idx);
 526   slot = SCM_I_INUM (idx);
 527   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 528 }
 529
 530 VM_DEFINE_INSTRUCTION (171, slot_set, "slot-set", 0, 3, 0)
 531 {
 532   SCM instance, idx, val;
 533   size_t slot;
 534   POP (val);
 535   POP (idx);
 536   POP (instance);
 537   slot = SCM_I_INUM (idx);
 538   SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
 539   NEXT;
 540 }
 541
 542 \f
 543 /*
 544  * Bytevectors
 545  */
 546 #define VM_VALIDATE_BYTEVECTOR(x)               \
 547   if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x)))     \
 548     { finish_args = x;                          \
 549       goto vm_error_not_a_bytevector;           \
 550     }
 551
 552 #define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
 553 {                                                                       \
 554   SCM endianness;                                                       \
 555   POP (endianness);                                                     \
 556   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 557     goto VM_LABEL (bv_##stem##_native_ref);                             \
 558   {                                                                     \
 559     ARGS2 (bv, idx);                                                    \
 560     SYNC_REGISTER ();                                                   \
 561     RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness));      \
 562   }                                                                     \
 563 }
 564
 565 VM_DEFINE_FUNCTION (172, bv_u16_ref, "bv-u16-ref", 3)
 566 BV_REF_WITH_ENDIANNESS (u16, u16)
 567 VM_DEFINE_FUNCTION (173, bv_s16_ref, "bv-s16-ref", 3)
 568 BV_REF_WITH_ENDIANNESS (s16, s16)
 569 VM_DEFINE_FUNCTION (174, bv_u32_ref, "bv-u32-ref", 3)
 570 BV_REF_WITH_ENDIANNESS (u32, u32)
 571 VM_DEFINE_FUNCTION (175, bv_s32_ref, "bv-s32-ref", 3)
 572 BV_REF_WITH_ENDIANNESS (s32, s32)
 573 VM_DEFINE_FUNCTION (176, bv_u64_ref, "bv-u64-ref", 3)
 574 BV_REF_WITH_ENDIANNESS (u64, u64)
 575 VM_DEFINE_FUNCTION (177, bv_s64_ref, "bv-s64-ref", 3)
 576 BV_REF_WITH_ENDIANNESS (s64, s64)
 577 VM_DEFINE_FUNCTION (178, bv_f32_ref, "bv-f32-ref", 3)
 578 BV_REF_WITH_ENDIANNESS (f32, ieee_single)
 579 VM_DEFINE_FUNCTION (179, bv_f64_ref, "bv-f64-ref", 3)
 580 BV_REF_WITH_ENDIANNESS (f64, ieee_double)
 581
 582 #undef BV_REF_WITH_ENDIANNESS
 583
 584 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size)                   \
 585 {                                                                       \
 586   long i = 0;                                                           \
 587   ARGS2 (bv, idx);                                                      \
 588   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 589   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 590                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 591                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 592                   && (i % size == 0)))                                  \
 593     RETURN (SCM_I_MAKINUM (*(scm_t_##type*)                             \
 594                            (SCM_BYTEVECTOR_CONTENTS (bv) + i)));        \
 595   else                                                                  \
 596     {                                                                   \
 597       SYNC_REGISTER ();                                                 \
 598       RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx));            \
 599     }                                                                   \
 600 }
 601
 602 #define BV_INT_REF(stem, type, size)                                    \
 603 {                                                                       \
 604   long i = 0;                                                           \
 605   ARGS2 (bv, idx);                                                      \
 606   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 607   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 608                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 609                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 610                   && (i % size == 0)))                                  \
 611     { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \
 612       if (SCM_FIXABLE (x))                                              \
 613         RETURN (SCM_I_MAKINUM (x));                                     \
 614       else                                                              \
 615         {                                                               \
 616           SYNC_REGISTER ();                                             \
 617           RETURN (scm_from_ ## type (x));                               \
 618         }                                                               \
 619     }                                                                   \
 620   else                                                                  \
 621     {                                                                   \
 622       SYNC_REGISTER ();                                                 \
 623       RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx));        \
 624     }                                                                   \
 625 }
 626
 627 #define BV_FLOAT_REF(stem, fn_stem, type, size)                         \
 628 {                                                                       \
 629   long i = 0;                                                           \
 630   ARGS2 (bv, idx);                                                      \
 631   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 632   SYNC_REGISTER ();                                                     \
 633   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 634                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 635                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 636                   && (i % size == 0)))                                  \
 637     RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \
 638   else                                                                  \
 639     RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx));       \
 640 }
 641
 642 VM_DEFINE_FUNCTION (180, bv_u8_ref, "bv-u8-ref", 2)
 643 BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
 644 VM_DEFINE_FUNCTION (181, bv_s8_ref, "bv-s8-ref", 2)
 645 BV_FIXABLE_INT_REF (s8, s8, int8, 1)
 646 VM_DEFINE_FUNCTION (182, bv_u16_native_ref, "bv-u16-native-ref", 2)
 647 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
 648 VM_DEFINE_FUNCTION (183, bv_s16_native_ref, "bv-s16-native-ref", 2)
 649 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
 650 VM_DEFINE_FUNCTION (184, bv_u32_native_ref, "bv-u32-native-ref", 2)
 651 #if SIZEOF_VOID_P > 4
 652 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
 653 #else
 654 BV_INT_REF (u32, uint32, 4)
 655 #endif
 656 VM_DEFINE_FUNCTION (185, bv_s32_native_ref, "bv-s32-native-ref", 2)
 657 #if SIZEOF_VOID_P > 4
 658 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
 659 #else
 660 BV_INT_REF (s32, int32, 4)
 661 #endif
 662 VM_DEFINE_FUNCTION (186, bv_u64_native_ref, "bv-u64-native-ref", 2)
 663 BV_INT_REF (u64, uint64, 8)
 664 VM_DEFINE_FUNCTION (187, bv_s64_native_ref, "bv-s64-native-ref", 2)
 665 BV_INT_REF (s64, int64, 8)
 666 VM_DEFINE_FUNCTION (188, bv_f32_native_ref, "bv-f32-native-ref", 2)
 667 BV_FLOAT_REF (f32, ieee_single, float, 4)
 668 VM_DEFINE_FUNCTION (189, bv_f64_native_ref, "bv-f64-native-ref", 2)
 669 BV_FLOAT_REF (f64, ieee_double, double, 8)
 670
 671 #undef BV_FIXABLE_INT_REF
 672 #undef BV_INT_REF
 673 #undef BV_FLOAT_REF
 674
 675
 676
 677 #define BV_SET_WITH_ENDIANNESS(stem, fn_stem)                           \
 678 {                                                                       \
 679   SCM endianness;                                                       \
 680   POP (endianness);                                                     \
 681   if (scm_is_eq (endianness, scm_i_native_endianness))                  \
 682     goto VM_LABEL (bv_##stem##_native_set);                             \
 683   {                                                                     \
 684     SCM bv, idx, val; POP (val); POP (idx); POP (bv);                   \
 685     scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness);        \
 686     NEXT;                                                               \
 687   }                                                                     \
 688 }
 689
 690 VM_DEFINE_INSTRUCTION (190, bv_u16_set, "bv-u16-set", 0, 4, 0)
 691 BV_SET_WITH_ENDIANNESS (u16, u16)
 692 VM_DEFINE_INSTRUCTION (191, bv_s16_set, "bv-s16-set", 0, 4, 0)
 693 BV_SET_WITH_ENDIANNESS (s16, s16)
 694 VM_DEFINE_INSTRUCTION (192, bv_u32_set, "bv-u32-set", 0, 4, 0)
 695 BV_SET_WITH_ENDIANNESS (u32, u32)
 696 VM_DEFINE_INSTRUCTION (193, bv_s32_set, "bv-s32-set", 0, 4, 0)
 697 BV_SET_WITH_ENDIANNESS (s32, s32)
 698 VM_DEFINE_INSTRUCTION (194, bv_u64_set, "bv-u64-set", 0, 4, 0)
 699 BV_SET_WITH_ENDIANNESS (u64, u64)
 700 VM_DEFINE_INSTRUCTION (195, bv_s64_set, "bv-s64-set", 0, 4, 0)
 701 BV_SET_WITH_ENDIANNESS (s64, s64)
 702 VM_DEFINE_INSTRUCTION (196, bv_f32_set, "bv-f32-set", 0, 4, 0)
 703 BV_SET_WITH_ENDIANNESS (f32, ieee_single)
 704 VM_DEFINE_INSTRUCTION (197, bv_f64_set, "bv-f64-set", 0, 4, 0)
 705 BV_SET_WITH_ENDIANNESS (f64, ieee_double)
 706
 707 #undef BV_SET_WITH_ENDIANNESS
 708
 709 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size)         \
 710 {                                                                       \
 711   long i = 0, j = 0;                                                    \
 712   SCM bv, idx, val; POP (val); POP (idx); POP (bv);                     \
 713   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 714   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 715                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 716                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 717                   && (i % size == 0)                                    \
 718                   && (SCM_I_INUMP (val))                                \
 719                   && ((j = SCM_I_INUM (val)) >= min)                    \
 720                   && (j <= max)))                                       \
 721     *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \
 722   else                                                                  \
 723     scm_bytevector_##fn_stem##_set_x (bv, idx, val);                    \
 724   NEXT;                                                                 \
 725 }
 726
 727 #define BV_INT_SET(stem, type, size)                                    \
 728 {                                                                       \
 729   long i = 0;                                                           \
 730   SCM bv, idx, val; POP (val); POP (idx); POP (bv);                     \
 731   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 732   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 733                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 734                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 735                   && (i % size == 0)))                                  \
 736     *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \
 737   else                                                                  \
 738     scm_bytevector_##stem##_native_set_x (bv, idx, val);                \
 739   NEXT;                                                                 \
 740 }
 741
 742 #define BV_FLOAT_SET(stem, fn_stem, type, size)                         \
 743 {                                                                       \
 744   long i = 0;                                                           \
 745   SCM bv, idx, val; POP (val); POP (idx); POP (bv);                     \
 746   VM_VALIDATE_BYTEVECTOR (bv);                                          \
 747   if (SCM_LIKELY (SCM_I_INUMP (idx)                                     \
 748                   && ((i = SCM_I_INUM (idx)) >= 0)                      \
 749                   && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))           \
 750                   && (i % size == 0)))                                  \
 751     *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val);  \
 752   else                                                                  \
 753     scm_bytevector_##fn_stem##_native_set_x (bv, idx, val);             \
 754   NEXT;                                                                 \
 755 }
 756
 757 VM_DEFINE_INSTRUCTION (198, bv_u8_set, "bv-u8-set", 0, 3, 0)
 758 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
 759 VM_DEFINE_INSTRUCTION (199, bv_s8_set, "bv-s8-set", 0, 3, 0)
 760 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
 761 VM_DEFINE_INSTRUCTION (200, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
 762 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
 763 VM_DEFINE_INSTRUCTION (201, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
 764 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
 765 VM_DEFINE_INSTRUCTION (202, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
 766 #if SIZEOF_VOID_P > 4
 767 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
 768 #else
 769 BV_INT_SET (u32, uint32, 4)
 770 #endif
 771 VM_DEFINE_INSTRUCTION (203, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
 772 #if SIZEOF_VOID_P > 4
 773 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
 774 #else
 775 BV_INT_SET (s32, int32, 4)
 776 #endif
 777 VM_DEFINE_INSTRUCTION (204, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
 778 BV_INT_SET (u64, uint64, 8)
 779 VM_DEFINE_INSTRUCTION (205, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
 780 BV_INT_SET (s64, int64, 8)
 781 VM_DEFINE_INSTRUCTION (206, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
 782 BV_FLOAT_SET (f32, ieee_single, float, 4)
 783 VM_DEFINE_INSTRUCTION (207, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
 784 BV_FLOAT_SET (f64, ieee_double, double, 8)
 785
 786 #undef BV_FIXABLE_INT_SET
 787 #undef BV_INT_SET
 788 #undef BV_FLOAT_SET
 789
 790 /*
 791 (defun renumber-ops ()
 792   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
 793   (interactive "")
 794   (save-excursion
 795     (let ((counter 127)) (goto-char (point-min))
 796       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
 797         (replace-match
 798          (number-to-string (setq counter (1+ counter)))
 799           t t nil 1)))))
 800 */
 801
 802 /*
 803   Local Variables:
 804   c-file-style: "gnu"
 805   End:
 806 */