libguile/vm-i-scheme.c

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