HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
more care regarding SCM_PACK and SCM_UNPACK
[bpt/guile.git] / libguile / vm-i-scheme.c
CommitLineData
eae2438d 1/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
a98cef7e 2 *
560b9c25 3 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 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.
a98cef7e 7 *
53befeb7
NJ		 8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
560b9c25
AW		 10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
a98cef7e 12 *
560b9c25
AW		 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
53befeb7
NJ		 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
560b9c25 17 */
a98cef7e
KN		 18
19/* This file is included in vm_engine.c */
20
a80be762
KN		 21\f
22/*
23 * Predicates
24 */
25
93d197be 26#define ARGS1(a1) SCM a1 = sp[0];
11ea1aba
AW		 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);
93d197be
AW		 29
30#define RETURN(x) do { *sp = x; NEXT; } while (0)
31
827dc8dc 32VM_DEFINE_FUNCTION (128, not, "not", 1)
a98cef7e 33{
a80be762 34 ARGS1 (x);
2533f10b 35 RETURN (scm_from_bool (scm_is_false (x)));
17e90c5e
KN		 36}
37
827dc8dc 38VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
17e90c5e 39{
a80be762 40 ARGS1 (x);
2533f10b 41 RETURN (scm_from_bool (!scm_is_false (x)));
17e90c5e
KN		 42}
43
827dc8dc 44VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
17e90c5e 45{
a80be762 46 ARGS2 (x, y);
5c8cefe5 47 RETURN (scm_from_bool (scm_is_eq (x, y)));
17e90c5e
KN		 48}
49
827dc8dc 50VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
17e90c5e 51{
a80be762 52 ARGS2 (x, y);
5c8cefe5 53 RETURN (scm_from_bool (!scm_is_eq (x, y)));
17e90c5e
KN		 54}
55
827dc8dc 56VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
17e90c5e 57{
a80be762 58 ARGS1 (x);
2533f10b 59 RETURN (scm_from_bool (scm_is_null (x)));
a98cef7e
KN		 60}
61
827dc8dc 62VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
a98cef7e 63{
a80be762 64 ARGS1 (x);
2533f10b 65 RETURN (scm_from_bool (!scm_is_null (x)));
a80be762
KN		 66}
67
827dc8dc 68VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
a80be762
KN		 69{
70 ARGS2 (x, y);
5c8cefe5 71 if (scm_is_eq (x, y))
a80be762
KN		 72 RETURN (SCM_BOOL_T);
73 if (SCM_IMP (x) || SCM_IMP (y))
74 RETURN (SCM_BOOL_F);
1865ad56 75 SYNC_REGISTER ();
a80be762
KN		 76 RETURN (scm_eqv_p (x, y));
77}
78
827dc8dc 79VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
a80be762
KN		 80{
81 ARGS2 (x, y);
5c8cefe5 82 if (scm_is_eq (x, y))
a80be762
KN		 83 RETURN (SCM_BOOL_T);
84 if (SCM_IMP (x) || SCM_IMP (y))
85 RETURN (SCM_BOOL_F);
1865ad56 86 SYNC_REGISTER ();
a80be762 87 RETURN (scm_equal_p (x, y));
a98cef7e
KN		 88}
89
827dc8dc 90VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
a98cef7e 91{
a80be762 92 ARGS1 (x);
5c8cefe5 93 RETURN (scm_from_bool (scm_is_pair (x)));
a98cef7e
KN		 94}
95
827dc8dc 96VM_DEFINE_FUNCTION (137, listp, "list?", 1)
a98cef7e 97{
a80be762 98 ARGS1 (x);
9bd48cb1 99 RETURN (scm_from_bool (scm_ilength (x) >= 0));
a98cef7e
KN		 100}
101
cf45ff03
AW		 102VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
103{
104 ARGS1 (x);
105 RETURN (scm_from_bool (scm_is_symbol (x)));
106}
107
108VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
109{
110 ARGS1 (x);
111 RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
112}
113
a80be762
KN		 114\f
115/*
116 * Basic data
117 */
118
cf45ff03 119VM_DEFINE_FUNCTION (140, cons, "cons", 2)
a98cef7e 120{
a80be762
KN		 121 ARGS2 (x, y);
122 CONS (x, x, y);
123 RETURN (x);
a98cef7e
KN		 124}
125
41e49280 126#define VM_VALIDATE_CONS(x, proc) \
5e390de6 127 if (SCM_UNLIKELY (!scm_is_pair (x))) \
41e49280
AW		 128 { func_name = proc; \
129 finish_args = x; \
5e390de6
AW		 130 goto vm_error_not_a_pair; \
131 }
132
cf45ff03 133VM_DEFINE_FUNCTION (141, car, "car", 1)
a98cef7e 134{
a80be762 135 ARGS1 (x);
41e49280 136 VM_VALIDATE_CONS (x, "car");
a80be762 137 RETURN (SCM_CAR (x));
a98cef7e
KN		 138}
139
cf45ff03 140VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
a98cef7e 141{
a80be762 142 ARGS1 (x);
41e49280 143 VM_VALIDATE_CONS (x, "cdr");
a80be762 144 RETURN (SCM_CDR (x));
a98cef7e
KN		 145}
146
cf45ff03 147VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
a98cef7e 148{
60ed31d2 149 SCM x, y;
eae2438d 150 POP2 (y, x);
41e49280 151 VM_VALIDATE_CONS (x, "set-car!");
a80be762 152 SCM_SETCAR (x, y);
60ed31d2 153 NEXT;
a98cef7e
KN		 154}
155
cf45ff03 156VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
a98cef7e 157{
60ed31d2 158 SCM x, y;
eae2438d 159 POP2 (y, x);
41e49280 160 VM_VALIDATE_CONS (x, "set-cdr!");
a80be762 161 SCM_SETCDR (x, y);
60ed31d2 162 NEXT;
a98cef7e
KN		 163}
164
a80be762
KN		 165\f
166/*
167 * Numeric relational tests
168 */
169
170#undef REL
b2b33168
AW		 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 }
a80be762 180
cf45ff03 181VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
a80be762
KN		 182{
183 REL (==, scm_num_eq_p);
184}
185
cf45ff03 186VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
a80be762
KN		 187{
188 REL (<, scm_less_p);
189}
190
cf45ff03 191VM_DEFINE_FUNCTION (147, le, "le?", 2)
a80be762
KN		 192{
193 REL (<=, scm_leq_p);
194}
195
cf45ff03 196VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
a80be762
KN		 197{
198 REL (>, scm_gr_p);
199}
200
cf45ff03 201VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
a80be762
KN		 202{
203 REL (>=, scm_geq_p);
204}
205
206\f
207/*
208 * Numeric functions
209 */
210
e78d4bf9 211/* The maximum/minimum tagged integers. */
0c57673a
LC		 212#undef INUM_MAX
213#undef INUM_MIN
e78d4bf9
LC		 214#define INUM_MAX (INTPTR_MAX - 1)
215#define INUM_MIN (INTPTR_MIN + scm_tc2_int)
216
a80be762
KN		 217#undef FUNC2
218#define FUNC2(CFUNC,SFUNC) \
219{ \
d8eeb67c 220 ARGS2 (x, y); \
2d80426a 221 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
a80be762 222 { \
c0ee3245 223 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
a80be762 224 if (SCM_FIXABLE (n)) \
2d80426a 225 RETURN (SCM_I_MAKINUM (n)); \
a80be762 226 } \
b2642276 227 SYNC_REGISTER (); \
a80be762
KN		 228 RETURN (SFUNC (x, y)); \
229}
230
0c57673a
LC		 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
cf45ff03 283VM_DEFINE_FUNCTION (150, add, "add", 2)
a80be762 284{
0c57673a 285#ifndef ASM_ADD
a80be762 286 FUNC2 (+, scm_sum);
0c57673a
LC		 287#else
288 ARGS2 (x, y);
289 ASM_ADD (x, y);
290 SYNC_REGISTER ();
291 RETURN (scm_sum (x, y));
292#endif
a80be762
KN		 293}
294
cf45ff03 295VM_DEFINE_FUNCTION (151, add1, "add1", 1)
7382f23e
AW		 296{
297 ARGS1 (x);
e78d4bf9
LC		 298
299 /* Check for overflow. */
b2b33168 300 if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX))
7382f23e 301 {
e78d4bf9
LC		 302 SCM result;
303
304 /* Add the integers without untagging. */
b2b33168
AW		 305 result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
306 + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
e78d4bf9
LC		 307 - scm_tc2_int);
308
309 if (SCM_LIKELY (SCM_I_INUMP (result)))
310 RETURN (result);
7382f23e 311 }
e78d4bf9 312
7382f23e
AW		 313 SYNC_REGISTER ();
314 RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
315}
316
cf45ff03 317VM_DEFINE_FUNCTION (152, sub, "sub", 2)
a80be762 318{
0c57673a 319#ifndef ASM_SUB
a80be762 320 FUNC2 (-, scm_difference);
0c57673a
LC		 321#else
322 ARGS2 (x, y);
323 ASM_SUB (x, y);
324 SYNC_REGISTER ();
325 RETURN (scm_difference (x, y));
326#endif
a80be762
KN		 327}
328
cf45ff03 329VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
7382f23e
AW		 330{
331 ARGS1 (x);
e78d4bf9
LC		 332
333 /* Check for underflow. */
b2b33168 334 if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN))
7382f23e 335 {
e78d4bf9
LC		 336 SCM result;
337
338 /* Substract the integers without untagging. */
b2b33168
AW		 339 result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
340 - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
e78d4bf9
LC		 341 + scm_tc2_int);
342
343 if (SCM_LIKELY (SCM_I_INUMP (result)))
344 RETURN (result);
7382f23e 345 }
e78d4bf9 346
7382f23e
AW		 347 SYNC_REGISTER ();
348 RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
349}
350
0c57673a
LC		 351# undef ASM_ADD
352# undef ASM_SUB
353
cf45ff03 354VM_DEFINE_FUNCTION (154, mul, "mul", 2)
a80be762
KN		 355{
356 ARGS2 (x, y);
1865ad56 357 SYNC_REGISTER ();
a80be762
KN		 358 RETURN (scm_product (x, y));
359}
360
cf45ff03 361VM_DEFINE_FUNCTION (155, div, "div", 2)
a80be762
KN		 362{
363 ARGS2 (x, y);
1865ad56 364 SYNC_REGISTER ();
a80be762
KN		 365 RETURN (scm_divide (x, y));
366}
367
cf45ff03 368VM_DEFINE_FUNCTION (156, quo, "quo", 2)
a80be762
KN		 369{
370 ARGS2 (x, y);
1865ad56 371 SYNC_REGISTER ();
a80be762
KN		 372 RETURN (scm_quotient (x, y));
373}
374
cf45ff03 375VM_DEFINE_FUNCTION (157, rem, "rem", 2)
a80be762
KN		 376{
377 ARGS2 (x, y);
1865ad56 378 SYNC_REGISTER ();
a80be762
KN		 379 RETURN (scm_remainder (x, y));
380}
381
cf45ff03 382VM_DEFINE_FUNCTION (158, mod, "mod", 2)
a80be762
KN		 383{
384 ARGS2 (x, y);
1865ad56 385 SYNC_REGISTER ();
a80be762
KN		 386 RETURN (scm_modulo (x, y));
387}
388
cf45ff03 389VM_DEFINE_FUNCTION (159, ash, "ash", 2)
b10d9330
AW		 390{
391 ARGS2 (x, y);
392 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
393 {
394 if (SCM_I_INUM (y) < 0)
8ecd1943 395 /* Right shift, will be a fixnum. */
b10d9330 396 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
8ecd1943
AW		 397 else
398 /* Left shift. See comments in scm_ash. */
399 {
e25f3727 400 scm_t_signed_bits nn, bits_to_shift;
8ecd1943
AW		 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
e25f3727 406 && ((scm_t_bits)
8ecd1943
AW		 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 }
b10d9330
AW		 412 /* fall through */
413 }
414 SYNC_REGISTER ();
415 RETURN (scm_ash (x, y));
416}
417
cf45ff03 418VM_DEFINE_FUNCTION (160, logand, "logand", 2)
b10d9330
AW		 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
cf45ff03 427VM_DEFINE_FUNCTION (161, logior, "logior", 2)
b10d9330
AW		 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
cf45ff03 436VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
b10d9330
AW		 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
1e4b834a
AW		 445\f
446/*
827dc8dc 447 * Vectors and arrays
1e4b834a 448 */
aec4a84a 449
cf45ff03 450VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
d6f1ce3d 451{
e25f3727 452 scm_t_signed_bits i = 0;
d6f1ce3d 453 ARGS2 (vect, idx);
7b702b53 454 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
d6f1ce3d
AW		 455 && SCM_I_INUMP (idx)
456 && ((i = SCM_I_INUM (idx)) >= 0)
457 && i < SCM_I_VECTOR_LENGTH (vect)))
458 RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
459 else
9b29d607
AW		 460 {
461 SYNC_REGISTER ();
462 RETURN (scm_vector_ref (vect, idx));
463 }
d6f1ce3d
AW		 464}
465
cf45ff03 466VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
d6f1ce3d 467{
e25f3727 468 scm_t_signed_bits i = 0;
d6f1ce3d 469 SCM vect, idx, val;
eae2438d 470 POP3 (val, idx, vect);
7b702b53 471 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
d6f1ce3d
AW		 472 && SCM_I_INUMP (idx)
473 && ((i = SCM_I_INUM (idx)) >= 0)
474 && i < SCM_I_VECTOR_LENGTH (vect)))
475 SCM_I_VECTOR_WELTS (vect)[i] = val;
476 else
9b29d607
AW		 477 {
478 SYNC_REGISTER ();
479 scm_vector_set_x (vect, idx, val);
480 }
d6f1ce3d
AW		 481 NEXT;
482}
483
cf45ff03 484VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
827dc8dc
AW		 485{
486 scm_t_uint32 len;
487 SCM shape, ret;
488
489 len = FETCH ();
490 len = (len << 8) + FETCH ();
491 len = (len << 8) + FETCH ();
492 POP (shape);
493 SYNC_REGISTER ();
384dce46 494 PRE_CHECK_UNDERFLOW (len);
827dc8dc
AW		 495 ret = scm_from_contiguous_array (shape, sp - len + 1, len);
496 DROPN (len);
497 PUSH (ret);
498 NEXT;
499}
500
501\f
502/*
503 * Structs
504 */
41e49280 505#define VM_VALIDATE_STRUCT(obj, proc) \
827dc8dc
AW		 506 if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
507 { \
41e49280 508 func_name = proc; \
827dc8dc
AW		 509 finish_args = (obj); \
510 goto vm_error_not_a_struct; \
511 }
512
cf45ff03 513VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
827dc8dc
AW		 514{
515 ARGS1 (obj);
516 RETURN (scm_from_bool (SCM_STRUCTP (obj)));
517}
518
cf45ff03 519VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
827dc8dc
AW		 520{
521 ARGS1 (obj);
41e49280 522 VM_VALIDATE_STRUCT (obj, "struct_vtable");
827dc8dc
AW		 523 RETURN (SCM_STRUCT_VTABLE (obj));
524}
525
cf45ff03 526VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
827dc8dc
AW		 527{
528 unsigned h = FETCH ();
529 unsigned l = FETCH ();
9a974fd3
AW		 530 scm_t_bits n = ((h << 8U) + l);
531 SCM vtable = sp[-(n - 1)];
532 const SCM *inits = sp - n + 2;
533 SCM ret;
827dc8dc 534
9823fd39
LC		 535 SYNC_REGISTER ();
536
827dc8dc
AW		 537 if (SCM_LIKELY (SCM_STRUCTP (vtable)
538 && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
9a974fd3
AW		 539 && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
540 == n)
541 && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
827dc8dc 542 {
9a974fd3
AW		 543 /* Verily, we are making a simple struct with the right number of
544 initializers, and no finalizer. */
545 ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
546 n + 1);
547 SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
548 memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
827dc8dc 549 }
9a974fd3
AW		 550 else
551 ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
552
c99865c1 553 DROPN (n);
9a974fd3 554 PUSH (ret);
827dc8dc 555
9a974fd3 556 NEXT;
827dc8dc
AW		 557}
558
cf45ff03 559VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
827dc8dc
AW		 560{
561 ARGS2 (obj, pos);
562
563 if (SCM_LIKELY (SCM_STRUCTP (obj)
564 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
565 SCM_VTABLE_FLAG_SIMPLE)
566 && SCM_I_INUMP (pos)))
567 {
568 SCM vtable;
569 scm_t_bits index, len;
570
e25f3727
AW		 571 /* True, an inum is a signed value, but cast to unsigned it will
572 certainly be more than the length, so we will fall through if
573 index is negative. */
827dc8dc
AW		 574 index = SCM_I_INUM (pos);
575 vtable = SCM_STRUCT_VTABLE (obj);
576 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
577
578 if (SCM_LIKELY (index < len))
579 {
580 scm_t_bits *data = SCM_STRUCT_DATA (obj);
581 RETURN (SCM_PACK (data[index]));
582 }
583 }
584
9823fd39 585 SYNC_REGISTER ();
827dc8dc
AW		 586 RETURN (scm_struct_ref (obj, pos));
587}
588
cf45ff03 589VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
827dc8dc
AW		 590{
591 ARGS3 (obj, pos, val);
592
593 if (SCM_LIKELY (SCM_STRUCTP (obj)
594 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
595 SCM_VTABLE_FLAG_SIMPLE)
596 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
597 SCM_VTABLE_FLAG_SIMPLE_RW)
598 && SCM_I_INUMP (pos)))
599 {
600 SCM vtable;
601 scm_t_bits index, len;
602
e25f3727 603 /* See above regarding index being >= 0. */
827dc8dc
AW		 604 index = SCM_I_INUM (pos);
605 vtable = SCM_STRUCT_VTABLE (obj);
606 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
607 if (SCM_LIKELY (index < len))
608 {
609 scm_t_bits *data = SCM_STRUCT_DATA (obj);
610 data[index] = SCM_UNPACK (val);
611 RETURN (val);
612 }
613 }
614
9823fd39 615 SYNC_REGISTER ();
827dc8dc
AW		 616 RETURN (scm_struct_set_x (obj, pos, val));
617}
618
619\f
620/*
621 * GOOPS support
622 */
cf45ff03 623VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
827dc8dc
AW		 624{
625 ARGS1 (obj);
1a461493
AW		 626 if (SCM_INSTANCEP (obj))
627 RETURN (SCM_CLASS_OF (obj));
628 SYNC_REGISTER ();
629 RETURN (scm_class_of (obj));
827dc8dc
AW		 630}
631
e25f3727 632/* FIXME: No checking whatsoever. */
cf45ff03 633VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
827dc8dc
AW		 634{
635 size_t slot;
636 ARGS2 (instance, idx);
637 slot = SCM_I_INUM (idx);
638 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
639}
640
e25f3727 641/* FIXME: No checking whatsoever. */
cf45ff03 642VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
827dc8dc
AW		 643{
644 SCM instance, idx, val;
645 size_t slot;
eae2438d 646 POP3 (val, idx, instance);
827dc8dc
AW		 647 slot = SCM_I_INUM (idx);
648 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
649 NEXT;
650}
651
652\f
653/*
654 * Bytevectors
655 */
41e49280 656#define VM_VALIDATE_BYTEVECTOR(x, proc) \
1b68d627
LC		 657 do \
658 { \
659 if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
660 { \
41e49280 661 func_name = proc; \
1b68d627
LC		 662 finish_args = x; \
663 goto vm_error_not_a_bytevector; \
664 } \
665 } \
666 while (0)
e6eb2467
AW		 667
668#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
669{ \
670 SCM endianness; \
671 POP (endianness); \
672 if (scm_is_eq (endianness, scm_i_native_endianness)) \
673 goto VM_LABEL (bv_##stem##_native_ref); \
674 { \
675 ARGS2 (bv, idx); \
9823fd39 676 SYNC_REGISTER (); \
e6eb2467
AW		 677 RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
678 } \
679}
680
daccfef4
LC		 681/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
682#define ALIGNED_P(ptr, type) \
683 ((scm_t_uintptr) (ptr) % alignof (type) == 0)
684
cf45ff03 685VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
e6eb2467 686BV_REF_WITH_ENDIANNESS (u16, u16)
cf45ff03 687VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
e6eb2467 688BV_REF_WITH_ENDIANNESS (s16, s16)
cf45ff03 689VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
e6eb2467 690BV_REF_WITH_ENDIANNESS (u32, u32)
cf45ff03 691VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
e6eb2467 692BV_REF_WITH_ENDIANNESS (s32, s32)
cf45ff03 693VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
e6eb2467 694BV_REF_WITH_ENDIANNESS (u64, u64)
cf45ff03 695VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
e6eb2467 696BV_REF_WITH_ENDIANNESS (s64, s64)
cf45ff03 697VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
e6eb2467 698BV_REF_WITH_ENDIANNESS (f32, ieee_single)
cf45ff03 699VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
e6eb2467
AW		 700BV_REF_WITH_ENDIANNESS (f64, ieee_double)
701
702#undef BV_REF_WITH_ENDIANNESS
703
9823fd39
LC		 704#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
705{ \
e25f3727 706 scm_t_signed_bits i; \
daccfef4 707 const scm_t_ ## type *int_ptr; \
9823fd39 708 ARGS2 (bv, idx); \
daccfef4 709 \
41e49280 710 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
daccfef4
LC		 711 i = SCM_I_INUM (idx); \
712 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
713 \
9823fd39 714 if (SCM_LIKELY (SCM_I_INUMP (idx) \
daccfef4 715 && (i >= 0) \
9823fd39 716 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
daccfef4
LC		 717 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
718 RETURN (SCM_I_MAKINUM (*int_ptr)); \
9823fd39
LC		 719 else \
720 { \
721 SYNC_REGISTER (); \
722 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
723 } \
724}
725
726#define BV_INT_REF(stem, type, size) \
727{ \
e25f3727 728 scm_t_signed_bits i; \
daccfef4 729 const scm_t_ ## type *int_ptr; \
9823fd39 730 ARGS2 (bv, idx); \
daccfef4 731 \
41e49280 732 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
daccfef4
LC		 733 i = SCM_I_INUM (idx); \
734 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
735 \
9823fd39 736 if (SCM_LIKELY (SCM_I_INUMP (idx) \
daccfef4 737 && (i >= 0) \
9823fd39 738 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
daccfef4
LC		 739 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
740 { \
741 scm_t_ ## type x = *int_ptr; \
9823fd39
LC		 742 if (SCM_FIXABLE (x)) \
743 RETURN (SCM_I_MAKINUM (x)); \
744 else \
745 { \
746 SYNC_REGISTER (); \
747 RETURN (scm_from_ ## type (x)); \
748 } \
749 } \
750 else \
751 { \
752 SYNC_REGISTER (); \
753 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
754 } \
755}
756
757#define BV_FLOAT_REF(stem, fn_stem, type, size) \
758{ \
e25f3727 759 scm_t_signed_bits i; \
daccfef4 760 const type *float_ptr; \
9823fd39 761 ARGS2 (bv, idx); \
daccfef4 762 \
41e49280 763 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
daccfef4
LC		 764 i = SCM_I_INUM (idx); \
765 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
766 \
9823fd39
LC		 767 SYNC_REGISTER (); \
768 if (SCM_LIKELY (SCM_I_INUMP (idx) \
daccfef4 769 && (i >= 0) \
9823fd39 770 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
daccfef4
LC		 771 && (ALIGNED_P (float_ptr, type)))) \
772 RETURN (scm_from_double (*float_ptr)); \
9823fd39
LC		 773 else \
774 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
e6eb2467
AW		 775}
776
cf45ff03 777VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
e6eb2467 778BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
cf45ff03 779VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
e6eb2467 780BV_FIXABLE_INT_REF (s8, s8, int8, 1)
cf45ff03 781VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
e6eb2467 782BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
cf45ff03 783VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
e6eb2467 784BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
cf45ff03 785VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
dddacb23
LC		 786#if SIZEOF_VOID_P > 4
787BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
788#else
e6eb2467 789BV_INT_REF (u32, uint32, 4)
dddacb23 790#endif
cf45ff03 791VM_DEFINE_FUNCTION (187, bv_s32_native_ref, "bv-s32-native-ref", 2)
dddacb23
LC		 792#if SIZEOF_VOID_P > 4
793BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
794#else
e6eb2467 795BV_INT_REF (s32, int32, 4)
dddacb23 796#endif
cf45ff03 797VM_DEFINE_FUNCTION (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
e6eb2467 798BV_INT_REF (u64, uint64, 8)
cf45ff03 799VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
e6eb2467 800BV_INT_REF (s64, int64, 8)
cf45ff03 801VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
e6eb2467 802BV_FLOAT_REF (f32, ieee_single, float, 4)
cf45ff03 803VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
e6eb2467
AW		 804BV_FLOAT_REF (f64, ieee_double, double, 8)
805
806#undef BV_FIXABLE_INT_REF
807#undef BV_INT_REF
808#undef BV_FLOAT_REF
809
810
811
812#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
813{ \
814 SCM endianness; \
815 POP (endianness); \
816 if (scm_is_eq (endianness, scm_i_native_endianness)) \
817 goto VM_LABEL (bv_##stem##_native_set); \
818 { \
eae2438d 819 SCM bv, idx, val; POP3 (val, idx, bv); \
ad301b6d 820 SYNC_REGISTER (); \
d6f1ce3d
AW		 821 scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
822 NEXT; \
e6eb2467
AW		 823 } \
824}
825
cf45ff03 826VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
e6eb2467 827BV_SET_WITH_ENDIANNESS (u16, u16)
cf45ff03 828VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
e6eb2467 829BV_SET_WITH_ENDIANNESS (s16, s16)
cf45ff03 830VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
e6eb2467 831BV_SET_WITH_ENDIANNESS (u32, u32)
cf45ff03 832VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
e6eb2467 833BV_SET_WITH_ENDIANNESS (s32, s32)
cf45ff03 834VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
e6eb2467 835BV_SET_WITH_ENDIANNESS (u64, u64)
cf45ff03 836VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
e6eb2467 837BV_SET_WITH_ENDIANNESS (s64, s64)
cf45ff03 838VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
e6eb2467 839BV_SET_WITH_ENDIANNESS (f32, ieee_single)
cf45ff03 840VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
e6eb2467
AW		 841BV_SET_WITH_ENDIANNESS (f64, ieee_double)
842
843#undef BV_SET_WITH_ENDIANNESS
844
daccfef4
LC		 845#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
846{ \
e25f3727 847 scm_t_signed_bits i, j = 0; \
daccfef4
LC		 848 SCM bv, idx, val; \
849 scm_t_ ## type *int_ptr; \
850 \
eae2438d 851 POP3 (val, idx, bv); \
41e49280 852 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
daccfef4
LC		 853 i = SCM_I_INUM (idx); \
854 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
855 \
856 if (SCM_LIKELY (SCM_I_INUMP (idx) \
857 && (i >= 0) \
858 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
859 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
860 && (SCM_I_INUMP (val)) \
861 && ((j = SCM_I_INUM (val)) >= min) \
862 && (j <= max))) \
863 *int_ptr = (scm_t_ ## type) j; \
864 else \
ad301b6d
AW		 865 { \
866 SYNC_REGISTER (); \
867 scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \
868 } \
daccfef4
LC		 869 NEXT; \
870}
871
872#define BV_INT_SET(stem, type, size) \
873{ \
e25f3727 874 scm_t_signed_bits i = 0; \
daccfef4
LC		 875 SCM bv, idx, val; \
876 scm_t_ ## type *int_ptr; \
877 \
eae2438d 878 POP3 (val, idx, bv); \
41e49280 879 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
daccfef4
LC		 880 i = SCM_I_INUM (idx); \
881 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
882 \
883 if (SCM_LIKELY (SCM_I_INUMP (idx) \
884 && (i >= 0) \
885 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
886 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
887 *int_ptr = scm_to_ ## type (val); \
888 else \
ad301b6d
AW		 889 { \
890 SYNC_REGISTER (); \
891 scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \
892 } \
893 NEXT; \
daccfef4
LC		 894}
895
ad301b6d
AW		 896#define BV_FLOAT_SET(stem, fn_stem, type, size) \
897{ \
898 scm_t_signed_bits i = 0; \
899 SCM bv, idx, val; \
900 type *float_ptr; \
901 \
eae2438d 902 POP3 (val, idx, bv); \
ad301b6d
AW		 903 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
904 i = SCM_I_INUM (idx); \
905 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
906 \
907 if (SCM_LIKELY (SCM_I_INUMP (idx) \
908 && (i >= 0) \
909 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
910 && (ALIGNED_P (float_ptr, type)))) \
911 *float_ptr = scm_to_double (val); \
912 else \
913 { \
914 SYNC_REGISTER (); \
915 scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \
916 } \
917 NEXT; \
e6eb2467
AW		 918}
919
cf45ff03 920VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
e6eb2467 921BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
cf45ff03 922VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
e6eb2467 923BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
cf45ff03 924VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
d6f1ce3d 925BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
cf45ff03 926VM_DEFINE_INSTRUCTION (203, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
d6f1ce3d 927BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
cf45ff03 928VM_DEFINE_INSTRUCTION (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
dddacb23
LC		 929#if SIZEOF_VOID_P > 4
930BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
931#else
e6eb2467 932BV_INT_SET (u32, uint32, 4)
dddacb23 933#endif
cf45ff03 934VM_DEFINE_INSTRUCTION (205, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
dddacb23
LC		 935#if SIZEOF_VOID_P > 4
936BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
937#else
e6eb2467 938BV_INT_SET (s32, int32, 4)
dddacb23 939#endif
cf45ff03 940VM_DEFINE_INSTRUCTION (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
e6eb2467 941BV_INT_SET (u64, uint64, 8)
cf45ff03 942VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
e6eb2467 943BV_INT_SET (s64, int64, 8)
cf45ff03 944VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
e6eb2467 945BV_FLOAT_SET (f32, ieee_single, float, 4)
cf45ff03 946VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
e6eb2467
AW		 947BV_FLOAT_SET (f64, ieee_double, double, 8)
948
949#undef BV_FIXABLE_INT_SET
950#undef BV_INT_SET
951#undef BV_FLOAT_SET
952
53e28ed9
AW		 953/*
954(defun renumber-ops ()
955 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
956 (interactive "")
957 (save-excursion
827dc8dc 958 (let ((counter 127)) (goto-char (point-min))
53e28ed9
AW		 959 (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
960 (replace-match
961 (number-to-string (setq counter (1+ counter)))
962 t t nil 1)))))
963*/
1e4b834a 964
17e90c5e
KN		 965/*
966 Local Variables:
967 c-file-style: "gnu"
968 End:
969*/
Unnamed repository; edit this file 'description' to name the repository.