mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 22:17:34 +02:00
making EQUAL? comparison data-driven
all native types, present and future, now supported. allows for distinguishing which slots should be used for comparison (e.g. source info of pairs isn't compared).
This commit is contained in:
Alex Shinn
parent
6db4ed9155
commit
311c567c06
4 changed files with 151 additions and 119 deletions
10
eval.c
10
eval.c
|
|
@ -1533,14 +1533,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
case OP_NULLP:
|
||||
_ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
|
||||
case OP_INTEGERP:
|
||||
j = sexp_integerp(_ARG1);
|
||||
#if USE_FLONUMS
|
||||
if (! j)
|
||||
j = (sexp_flonump(_ARG1)
|
||||
&& (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1))));
|
||||
#endif
|
||||
_ARG1 = sexp_make_boolean(j);
|
||||
break;
|
||||
_ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break;
|
||||
case OP_SYMBOLP:
|
||||
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
|
||||
case OP_CHARP:
|
||||
|
|
@ -2432,7 +2425,6 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
|
|||
sexp_gc_var1(thunk);
|
||||
sexp_gc_preserve1(ctx, thunk);
|
||||
ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
|
||||
/* sexp_context_parent(ctx2) = ctx; */
|
||||
thunk = sexp_compile(ctx2, obj);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(ctx2, thunk,
|
||||
|
|
|
|||
10
gc.c
10
gc.c
|
|
@ -43,18 +43,16 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
|
|||
}
|
||||
|
||||
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
||||
sexp_uint_t res, *len_ptr;
|
||||
sexp_uint_t res;
|
||||
sexp t;
|
||||
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types))
|
||||
return sexp_heap_align(1);
|
||||
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
|
||||
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));
|
||||
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
|
||||
res = sexp_type_size_of_object(t, x);
|
||||
return res;
|
||||
}
|
||||
|
||||
void sexp_mark (sexp x) {
|
||||
sexp_uint_t *len_ptr;
|
||||
sexp_sint_t i, len;
|
||||
sexp t, *p;
|
||||
struct sexp_gc_var_t *saves;
|
||||
|
|
@ -67,9 +65,7 @@ void sexp_mark (sexp x) {
|
|||
if (saves->var) sexp_mark(*(saves->var));
|
||||
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
|
||||
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
|
||||
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t));
|
||||
len = sexp_type_field_len_base(t)
|
||||
+ len_ptr[0]*sexp_type_field_len_scale(t) - 1;
|
||||
len = sexp_type_num_slots_of_object(t, x) - 1;
|
||||
if (len >= 0) {
|
||||
for (i=0; i<len; i++)
|
||||
sexp_mark(p[i]);
|
||||
|
|
|
|||
|
|
@ -98,12 +98,11 @@ enum sexp_types {
|
|||
|
||||
typedef unsigned long sexp_uint_t;
|
||||
typedef long sexp_sint_t;
|
||||
/* #if SEXP_64_BIT */
|
||||
/* typedef unsigned int sexp_tag_t; */
|
||||
/* #else */
|
||||
/* typedef unsigned short sexp_tag_t; */
|
||||
/* #endif */
|
||||
typedef unsigned char sexp_tag_t;
|
||||
#if SEXP_64_BIT
|
||||
typedef unsigned int sexp_tag_t;
|
||||
#else
|
||||
typedef unsigned short sexp_tag_t;
|
||||
#endif
|
||||
typedef struct sexp_struct *sexp;
|
||||
|
||||
#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2))
|
||||
|
|
@ -143,8 +142,10 @@ struct sexp_struct {
|
|||
double flonum;
|
||||
struct {
|
||||
sexp_tag_t tag;
|
||||
short field_base, field_len_base, field_len_off, field_len_scale;
|
||||
short size_base, size_off, size_scale;
|
||||
short field_base, field_eq_len_base, field_len_base, field_len_off;
|
||||
unsigned short field_len_scale;
|
||||
short size_base, size_off;
|
||||
unsigned short size_scale;
|
||||
char *name;
|
||||
} type;
|
||||
struct {
|
||||
|
|
@ -165,7 +166,8 @@ struct sexp_struct {
|
|||
struct {
|
||||
FILE *stream;
|
||||
char *buf;
|
||||
sexp_uint_t offset, line, size, openp, sourcep;
|
||||
char openp, sourcep;
|
||||
sexp_uint_t offset, line, size;
|
||||
sexp name;
|
||||
sexp cookie;
|
||||
} port;
|
||||
|
|
@ -352,9 +354,22 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
#define sexp_gc_mark(x) ((x)->gc_mark)
|
||||
#define sexp_immutablep(x) ((x)->immutablep)
|
||||
|
||||
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag]))
|
||||
#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x)))
|
||||
#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)])))
|
||||
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag]))
|
||||
#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x)))
|
||||
#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)])))
|
||||
|
||||
#define sexp_type_size_of_object(t, x) \
|
||||
(((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \
|
||||
* sexp_type_size_scale(t) \
|
||||
+ sexp_type_size_base(t))
|
||||
#define sexp_type_num_slots_of_object(t, x) \
|
||||
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
|
||||
* sexp_type_field_len_scale(t) \
|
||||
+ sexp_type_field_len_base(t))
|
||||
#define sexp_type_num_eq_slots_of_object(t, x) \
|
||||
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
|
||||
* sexp_type_field_len_scale(t) \
|
||||
+ sexp_type_field_eq_len_base(t))
|
||||
|
||||
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
|
||||
|
||||
|
|
@ -419,12 +434,19 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
|
||||
#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x))
|
||||
|
||||
#if USE_FLONUMS
|
||||
#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x)))
|
||||
#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x))
|
||||
#else
|
||||
#define _or_integer_flonump(x)
|
||||
#endif
|
||||
|
||||
#if USE_BIGNUMS
|
||||
SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
||||
#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x))
|
||||
#define sexp_integerp(x) (sexp_fixnump(x) || sexp_bignump(x) _or_integer_flonump(x))
|
||||
#else
|
||||
#define sexp_make_integer(ctx, x) sexp_make_fixnum(x)
|
||||
#define sexp_integerp sexp_fixnump
|
||||
#define sexp_integerp(x) (sexp_fixnump(x) _or_integer_flonump(x))
|
||||
#endif
|
||||
|
||||
#if USE_FLONUMS
|
||||
|
|
@ -555,15 +577,16 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
|
||||
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
|
||||
|
||||
#define sexp_type_tag(x) ((x)->value.type.tag)
|
||||
#define sexp_type_field_base(x) ((x)->value.type.field_base)
|
||||
#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
|
||||
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
|
||||
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
|
||||
#define sexp_type_size_base(x) ((x)->value.type.size_base)
|
||||
#define sexp_type_size_off(x) ((x)->value.type.size_off)
|
||||
#define sexp_type_size_scale(x) ((x)->value.type.size_scale)
|
||||
#define sexp_type_name(x) ((x)->value.type.name)
|
||||
#define sexp_type_tag(x) ((x)->value.type.tag)
|
||||
#define sexp_type_field_base(x) ((x)->value.type.field_base)
|
||||
#define sexp_type_field_eq_len_base(x) ((x)->value.type.field_eq_len_base)
|
||||
#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
|
||||
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
|
||||
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
|
||||
#define sexp_type_size_base(x) ((x)->value.type.size_base)
|
||||
#define sexp_type_size_off(x) ((x)->value.type.size_off)
|
||||
#define sexp_type_size_scale(x) ((x)->value.type.size_scale)
|
||||
#define sexp_type_name(x) ((x)->value.type.name)
|
||||
|
||||
#define sexp_bignum_sign(x) ((x)->value.bignum.sign)
|
||||
#define sexp_bignum_length(x) ((x)->value.bignum.length)
|
||||
|
|
@ -686,7 +709,7 @@ SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
|
|||
SEXP_API void sexp_init(void);
|
||||
|
||||
#if USE_TYPE_DEFS
|
||||
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
|
||||
#endif
|
||||
|
||||
|
|
|
|||
179
sexp.c
179
sexp.c
|
|
@ -59,40 +59,40 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
|
||||
{.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}}
|
||||
#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n) \
|
||||
{.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n}}}
|
||||
|
||||
static struct sexp_struct _sexp_type_specs[] = {
|
||||
_DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"),
|
||||
_DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
|
||||
_DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
|
||||
_DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"),
|
||||
_DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"),
|
||||
_DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
|
||||
_DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
|
||||
_DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
|
||||
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector"),
|
||||
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
|
||||
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum"),
|
||||
_DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
|
||||
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
|
||||
_DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
|
||||
_DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
|
||||
_DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
|
||||
_DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
|
||||
_DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
|
||||
_DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
|
||||
_DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
|
||||
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
|
||||
_DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"),
|
||||
_DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
|
||||
_DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
|
||||
_DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
|
||||
_DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
|
||||
_DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"),
|
||||
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
|
||||
_DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object"),
|
||||
_DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
|
||||
_DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
|
||||
_DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char"),
|
||||
_DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean"),
|
||||
_DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair"),
|
||||
_DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"),
|
||||
_DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"),
|
||||
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector"),
|
||||
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"),
|
||||
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum"),
|
||||
_DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), 0, 0, "cpointer"),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
|
||||
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"),
|
||||
_DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"),
|
||||
_DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"),
|
||||
_DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"),
|
||||
_DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"),
|
||||
_DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"),
|
||||
_DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"),
|
||||
_DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"),
|
||||
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"),
|
||||
_DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"),
|
||||
_DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"),
|
||||
_DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"),
|
||||
_DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"),
|
||||
_DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"),
|
||||
_DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"),
|
||||
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
|
||||
};
|
||||
#undef _DEF_TYPE
|
||||
|
||||
|
|
@ -103,8 +103,8 @@ struct sexp_struct *sexp_type_specs = _sexp_type_specs;
|
|||
static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES;
|
||||
static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES;
|
||||
|
||||
sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp fls,
|
||||
sexp sb, sexp so, sexp sc) {
|
||||
sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
|
||||
sexp flo, sexp fls, sexp sb, sexp so, sexp sc) {
|
||||
struct sexp_struct *type, *new, *tmp;
|
||||
sexp res;
|
||||
sexp_uint_t i, len;
|
||||
|
|
@ -129,6 +129,7 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp
|
|||
sexp_pointer_tag(type) = SEXP_TYPE;
|
||||
sexp_type_tag(type) = sexp_num_types++;
|
||||
sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
|
||||
sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb);
|
||||
sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);
|
||||
sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo);
|
||||
sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls);
|
||||
|
|
@ -144,11 +145,12 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp flb, sexp flo, sexp
|
|||
sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
|
||||
short type_size
|
||||
= sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots);
|
||||
return sexp_register_type(ctx, name,
|
||||
sexp_make_fixnum(offsetof(struct sexp_struct, value)),
|
||||
slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(type_size), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0));
|
||||
return
|
||||
sexp_register_type(ctx, name,
|
||||
sexp_make_fixnum(offsetof(struct sexp_struct, value)),
|
||||
slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(type_size), sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0));
|
||||
}
|
||||
|
||||
#else
|
||||
|
|
@ -382,64 +384,81 @@ sexp sexp_length (sexp ctx, sexp ls) {
|
|||
}
|
||||
|
||||
sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
||||
sexp_uint_t len;
|
||||
sexp *v1, *v2;
|
||||
sexp_uint_t size;
|
||||
sexp_sint_t i, len;
|
||||
sexp t, tmp, *p, *q;
|
||||
char *p0, *q0;
|
||||
|
||||
loop:
|
||||
if (a == b)
|
||||
return SEXP_TRUE;
|
||||
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)))
|
||||
return
|
||||
sexp_make_boolean((a == b)
|
||||
|| (sexp_flonump(a)
|
||||
&& sexp_make_fixnum(sexp_flonum_value(a)) == b)
|
||||
|| (sexp_flonump(b)
|
||||
&& sexp_make_fixnum(sexp_flonum_value(b)) == a));
|
||||
sexp_make_boolean((sexp_flonump(a) && sexp_fixnump(b)
|
||||
&& sexp_flonum_value(a) == sexp_unbox_fixnum(b))
|
||||
|| (sexp_flonump(b) && sexp_fixnump(a)
|
||||
&& sexp_flonum_value(b) == sexp_unbox_fixnum(a)));
|
||||
#else
|
||||
if (! sexp_pointerp(a))
|
||||
return sexp_make_boolean(sexp_fixnump(a) && sexp_pointerp(b)
|
||||
&& (sexp_unbox_fixnum(a)
|
||||
== sexp_flonum_value(b)));
|
||||
return sexp_make_boolean(sexp_fixnump(a) && sexp_flonump(b)
|
||||
&& (sexp_unbox_fixnum(a) == sexp_flonum_value(b)));
|
||||
else if (! sexp_pointerp(b))
|
||||
return sexp_make_boolean(sexp_fixnump(b) && sexp_pointerp(a)
|
||||
&& (sexp_unbox_fixnum(b)
|
||||
== sexp_flonum_value(a)));
|
||||
return sexp_make_boolean(sexp_fixnump(b) && sexp_flonump(a)
|
||||
&& (sexp_unbox_fixnum(b) == sexp_flonum_value(a)));
|
||||
#endif
|
||||
|
||||
if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
|
||||
#if USE_BIGNUMS && ! USE_IMMEDIATE_FLONUMS
|
||||
if (sexp_pointer_tag(a) == SEXP_FLONUM) {tmp=a; a=b; b=tmp;}
|
||||
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
|
||||
return sexp_make_boolean((sexp_pointer_tag(b) == SEXP_FLONUM)
|
||||
&& sexp_fp_integerp(b)
|
||||
&& ! sexp_bignum_compare(a, sexp_double_to_bignum(ctx, sexp_flonum_value(b))));
|
||||
else
|
||||
#endif
|
||||
if (sexp_pointer_tag(a) != sexp_pointer_tag(b))
|
||||
return SEXP_FALSE;
|
||||
switch (sexp_pointer_tag(a)) {
|
||||
case SEXP_PAIR:
|
||||
if (sexp_equalp(ctx, sexp_car(a), sexp_car(b)) == SEXP_FALSE)
|
||||
return SEXP_FALSE;
|
||||
a = sexp_cdr(a);
|
||||
b = sexp_cdr(b);
|
||||
goto loop;
|
||||
case SEXP_VECTOR:
|
||||
len = sexp_vector_length(a);
|
||||
if (len != sexp_vector_length(b))
|
||||
return SEXP_FALSE;
|
||||
v1 = sexp_vector_data(a);
|
||||
v2 = sexp_vector_data(b);
|
||||
for (len--; len > 0; len--)
|
||||
if (sexp_equalp(ctx, v1[len], v2[len]) == SEXP_FALSE)
|
||||
return SEXP_FALSE;
|
||||
return SEXP_TRUE;
|
||||
case SEXP_STRING:
|
||||
return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b))
|
||||
&& (! strncmp(sexp_string_data(a),
|
||||
sexp_string_data(b),
|
||||
sexp_string_length(a))));
|
||||
}
|
||||
|
||||
/* a and b are both pointers of the same type */
|
||||
#if USE_BIGNUMS
|
||||
case SEXP_BIGNUM:
|
||||
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
|
||||
return sexp_make_boolean(!sexp_bignum_compare(a, b));
|
||||
#endif
|
||||
#if ! USE_IMMEDIATE_FLONUMS
|
||||
case SEXP_FLONUM:
|
||||
#if USE_FLONUMS && ! USE_IMMEDIATE_FLONUMS
|
||||
if (sexp_pointer_tag(a) == SEXP_FLONUM)
|
||||
return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
|
||||
#endif
|
||||
default:
|
||||
t = &(sexp_type_specs[sexp_pointer_tag(a)]);
|
||||
p0 = ((char*)a) + offsetof(struct sexp_struct, value);
|
||||
p = (sexp*) (((char*)a) + sexp_type_field_base(t));
|
||||
q0 = ((char*)b) + offsetof(struct sexp_struct, value);
|
||||
q = (sexp*) (((char*)b) + sexp_type_field_base(t));
|
||||
if ((sexp)p == a) {p=(sexp*)p0; q=(sexp*)q0;}
|
||||
/* check preliminary non-object data */
|
||||
if ((p0 < (char*)p) && memcmp(p0, q0, ((char*)p - p0)))
|
||||
return SEXP_FALSE;
|
||||
/* check trailing non-object data */
|
||||
size = sexp_type_size_of_object(t, a) - offsetof(struct sexp_struct, value);
|
||||
p0 = ((char*)p + sexp_type_num_slots_of_object(t,a)*sizeof(sexp));
|
||||
if (((char*)a + size) > p0) {
|
||||
q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp));
|
||||
if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value))
|
||||
return SEXP_FALSE;
|
||||
if (memcmp(p0, q0, size-((char*)p0-(char*)p)))
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
/* check eq-object slots */
|
||||
len = sexp_type_num_eq_slots_of_object(t, a);
|
||||
if (len > 0) {
|
||||
for (i=0; i<len-1; i++)
|
||||
if (p[i] != q[i] && sexp_not(sexp_equalp(ctx, p[i], q[i])))
|
||||
return SEXP_FALSE;
|
||||
/* tail-recurse on the last value */
|
||||
a = p[len-1]; b = q[len-1]; goto loop;
|
||||
}
|
||||
return SEXP_TRUE;
|
||||
}
|
||||
|
||||
/********************* strings, symbols, vectors **********************/
|
||||
|
|
@ -572,6 +591,8 @@ sexp sexp_intern(sexp ctx, char *str) {
|
|||
}
|
||||
|
||||
sexp sexp_string_to_symbol (sexp ctx, sexp str) {
|
||||
if (! sexp_stringp(str))
|
||||
return sexp_type_exception(ctx, "string->symbol: not a string", str);
|
||||
return sexp_intern(ctx, sexp_string_data(str));
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue