mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
various fixes, gc can handle running the whole test suite
in a loop hundreds of times. the heuristics for growing the heap still cause it to grow very slowly over time, but nonetheless slower than boehm.
This commit is contained in:
Alex Shinn
parent
9e6a0c1300
commit
56dcf497de
7 changed files with 167 additions and 159 deletions
14
Makefile
14
Makefile
|
|
@ -9,21 +9,17 @@ LIBDIR=$(PREFIX)/lib
|
|||
INCDIR=$(PREFIX)/include/chibi-scheme
|
||||
MODDIR=$(PREFIX)/share/chibi-scheme
|
||||
|
||||
LDFLAGS=-lm
|
||||
LDFLAGS=-lm #-lgc -L/opt/local/lib
|
||||
|
||||
# -Oz for smaller size on darwin
|
||||
CFLAGS=-Wall -O2 -g #-save-temps
|
||||
CFLAGS=-Wall -O2 -g #-I/opt/local/include #-save-temps
|
||||
|
||||
./gc/gc.a: ./gc/alloc.c
|
||||
cd gc && make
|
||||
|
||||
sexp.o: sexp.c gc.c sexp.h config.h defaults.h Makefile
|
||||
sexp.o: sexp.c gc.c sexp.h config.h Makefile
|
||||
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
|
||||
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile
|
||||
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
|
||||
|
||||
main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
|
||||
main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile
|
||||
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
|
||||
|
||||
chibi-scheme: main.o sexp.o
|
||||
|
|
|
|||
74
config.h
74
config.h
|
|
@ -14,8 +14,8 @@
|
|||
/* 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 want immediate flonums (experimental) */
|
||||
/* #define USE_IMMEDIATE_FLONUMS 1 */
|
||||
|
||||
/* uncomment this if you don't need extended math operations */
|
||||
/* #define USE_MATH 0 */
|
||||
|
|
@ -32,9 +32,75 @@
|
|||
/* uncomment this to disable string ports */
|
||||
/* #define USE_STRING_STREAMS 0 */
|
||||
|
||||
/* uncomment this to disable a small optimization for let */
|
||||
/* #define USE_FAST_LET 0 */
|
||||
/* uncomment this to disable stack checks */
|
||||
/* #define USE_CHECK_STACK 0 */
|
||||
|
||||
/* uncomment this to enable debugging utilities */
|
||||
/* #define USE_DEBUG 1 */
|
||||
|
||||
/************************************************************************/
|
||||
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
|
||||
/************************************************************************/
|
||||
|
||||
#if HAVE_ERR_H
|
||||
#include <err.h>
|
||||
#else
|
||||
/* requires msg be a string literal, and at least one argument */
|
||||
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
|
||||
#endif
|
||||
|
||||
#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
|
||||
#define SEXP_BSD 1
|
||||
#else
|
||||
#define SEXP_BSD 0
|
||||
#define _GNU_SOURCE
|
||||
#endif
|
||||
|
||||
#ifndef USE_BOEHM
|
||||
#define USE_BOEHM 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MALLOC
|
||||
#define USE_MALLOC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG_GC
|
||||
#define USE_DEBUG_GC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_FLONUMS
|
||||
#define USE_FLONUMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_IMMEDIATE_FLONUMS
|
||||
#define USE_IMMEDIATE_FLONUMS 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MATH
|
||||
#define USE_MATH 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_WARN_UNDEFS
|
||||
#define USE_WARN_UNDEFS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HUFF_SYMS
|
||||
#define USE_HUFF_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HASH_SYMS
|
||||
#define USE_HASH_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG
|
||||
#define USE_DEBUG 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_STRING_STREAMS
|
||||
#define USE_STRING_STREAMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_CHECK_STACK
|
||||
#define USE_CHECK_STACK 1
|
||||
#endif
|
||||
|
||||
|
|
|
|||
70
defaults.h
70
defaults.h
|
|
@ -1,70 +0,0 @@
|
|||
/* defaults.h -- defaults for unspecified configs */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#if HAVE_ERR_H
|
||||
#include <err.h>
|
||||
#else
|
||||
/* requires msg be a string literal, and at least one argument */
|
||||
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
|
||||
#endif
|
||||
|
||||
#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
|
||||
#define SEXP_BSD 1
|
||||
#else
|
||||
#define SEXP_BSD 0
|
||||
#define _GNU_SOURCE
|
||||
#endif
|
||||
|
||||
#ifndef USE_BOEHM
|
||||
#define USE_BOEHM 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MALLOC
|
||||
#define USE_MALLOC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG_GC
|
||||
#define USE_DEBUG_GC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_FLONUMS
|
||||
#define USE_FLONUMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_IMMEDIATE_FLONUMS
|
||||
#define USE_IMMEDIATE_FLONUMS 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MATH
|
||||
#define USE_MATH 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_WARN_UNDEFS
|
||||
#define USE_WARN_UNDEFS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HUFF_SYMS
|
||||
#define USE_HUFF_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HASH_SYMS
|
||||
#define USE_HASH_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG
|
||||
#define USE_DEBUG 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_STRING_STREAMS
|
||||
#define USE_STRING_STREAMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_FAST_LET
|
||||
#define USE_FAST_LET 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_CHECK_STACK
|
||||
#define USE_CHECK_STACK 0
|
||||
#endif
|
||||
|
||||
50
eval.c
50
eval.c
|
|
@ -1310,8 +1310,10 @@ sexp vm (sexp ctx, sexp proc) {
|
|||
goto make_call;
|
||||
case OP_CALL:
|
||||
#if USE_CHECK_STACK
|
||||
if (top >= INIT_STACK_SIZE)
|
||||
sexp_raise("out of stack space", SEXP_NULL);
|
||||
if (top+16 >= INIT_STACK_SIZE) {
|
||||
fprintf(stderr, "out of stack space\n");
|
||||
exit(70);
|
||||
}
|
||||
#endif
|
||||
i = sexp_unbox_integer(_WORD0);
|
||||
tmp1 = _ARG1;
|
||||
|
|
@ -1550,9 +1552,9 @@ sexp vm (sexp ctx, sexp proc) {
|
|||
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2);
|
||||
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
|
||||
_ARG2 = sexp_fp_add(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
|
||||
_ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_integer(_ARG2));
|
||||
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_add(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
|
||||
_ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) + sexp_flonum_value(_ARG2));
|
||||
#endif
|
||||
else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2));
|
||||
top--;
|
||||
|
|
@ -1564,9 +1566,9 @@ sexp vm (sexp ctx, sexp proc) {
|
|||
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2);
|
||||
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
|
||||
_ARG2 = sexp_fp_sub(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
|
||||
_ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_integer(_ARG2));
|
||||
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_sub(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
|
||||
_ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) - sexp_flonum_value(_ARG2));
|
||||
#endif
|
||||
else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2));
|
||||
top--;
|
||||
|
|
@ -1578,9 +1580,9 @@ sexp vm (sexp ctx, sexp proc) {
|
|||
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2);
|
||||
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
|
||||
_ARG2 = sexp_fp_mul(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
|
||||
_ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_integer(_ARG2));
|
||||
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_mul(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
|
||||
_ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) * sexp_flonum_value(_ARG2));
|
||||
#endif
|
||||
else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2));
|
||||
top--;
|
||||
|
|
@ -1588,17 +1590,22 @@ sexp vm (sexp ctx, sexp proc) {
|
|||
case OP_DIV:
|
||||
if (_ARG2 == sexp_make_integer(0))
|
||||
sexp_raise("divide by zero", SEXP_NULL);
|
||||
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
|
||||
_ARG2 = sexp_fp_div(ctx,
|
||||
sexp_integer_to_flonum(ctx, _ARG1),
|
||||
sexp_integer_to_flonum(ctx, _ARG2));
|
||||
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
|
||||
#if USE_FLONUMS
|
||||
_ARG1 = sexp_integer_to_flonum(ctx, _ARG1);
|
||||
_ARG2 = sexp_integer_to_flonum(ctx, _ARG2);
|
||||
_ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2);
|
||||
#else
|
||||
_ARG2 = sexp_fx_div(_ARG1, _ARG2);
|
||||
#endif
|
||||
}
|
||||
#if USE_FLONUMS
|
||||
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2);
|
||||
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
|
||||
_ARG2 = sexp_fp_div(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2));
|
||||
_ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_integer(_ARG2));
|
||||
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
|
||||
_ARG2 = sexp_fp_div(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2);
|
||||
_ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) / sexp_flonum_value(_ARG2));
|
||||
#endif
|
||||
else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2));
|
||||
top--;
|
||||
|
|
@ -1804,7 +1811,7 @@ static sexp sexp_open_input_file (sexp ctx, sexp path) {
|
|||
if (! in)
|
||||
return
|
||||
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path);
|
||||
return sexp_make_input_port(ctx, in, sexp_string_data(path));
|
||||
return sexp_make_input_port(ctx, in, path);
|
||||
}
|
||||
|
||||
static sexp sexp_open_output_file (sexp ctx, sexp path) {
|
||||
|
|
@ -1815,7 +1822,7 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) {
|
|||
if (! out)
|
||||
return
|
||||
sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path);
|
||||
return sexp_make_input_port(ctx, out, sexp_string_data(path));
|
||||
return sexp_make_input_port(ctx, out, path);
|
||||
}
|
||||
|
||||
static sexp sexp_close_port (sexp ctx, sexp port) {
|
||||
|
|
@ -1834,13 +1841,16 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) {
|
|||
}
|
||||
|
||||
sexp sexp_load (sexp ctx, sexp source, sexp env) {
|
||||
sexp tmp, out, res=SEXP_VOID;
|
||||
sexp tmp, out;
|
||||
sexp_gc_var(ctx, ctx2, s_ctx2);
|
||||
sexp_gc_var(ctx, x, s_x);
|
||||
sexp_gc_var(ctx, in, s_in);
|
||||
sexp_gc_var(ctx, res, s_res);
|
||||
sexp_gc_preserve(ctx, ctx2, s_ctx2);
|
||||
sexp_gc_preserve(ctx, x, s_x);
|
||||
sexp_gc_preserve(ctx, in, s_in);
|
||||
sexp_gc_preserve(ctx, res, s_res);
|
||||
res = SEXP_VOID;
|
||||
in = sexp_open_input_file(ctx, source);
|
||||
out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
|
||||
ctx2 = sexp_make_context(ctx, NULL, env);
|
||||
|
|
@ -2021,11 +2031,11 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op);
|
||||
}
|
||||
env_define(ctx, e, the_cur_in_symbol,
|
||||
sexp_make_input_port(ctx, stdin, NULL));
|
||||
sexp_make_input_port(ctx, stdin, SEXP_FALSE));
|
||||
env_define(ctx, e, the_cur_out_symbol,
|
||||
sexp_make_output_port(ctx, stdout, NULL));
|
||||
sexp_make_output_port(ctx, stdout, SEXP_FALSE));
|
||||
env_define(ctx, e, the_cur_err_symbol,
|
||||
sexp_make_output_port(ctx, stderr, NULL));
|
||||
sexp_make_output_port(ctx, stderr, SEXP_FALSE));
|
||||
env_define(ctx, e, the_interaction_env_symbol, e);
|
||||
sexp_gc_release(ctx, e, s_e);
|
||||
return e;
|
||||
|
|
|
|||
54
gc.c
54
gc.c
|
|
@ -4,11 +4,12 @@
|
|||
|
||||
#include "sexp.h"
|
||||
|
||||
/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */
|
||||
#define SEXP_INITIAL_HEAP_SIZE 37000
|
||||
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
|
||||
#define SEXP_MAXIMUM_HEAP_SIZE 0
|
||||
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum))
|
||||
#define SEXP_GROW_HEAP_RATIO 0.8
|
||||
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair))
|
||||
#define SEXP_GROW_HEAP_RATIO 0.7
|
||||
|
||||
#define sexp_heap_align(n) sexp_align(n, 4)
|
||||
|
||||
typedef struct sexp_heap *sexp_heap;
|
||||
|
||||
|
|
@ -67,7 +68,7 @@ void sexp_mark (sexp x) {
|
|||
#if USE_DEBUG_GC
|
||||
int stack_references_pointer_p (sexp ctx, sexp x) {
|
||||
sexp *p;
|
||||
for (p=&x; p<stack_base; p++)
|
||||
for (p=(&x)+1; p<stack_base; p++)
|
||||
if (*p == x)
|
||||
return 1;
|
||||
return 0;
|
||||
|
|
@ -76,8 +77,8 @@ int stack_references_pointer_p (sexp ctx, sexp x) {
|
|||
#define stack_references_pointer_p(ctx, x) 0
|
||||
#endif
|
||||
|
||||
sexp sexp_sweep (sexp ctx) {
|
||||
sexp_uint_t freed, max_freed=0, sum_freed=0, size;
|
||||
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
||||
size_t freed, max_freed=0, sum_freed=0, size;
|
||||
sexp_heap h = heap;
|
||||
sexp p, q, r;
|
||||
char *end;
|
||||
|
|
@ -133,10 +134,11 @@ sexp sexp_sweep (sexp ctx) {
|
|||
}
|
||||
}
|
||||
}
|
||||
sum_freed_ptr[0] = sum_freed;
|
||||
return sexp_make_integer(max_freed);
|
||||
}
|
||||
|
||||
sexp sexp_gc (sexp ctx) {
|
||||
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
||||
sexp res;
|
||||
int i;
|
||||
sexp_mark(continuation_resumer);
|
||||
|
|
@ -144,26 +146,28 @@ sexp sexp_gc (sexp ctx) {
|
|||
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
||||
sexp_mark(sexp_symbol_table[i]);
|
||||
sexp_mark(ctx);
|
||||
res = sexp_sweep(ctx);
|
||||
res = sexp_sweep(ctx, sum_freed);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp_heap sexp_make_heap (size_t size) {
|
||||
sexp free, next;
|
||||
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
|
||||
if (h) {
|
||||
h->size = size;
|
||||
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_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_heap_align(sexp_sizeof(pair)));
|
||||
sexp_cdr(next) = SEXP_NULL;
|
||||
if (! h) {
|
||||
fprintf(stderr, "out of memory allocating %ld byte heap, aborting\n", size);
|
||||
exit(70);
|
||||
}
|
||||
h->size = size;
|
||||
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_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_heap_align(sexp_sizeof(pair)));
|
||||
sexp_cdr(next) = SEXP_NULL;
|
||||
return h;
|
||||
}
|
||||
|
||||
|
|
@ -205,15 +209,15 @@ void* sexp_try_alloc (sexp ctx, size_t size) {
|
|||
|
||||
void* sexp_alloc (sexp ctx, size_t size) {
|
||||
void *res;
|
||||
size_t freed;
|
||||
size_t max_freed, sum_freed;
|
||||
sexp_heap h;
|
||||
size = sexp_heap_align(size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
freed = sexp_unbox_integer(sexp_gc(ctx));
|
||||
max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed));
|
||||
h = sexp_heap_last(heap);
|
||||
if (((freed < size)
|
||||
|| ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO)))
|
||||
if (((max_freed < size)
|
||||
|| ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO))))
|
||||
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
|
||||
sexp_grow_heap(ctx, size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
|
|
|
|||
53
sexp.c
53
sexp.c
|
|
@ -6,12 +6,12 @@
|
|||
|
||||
/* optional huffman-compressed immediate symbols */
|
||||
#if USE_HUFF_SYMS
|
||||
struct huff_entry {
|
||||
struct sexp_huff_entry {
|
||||
unsigned char len;
|
||||
unsigned short bits;
|
||||
};
|
||||
#include "opt/sexp-hufftabs.c"
|
||||
static struct huff_entry huff_table[] = {
|
||||
static struct sexp_huff_entry huff_table[] = {
|
||||
#include "opt/sexp-huff.c"
|
||||
};
|
||||
#endif
|
||||
|
|
@ -67,8 +67,8 @@ static struct sexp_struct sexp_types[] = {
|
|||
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "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), 4, "bignum"),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"),
|
||||
_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"),
|
||||
|
|
@ -214,8 +214,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
|
|||
sexp_gc_var(ctx, str, s_str);
|
||||
sexp_gc_preserve(ctx, name, s_name);
|
||||
sexp_gc_preserve(ctx, str, s_str);
|
||||
name = (sexp_port_name(port)
|
||||
? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE);
|
||||
name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE);
|
||||
str = sexp_c_string(ctx, msg, -1);
|
||||
res = sexp_make_exception(ctx, the_read_error_symbol,
|
||||
str, irritants, SEXP_FALSE, name,
|
||||
|
|
@ -402,7 +401,8 @@ sexp sexp_make_string(sexp ctx, sexp len, sexp ch) {
|
|||
sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen) {
|
||||
sexp_sint_t len = ((slen >= 0) ? slen : strlen(str));
|
||||
sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID);
|
||||
memcpy(sexp_string_data(s), str, len+1);
|
||||
memcpy(sexp_string_data(s), str, len);
|
||||
sexp_string_data(s)[len] = '\0';
|
||||
return s;
|
||||
}
|
||||
|
||||
|
|
@ -425,7 +425,8 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) {
|
|||
res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID);
|
||||
memcpy(sexp_string_data(res),
|
||||
sexp_string_data(str)+sexp_unbox_integer(start),
|
||||
sexp_string_length(res)+1);
|
||||
sexp_string_length(res));
|
||||
sexp_string_data(res)[sexp_string_length(res)] = '\0';
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -442,7 +443,7 @@ static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) {
|
|||
#endif
|
||||
|
||||
sexp sexp_intern(sexp ctx, char *str) {
|
||||
struct huff_entry he;
|
||||
struct sexp_huff_entry he;
|
||||
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket;
|
||||
char c, *p=str;
|
||||
sexp ls;
|
||||
|
|
@ -529,9 +530,10 @@ sexp sexp_vector(sexp ctx, int count, ...) {
|
|||
|
||||
#if SEXP_BSD
|
||||
|
||||
#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0))
|
||||
#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1))
|
||||
#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2))
|
||||
#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0))
|
||||
#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1))
|
||||
#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2))
|
||||
#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(3))
|
||||
|
||||
int sstream_read (void *vec, char *dst, int n) {
|
||||
sexp_uint_t len = sexp_unbox_integer(sexp_stream_size(vec));
|
||||
|
|
@ -550,7 +552,9 @@ int sstream_write (void *vec, const char *src, int n) {
|
|||
pos = sexp_unbox_integer(sexp_stream_pos(vec));
|
||||
newpos = pos+n;
|
||||
if (newpos >= len) {
|
||||
newbuf = sexp_make_string(NULL, sexp_make_integer(newpos*2), SEXP_VOID);
|
||||
newbuf = sexp_make_string(sexp_stream_ctx(vec),
|
||||
sexp_make_integer(newpos*2),
|
||||
SEXP_VOID);
|
||||
memcpy(sexp_string_data(newbuf),
|
||||
sexp_string_data(sexp_stream_buf(vec)),
|
||||
pos);
|
||||
|
|
@ -580,10 +584,11 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) {
|
|||
sexp res;
|
||||
sexp_gc_var(ctx, cookie, s_cookie);
|
||||
sexp_gc_preserve(ctx, cookie, s_cookie);
|
||||
cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)),
|
||||
cookie = sexp_vector(ctx, 4, ctx, str,
|
||||
sexp_make_integer(sexp_string_length(str)),
|
||||
sexp_make_integer(0));
|
||||
in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
|
||||
res = sexp_make_input_port(ctx, in, NULL);
|
||||
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
|
||||
sexp_port_cookie(res) = cookie;
|
||||
sexp_gc_release(ctx, cookie, s_cookie);
|
||||
return res;
|
||||
|
|
@ -595,10 +600,10 @@ sexp sexp_make_output_string_port (sexp ctx) {
|
|||
sexp_gc_var(ctx, cookie, s_cookie);
|
||||
sexp_gc_preserve(ctx, cookie, s_cookie);
|
||||
size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE);
|
||||
cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID),
|
||||
cookie = sexp_vector(ctx, 4, ctx, sexp_make_string(ctx, size, SEXP_VOID),
|
||||
size, sexp_make_integer(0));
|
||||
out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
|
||||
res = sexp_make_output_port(ctx, out, NULL);
|
||||
res = sexp_make_output_port(ctx, out, SEXP_FALSE);
|
||||
sexp_port_cookie(res) = cookie;
|
||||
sexp_gc_release(ctx, cookie, s_cookie);
|
||||
return res;
|
||||
|
|
@ -617,14 +622,14 @@ sexp sexp_get_output_string (sexp ctx, sexp port) {
|
|||
|
||||
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
|
||||
FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
|
||||
return sexp_make_input_port(in, NULL);
|
||||
return sexp_make_input_port(ctx, in, SEXP_FALSE);
|
||||
}
|
||||
|
||||
sexp sexp_make_output_string_port (sexp ctx) {
|
||||
FILE *out;
|
||||
sexp buf = sexp_alloc_type(ctx, string, SEXP_STRING), res;
|
||||
out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf));
|
||||
res = sexp_make_input_port(out, NULL);
|
||||
res = sexp_make_input_port(ctx, out, SEXP_FALSE);
|
||||
sexp_port_cookie(res) = buf;
|
||||
return res;
|
||||
}
|
||||
|
|
@ -641,18 +646,18 @@ sexp sexp_get_output_string (sexp ctx, sexp port) {
|
|||
|
||||
#endif
|
||||
|
||||
sexp sexp_make_input_port (sexp ctx, FILE* in, char *path) {
|
||||
sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
|
||||
sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT);
|
||||
sexp_port_stream(p) = in;
|
||||
sexp_port_name(p) = path;
|
||||
sexp_port_name(p) = name;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
}
|
||||
|
||||
sexp sexp_make_output_port (sexp ctx, FILE* out, char *path) {
|
||||
sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
|
||||
sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT);
|
||||
sexp_port_stream(p) = out;
|
||||
sexp_port_name(p) = path;
|
||||
sexp_port_name(p) = name;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
}
|
||||
|
|
@ -665,7 +670,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
char *str=NULL;
|
||||
|
||||
if (! obj) {
|
||||
sexp_write_string("#<null>", out);
|
||||
sexp_write_string("#<null>", out); /* shouldn't happen */
|
||||
} else if (sexp_pointerp(obj)) {
|
||||
switch (sexp_pointer_tag(obj)) {
|
||||
case SEXP_PAIR:
|
||||
|
|
|
|||
11
sexp.h
11
sexp.h
|
|
@ -6,7 +6,6 @@
|
|||
#define SEXP_H
|
||||
|
||||
#include "config.h"
|
||||
#include "defaults.h"
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdio.h>
|
||||
|
|
@ -14,7 +13,6 @@
|
|||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdarg.h>
|
||||
#include <sysexits.h>
|
||||
#include <sys/types.h>
|
||||
#include <math.h>
|
||||
|
||||
|
|
@ -123,8 +121,8 @@ struct sexp_struct {
|
|||
} symbol;
|
||||
struct {
|
||||
FILE *stream;
|
||||
char *name;
|
||||
sexp_uint_t line;
|
||||
sexp name;
|
||||
sexp cookie;
|
||||
} port;
|
||||
struct {
|
||||
|
|
@ -216,7 +214,7 @@ struct sexp_struct {
|
|||
#define sexp_gc_preserve(ctx, x, y)
|
||||
#define sexp_gc_release(ctx, x, y)
|
||||
|
||||
#include "gc/include/gc.h"
|
||||
#include "gc.h"
|
||||
#define sexp_alloc(ctx, size) GC_malloc(size)
|
||||
#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size)
|
||||
#define sexp_realloc(ctx, x, size) GC_realloc(x, size)
|
||||
|
|
@ -257,7 +255,6 @@ 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))
|
||||
|
|
@ -540,8 +537,8 @@ sexp sexp_read_number(sexp ctx, sexp in, int base);
|
|||
sexp sexp_read_raw(sexp ctx, sexp in);
|
||||
sexp sexp_read(sexp ctx, sexp in);
|
||||
sexp sexp_read_from_string(sexp ctx, char *str);
|
||||
sexp sexp_make_input_port(sexp ctx, FILE* in, char *path);
|
||||
sexp sexp_make_output_port(sexp ctx, FILE* out, char *path);
|
||||
sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name);
|
||||
sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name);
|
||||
sexp sexp_make_input_string_port(sexp ctx, sexp str);
|
||||
sexp sexp_make_output_string_port(sexp ctx);
|
||||
sexp sexp_get_output_string(sexp ctx, sexp port);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue