Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 22:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

making EQUAL? comparison data-driven

Browse source 
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 2009-11-15 18:45:08 +09:00
parent 6db4ed9155
commit 311c567c06
4 changed files with 151 additions and 119 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
eval.c
View file

@ -1533,14 +1533,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_NULLP: case OP_NULLP:
_ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
case OP_INTEGERP: case OP_INTEGERP:
j = sexp_integerp(_ARG1); _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break;
#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;
case OP_SYMBOLP: case OP_SYMBOLP:
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
case OP_CHARP: case OP_CHARP:
@ -2432,7 +2425,6 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
sexp_gc_var1(thunk); sexp_gc_var1(thunk);
sexp_gc_preserve1(ctx, thunk); sexp_gc_preserve1(ctx, thunk);
ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
/* sexp_context_parent(ctx2) = ctx; */
thunk = sexp_compile(ctx2, obj); thunk = sexp_compile(ctx2, obj);
if (sexp_exceptionp(thunk)) { if (sexp_exceptionp(thunk)) {
sexp_print_exception(ctx2, thunk, sexp_print_exception(ctx2, thunk,

10
gc.c
View file

@ -43,18 +43,16 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
} }
sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t sexp_allocated_bytes (sexp x) {
sexp_uint_t res, *len_ptr; sexp_uint_t res;
sexp t; sexp t;
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types)) if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types))
return sexp_heap_align(1); return sexp_heap_align(1);
t = &(sexp_type_specs[sexp_pointer_tag(x)]); t = &(sexp_type_specs[sexp_pointer_tag(x)]);
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); res = sexp_type_size_of_object(t, x);
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
return res; return res;
} }
void sexp_mark (sexp x) { void sexp_mark (sexp x) {
sexp_uint_t *len_ptr;
sexp_sint_t i, len; sexp_sint_t i, len;
sexp t, *p; sexp t, *p;
struct sexp_gc_var_t *saves; struct sexp_gc_var_t *saves;
@ -67,9 +65,7 @@ void sexp_mark (sexp x) {
if (saves->var) sexp_mark(*(saves->var)); if (saves->var) sexp_mark(*(saves->var));
t = &(sexp_type_specs[sexp_pointer_tag(x)]); t = &(sexp_type_specs[sexp_pointer_tag(x)]);
p = (sexp*) (((char*)x) + sexp_type_field_base(t)); 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_num_slots_of_object(t, x) - 1;
len = sexp_type_field_len_base(t)
+ len_ptr[0]*sexp_type_field_len_scale(t) - 1;
if (len >= 0) { if (len >= 0) {
for (i=0; i<len; i++) for (i=0; i<len; i++)
sexp_mark(p[i]); sexp_mark(p[i]);

71
include/chibi/sexp.h
View file

@ -98,12 +98,11 @@ enum sexp_types {
typedef unsigned long sexp_uint_t; typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t; typedef long sexp_sint_t;
/* #if SEXP_64_BIT */ #if SEXP_64_BIT
/* typedef unsigned int sexp_tag_t; */ typedef unsigned int sexp_tag_t;
/* #else */ #else
/* typedef unsigned short sexp_tag_t; */ typedef unsigned short sexp_tag_t;
/* #endif */ #endif
typedef unsigned char sexp_tag_t;
typedef struct sexp_struct *sexp; typedef struct sexp_struct *sexp;
#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2)) #define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2))
@ -143,8 +142,10 @@ struct sexp_struct {
double flonum; double flonum;
struct { struct {
sexp_tag_t tag; sexp_tag_t tag;
short field_base, field_len_base, field_len_off, field_len_scale; short field_base, field_eq_len_base, field_len_base, field_len_off;
short size_base, size_off, size_scale; unsigned short field_len_scale;
short size_base, size_off;
unsigned short size_scale;
char *name; char *name;
} type; } type;
struct { struct {
@ -165,7 +166,8 @@ struct sexp_struct {
struct { struct {
FILE *stream; FILE *stream;
char *buf; char *buf;
sexp_uint_t offset, line, size, openp, sourcep; char openp, sourcep;
sexp_uint_t offset, line, size;
sexp name; sexp name;
sexp cookie; sexp cookie;
} port; } 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_gc_mark(x) ((x)->gc_mark)
#define sexp_immutablep(x) ((x)->immutablep) #define sexp_immutablep(x) ((x)->immutablep)
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) #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_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_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))) #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)) #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 #if USE_BIGNUMS
SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); 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 #else
#define sexp_make_integer(ctx, x) sexp_make_fixnum(x) #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 #endif
#if USE_FLONUMS #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_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
#define sexp_type_tag(x) ((x)->value.type.tag) #define sexp_type_tag(x) ((x)->value.type.tag)
#define sexp_type_field_base(x) ((x)->value.type.field_base) #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_eq_len_base(x) ((x)->value.type.field_eq_len_base)
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) #define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) #define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
#define sexp_type_size_base(x) ((x)->value.type.size_base) #define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
#define sexp_type_size_off(x) ((x)->value.type.size_off) #define sexp_type_size_base(x) ((x)->value.type.size_base)
#define sexp_type_size_scale(x) ((x)->value.type.size_scale) #define sexp_type_size_off(x) ((x)->value.type.size_off)
#define sexp_type_name(x) ((x)->value.type.name) #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_sign(x) ((x)->value.bignum.sign)
#define sexp_bignum_length(x) ((x)->value.bignum.length) #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); SEXP_API void sexp_init(void);
#if USE_TYPE_DEFS #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); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
#endif #endif

179
sexp.c
View file

@ -59,40 +59,40 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
return res; return res;
} }
#define _DEF_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,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[] = { static struct sexp_struct _sexp_type_specs[] = {
_DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"), _DEF_TYPE(SEXP_OBJECT, 0, 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_TYPE, 0, 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_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum"),
_DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"), _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char"),
_DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"), _DEF_TYPE(SEXP_BOOLEAN, 0, 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_PAIR, sexp_offsetof(pair, car), 2, 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_SYMBOL, sexp_offsetof(symbol, string), 1, 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_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, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector"), _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, sexp_sizeof(flonum), 0, 0, "flonum"), _DEF_TYPE(SEXP_FLONUM, 0, 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_BIGNUM, 0, 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_CPOINTER, 0, 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_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, 0, 0, sexp_sizeof(port), 0, 0, "output-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, 0, 0, sexp_sizeof(exception), 0, 0, "exception"), _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, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"), _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, 0, 0, sexp_sizeof(macro), 0, 0, "macro"), _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, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"), _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, 0, 0, sexp_sizeof(env), 0, 0, "environment"), _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, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), _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, sexp_sizeof(core), 0, 0, "core-form"), _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, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), _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, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), _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, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), _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, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), _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, 0, 0, sexp_sizeof(set), 0, 0, "set!"), _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, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), _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, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), _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, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), _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, 0, 0, sexp_sizeof(context), 0, 0, "context"), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
}; };
#undef _DEF_TYPE #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_num_types = SEXP_NUM_CORE_TYPES;
static sexp_uint_t sexp_type_array_size = 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 sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
sexp sb, sexp so, sexp sc) { sexp flo, sexp fls, sexp sb, sexp so, sexp sc) {
struct sexp_struct *type, *new, *tmp; struct sexp_struct *type, *new, *tmp;
sexp res; sexp res;
sexp_uint_t i, len; 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_pointer_tag(type) = SEXP_TYPE;
sexp_type_tag(type) = sexp_num_types++; sexp_type_tag(type) = sexp_num_types++;
sexp_type_field_base(type) = sexp_unbox_fixnum(fb); 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_base(type) = sexp_unbox_fixnum(flb);
sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo); sexp_type_field_len_off(type) = sexp_unbox_fixnum(flo);
sexp_type_field_len_scale(type) = sexp_unbox_fixnum(fls); 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) { sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
short type_size short type_size
= sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots); = sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots);
return sexp_register_type(ctx, name, return
sexp_make_fixnum(offsetof(struct sexp_struct, value)), sexp_register_type(ctx, name,
slots, sexp_make_fixnum(0), sexp_make_fixnum(0), sexp_make_fixnum(offsetof(struct sexp_struct, value)),
sexp_make_fixnum(type_size), sexp_make_fixnum(0), slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
sexp_make_fixnum(0)); sexp_make_fixnum(type_size), sexp_make_fixnum(0),
sexp_make_fixnum(0));
} }
#else #else
@ -382,64 +384,81 @@ sexp sexp_length (sexp ctx, sexp ls) {
} }
sexp sexp_equalp (sexp ctx, sexp a, sexp b) { sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
sexp_uint_t len; sexp_uint_t size;
sexp *v1, *v2; sexp_sint_t i, len;
sexp t, tmp, *p, *q;
char *p0, *q0;
loop: loop:
if (a == b) if (a == b)
return SEXP_TRUE; return SEXP_TRUE;
#if USE_IMMEDIATE_FLONUMS #if USE_IMMEDIATE_FLONUMS
if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))) if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)))
return return
sexp_make_boolean((a == b) sexp_make_boolean((sexp_flonump(a) && sexp_fixnump(b)
|| (sexp_flonump(a) && sexp_flonum_value(a) == sexp_unbox_fixnum(b))
&& sexp_make_fixnum(sexp_flonum_value(a)) == b) || (sexp_flonump(b) && sexp_fixnump(a)
|| (sexp_flonump(b) && sexp_flonum_value(b) == sexp_unbox_fixnum(a)));
&& sexp_make_fixnum(sexp_flonum_value(b)) == a));
#else #else
if (! sexp_pointerp(a)) if (! sexp_pointerp(a))
return sexp_make_boolean(sexp_fixnump(a) && sexp_pointerp(b) return sexp_make_boolean(sexp_fixnump(a) && sexp_flonump(b)
&& (sexp_unbox_fixnum(a) && (sexp_unbox_fixnum(a) == sexp_flonum_value(b)));
== sexp_flonum_value(b)));
else if (! sexp_pointerp(b)) else if (! sexp_pointerp(b))
return sexp_make_boolean(sexp_fixnump(b) && sexp_pointerp(a) return sexp_make_boolean(sexp_fixnump(b) && sexp_flonump(a)
&& (sexp_unbox_fixnum(b) && (sexp_unbox_fixnum(b) == sexp_flonum_value(a)));
== 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 #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; return SEXP_FALSE;
a = sexp_cdr(a); }
b = sexp_cdr(b);
goto loop; /* a and b are both pointers of the same type */
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))));
#if USE_BIGNUMS #if USE_BIGNUMS
case SEXP_BIGNUM: if (sexp_pointer_tag(a) == SEXP_BIGNUM)
return sexp_make_boolean(!sexp_bignum_compare(a, b)); return sexp_make_boolean(!sexp_bignum_compare(a, b));
#endif #endif
#if ! USE_IMMEDIATE_FLONUMS #if USE_FLONUMS && ! USE_IMMEDIATE_FLONUMS
case SEXP_FLONUM: if (sexp_pointer_tag(a) == SEXP_FLONUM)
return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
#endif #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; 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 **********************/ /********************* strings, symbols, vectors **********************/
@ -572,6 +591,8 @@ sexp sexp_intern(sexp ctx, char *str) {
} }
sexp sexp_string_to_symbol (sexp ctx, sexp 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)); return sexp_intern(ctx, sexp_string_data(str));
} }