mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-04 11:46:37 +02:00
adding immediate flonum support
This commit is contained in:
Alex Shinn
parent
8a8e7c165e
commit
9e6a0c1300
7 changed files with 68 additions and 19 deletions
3
config.h
3
config.h
|
|
@ -14,6 +14,9 @@
|
|||
/* uncomment this if you only want fixnum support */
|
||||
/* #define USE_FLONUMS 0 */
|
||||
|
||||
/* uncomment this if you want immediate flonums */
|
||||
#define USE_IMMEDIATE_FLONUMS 1
|
||||
|
||||
/* uncomment this if you don't need extended math operations */
|
||||
/* #define USE_MATH 0 */
|
||||
|
||||
|
|
|
|||
2
debug.c
2
debug.c
|
|
@ -62,6 +62,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
|
|||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
#ifdef DEBUG_VM
|
||||
static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
|
||||
int i;
|
||||
for (i=0; i<top; i++) {
|
||||
|
|
@ -70,4 +71,5 @@ static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
|
|||
sexp_printf(out, "\n");
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
|
|
|
|||
|
|
@ -32,6 +32,10 @@
|
|||
#define USE_FLONUMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_IMMEDIATE_FLONUMS
|
||||
#define USE_IMMEDIATE_FLONUMS 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MATH
|
||||
#define USE_MATH 1
|
||||
#endif
|
||||
|
|
|
|||
2
eval.c
2
eval.c
|
|
@ -1006,7 +1006,7 @@ static void generate_lambda (sexp ctx, sexp lambda) {
|
|||
sexp_context_tailp(ctx2) = 1;
|
||||
generate(ctx2, sexp_lambda_body(lambda));
|
||||
flags = sexp_make_integer((sexp_listp(ctx2, sexp_lambda_params(lambda))
|
||||
== SEXP_FALSE) ? 1 : 0);
|
||||
== SEXP_FALSE) ? 1uL : 0uL);
|
||||
len = sexp_length(ctx2, sexp_lambda_params(lambda));
|
||||
bc = finalize_bytecode(ctx2);
|
||||
sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
|
||||
|
|
|
|||
18
gc.c
18
gc.c
|
|
@ -32,7 +32,7 @@ sexp_uint_t sexp_allocated_bytes (sexp x) {
|
|||
sexp_uint_t res, *len_ptr;
|
||||
sexp t;
|
||||
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT))
|
||||
return sexp_align(1, 4);
|
||||
return sexp_heap_align(1);
|
||||
t = &(sexp_types[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);
|
||||
|
|
@ -83,7 +83,7 @@ sexp sexp_sweep (sexp ctx) {
|
|||
char *end;
|
||||
/* scan over the whole heap */
|
||||
for ( ; h; h=h->next) {
|
||||
p = (sexp) (h->data + sexp_align(sexp_sizeof(pair), 4));
|
||||
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
|
||||
q = h->free_list;
|
||||
end = (char*)h->data + h->size;
|
||||
while (((char*)p) < end) {
|
||||
|
|
@ -94,7 +94,7 @@ sexp sexp_sweep (sexp ctx) {
|
|||
p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p));
|
||||
continue;
|
||||
}
|
||||
size = sexp_align(sexp_allocated_bytes(p), 4);
|
||||
size = sexp_heap_align(sexp_allocated_bytes(p));
|
||||
if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
|
||||
sum_freed += size;
|
||||
if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p)
|
||||
|
|
@ -153,15 +153,15 @@ sexp_heap sexp_make_heap (size_t size) {
|
|||
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
|
||||
if (h) {
|
||||
h->size = size;
|
||||
h->data = (char*) sexp_align((sexp_uint_t)&(h->data), 4);
|
||||
h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data));
|
||||
free = h->free_list = (sexp) h->data;
|
||||
h->next = NULL;
|
||||
next = (sexp) ((char*)free + sexp_align(sexp_sizeof(pair), 4));
|
||||
next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair)));
|
||||
sexp_pointer_tag(free) = SEXP_PAIR;
|
||||
sexp_car(free) = 0; /* actually sexp_sizeof(pair) */
|
||||
sexp_cdr(free) = next;
|
||||
sexp_pointer_tag(next) = SEXP_PAIR;
|
||||
sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4));
|
||||
sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair)));
|
||||
sexp_cdr(next) = SEXP_NULL;
|
||||
}
|
||||
return h;
|
||||
|
|
@ -171,7 +171,7 @@ int sexp_grow_heap (sexp ctx, size_t size) {
|
|||
size_t cur_size, new_size;
|
||||
sexp_heap h = sexp_heap_last(heap);
|
||||
cur_size = h->size;
|
||||
new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4);
|
||||
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
|
||||
h->next = sexp_make_heap(new_size);
|
||||
return (h->next != NULL);
|
||||
}
|
||||
|
|
@ -207,7 +207,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
void *res;
|
||||
size_t freed;
|
||||
sexp_heap h;
|
||||
size = sexp_align(size, 4);
|
||||
size = sexp_heap_align(size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
freed = sexp_unbox_integer(sexp_gc(ctx));
|
||||
|
|
@ -226,7 +226,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
}
|
||||
|
||||
void sexp_gc_init () {
|
||||
sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4);
|
||||
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
||||
heap = sexp_make_heap(size);
|
||||
/* the +32 is a hack, but this is just for debugging anyway */
|
||||
stack_base = ((sexp*)&size) + 32;
|
||||
|
|
|
|||
34
sexp.c
34
sexp.c
|
|
@ -5,7 +5,7 @@
|
|||
#include "sexp.h"
|
||||
|
||||
/* optional huffman-compressed immediate symbols */
|
||||
#ifdef USE_HUFF_SYMS
|
||||
#if USE_HUFF_SYMS
|
||||
struct huff_entry {
|
||||
unsigned char len;
|
||||
unsigned short bits;
|
||||
|
|
@ -326,6 +326,15 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
|||
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_integer(sexp_flonum_value(a)) == b)
|
||||
|| (sexp_flonump(b)
|
||||
&& sexp_make_integer(sexp_flonum_value(b)) == a));
|
||||
#else
|
||||
if (! sexp_pointerp(a))
|
||||
return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b)
|
||||
&& (sexp_unbox_integer(a)
|
||||
|
|
@ -334,6 +343,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
|||
return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a)
|
||||
&& (sexp_unbox_integer(b)
|
||||
== sexp_flonum_value(a)));
|
||||
#endif
|
||||
if (sexp_pointer_tag(a) != sexp_pointer_tag(b))
|
||||
return SEXP_FALSE;
|
||||
switch (sexp_pointer_tag(a)) {
|
||||
|
|
@ -358,8 +368,10 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
|||
&& (! strncmp(sexp_string_data(a),
|
||||
sexp_string_data(b),
|
||||
sexp_string_length(a))));
|
||||
#if ! USE_IMMEDIATE_FLONUMS
|
||||
case SEXP_FLONUM:
|
||||
return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
|
||||
#endif
|
||||
default:
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
|
|
@ -367,11 +379,13 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
|
|||
|
||||
/********************* strings, symbols, vectors **********************/
|
||||
|
||||
#if ! USE_IMMEDIATE_FLONUMS
|
||||
sexp sexp_make_flonum(sexp ctx, double f) {
|
||||
sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM);
|
||||
sexp_flonum_value(x) = f;
|
||||
return x;
|
||||
}
|
||||
#endif
|
||||
|
||||
sexp sexp_make_string(sexp ctx, sexp len, sexp ch) {
|
||||
sexp_sint_t clen = sexp_unbox_integer(len);
|
||||
|
|
@ -780,6 +794,11 @@ void sexp_write (sexp obj, sexp out) {
|
|||
}
|
||||
} else if (sexp_integerp(obj)) {
|
||||
sexp_printf(out, "%ld", sexp_unbox_integer(obj));
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
} else if (sexp_flonump(obj)) {
|
||||
f = sexp_flonum_value(obj);
|
||||
sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : "");
|
||||
#endif
|
||||
} else if (sexp_charp(obj)) {
|
||||
if (obj == sexp_make_character(' '))
|
||||
sexp_write_string("#\\space", out);
|
||||
|
|
@ -933,7 +952,12 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) {
|
|||
if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) {
|
||||
res = (sexp_sint_t) sexp_flonum_value(f);
|
||||
} else {
|
||||
if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f);
|
||||
if (negativep)
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
f = sexp_make_flonum(ctx, -sexp_flonum_value(f));
|
||||
#else
|
||||
sexp_flonum_value(f) = -sexp_flonum_value(f);
|
||||
#endif
|
||||
return f;
|
||||
}
|
||||
} else {
|
||||
|
|
@ -1146,9 +1170,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
|
|||
sexp_push_char(c2, in);
|
||||
res = sexp_read_number(ctx, in, 10);
|
||||
if ((c1 == '-') && ! sexp_exceptionp(res)) {
|
||||
#ifdef USE_FLONUMS
|
||||
#if USE_FLONUMS
|
||||
if (sexp_flonump(res))
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res));
|
||||
#else
|
||||
sexp_flonum_value(res) = -1 * sexp_flonum_value(res);
|
||||
#endif
|
||||
else
|
||||
#endif
|
||||
res = sexp_fx_mul(res, -1);
|
||||
|
|
|
|||
24
sexp.h
24
sexp.h
|
|
@ -21,8 +21,8 @@
|
|||
/* tagging system
|
||||
* bits end in 00: pointer
|
||||
* 01: fixnum
|
||||
* 011: <unused>
|
||||
* 111: immediate symbol
|
||||
* 011: immediate flonum (optional)
|
||||
* 111: immediate symbol (optional)
|
||||
* 0110: char
|
||||
* 1110: other immediate object (NULL, TRUE, FALSE)
|
||||
*/
|
||||
|
|
@ -38,6 +38,7 @@
|
|||
#define SEXP_POINTER_TAG 0
|
||||
#define SEXP_FIXNUM_TAG 1
|
||||
#define SEXP_ISYMBOL_TAG 7
|
||||
#define SEXP_IFLONUM_TAG 3
|
||||
#define SEXP_CHAR_TAG 6
|
||||
#define SEXP_EXTENDED_TAG 14
|
||||
|
||||
|
|
@ -256,6 +257,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
#endif
|
||||
|
||||
#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
|
||||
#define sexp_heap_align(n) sexp_align(n, 4)
|
||||
|
||||
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
|
||||
+ sizeof(((sexp)0)->value.x))
|
||||
|
|
@ -280,12 +282,25 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
|
||||
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
|
||||
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
union sexp_flonum_conv {
|
||||
float flonum;
|
||||
sexp_uint_t bits;
|
||||
};
|
||||
#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG)
|
||||
#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG))
|
||||
#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((sexp_uint_t)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum)
|
||||
#else
|
||||
#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM))
|
||||
#define sexp_flonum_value(f) ((f)->value.flonum)
|
||||
sexp sexp_make_flonum(sexp ctx, double f);
|
||||
#endif
|
||||
|
||||
#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE))
|
||||
#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR))
|
||||
#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING))
|
||||
#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL))
|
||||
#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR))
|
||||
#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM))
|
||||
#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT))
|
||||
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
|
||||
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
|
||||
|
|
@ -319,8 +334,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
|
||||
#define sexp_unbox_character(n) ((int) (((sexp_sint_t)n)>>SEXP_EXTENDED_BITS))
|
||||
|
||||
#define sexp_flonum_value(f) ((f)->value.flonum)
|
||||
|
||||
#if USE_FLONUMS
|
||||
#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x)))
|
||||
#else
|
||||
|
|
@ -515,7 +528,6 @@ sexp sexp_length(sexp ctx, sexp ls);
|
|||
sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen);
|
||||
sexp sexp_make_string(sexp ctx, sexp len, sexp ch);
|
||||
sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end);
|
||||
sexp sexp_make_flonum(sexp ctx, double f);
|
||||
sexp sexp_intern(sexp ctx, char *str);
|
||||
sexp sexp_string_to_symbol(sexp ctx, sexp str);
|
||||
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue