mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
cleaning up allocation, hiding last details of sexp fields
This commit is contained in:
Alex Shinn
parent
9af5279e6f
commit
08d37049fd
5 changed files with 221 additions and 117 deletions
4
Makefile
4
Makefile
|
|
@ -10,10 +10,10 @@ GC_OBJ=./gc/gc.a
|
|||
$GC_OBJ: ./gc/alloc.c
|
||||
cd gc && make test
|
||||
|
||||
sexp.o: sexp.c sexp.h config.h Makefile
|
||||
sexp.o: sexp.c sexp.h config.h defaults.h Makefile
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c debug.c eval.h sexp.h config.h Makefile
|
||||
eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
# main.o: main.c eval.h sexp.h config.h Makefile
|
||||
|
|
|
|||
18
defaults.h
18
defaults.h
|
|
@ -41,14 +41,16 @@
|
|||
|
||||
#if USE_BOEHM
|
||||
#include "gc/include/gc.h"
|
||||
#define SEXP_ALLOC GC_malloc
|
||||
#define SEXP_ALLOC_ATOMIC GC_malloc_atomic
|
||||
#define SEXP_REALLOC GC_realloc
|
||||
#define SEXP_FREE GC_free
|
||||
#define sexp_alloc GC_malloc
|
||||
#define sexp_alloc_atomic GC_malloc_atomic
|
||||
#define sexp_realloc GC_realloc
|
||||
#define sexp_free(x)
|
||||
#define sexp_deep_free(x)
|
||||
#else
|
||||
#define SEXP_ALLOC malloc
|
||||
#define SEXP_ALLOC_ATOMIC SEXP_ALLOC
|
||||
#define SEXP_REALLOC realloc
|
||||
#define SEXP_FREE free
|
||||
#define sexp_alloc malloc
|
||||
#define sexp_alloc_atomic sexp_alloc
|
||||
#define sexp_realloc realloc
|
||||
#define sexp_free free
|
||||
void sexp_deep_free(sexp obj);
|
||||
#endif
|
||||
|
||||
|
|
|
|||
131
eval.c
131
eval.c
|
|
@ -65,8 +65,7 @@ static void env_define(sexp e, sexp key, sexp value) {
|
|||
|
||||
static sexp extend_env (sexp e, sexp fv, int offset) {
|
||||
int i;
|
||||
sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env));
|
||||
e2->tag = SEXP_ENV;
|
||||
sexp e2 = sexp_alloc_type(env, SEXP_ENV);
|
||||
sexp_env_parent(e2) = e;
|
||||
sexp_env_bindings(e2) = SEXP_NULL;
|
||||
for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--)
|
||||
|
|
@ -98,11 +97,10 @@ static sexp sexp_flatten_dot (sexp ls) {
|
|||
static void shrink_bcode(sexp *bc, sexp_uint_t i) {
|
||||
sexp tmp;
|
||||
if (sexp_bytecode_length(*bc) != i) {
|
||||
tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + i);
|
||||
tmp->tag = SEXP_BYTECODE;
|
||||
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE);
|
||||
sexp_bytecode_length(tmp) = i;
|
||||
memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i);
|
||||
SEXP_FREE(*bc);
|
||||
sexp_free(*bc);
|
||||
*bc = tmp;
|
||||
}
|
||||
}
|
||||
|
|
@ -110,14 +108,14 @@ static void shrink_bcode(sexp *bc, sexp_uint_t i) {
|
|||
static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) {
|
||||
sexp tmp;
|
||||
if (sexp_bytecode_length(*bc) < (*i)+size) {
|
||||
tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)
|
||||
+ sexp_bytecode_length(*bc)*2);
|
||||
tmp->tag = SEXP_BYTECODE;
|
||||
tmp = sexp_alloc_tagged(sexp_sizeof(bytecode)
|
||||
+ sexp_bytecode_length(*bc)*2,
|
||||
SEXP_BYTECODE);
|
||||
sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2;
|
||||
memcpy(sexp_bytecode_data(tmp),
|
||||
sexp_bytecode_data(*bc),
|
||||
sexp_bytecode_length(*bc));
|
||||
SEXP_FREE(*bc);
|
||||
sexp_free(*bc);
|
||||
*bc = tmp;
|
||||
}
|
||||
}
|
||||
|
|
@ -140,8 +138,7 @@ static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) {
|
|||
|
||||
static sexp sexp_make_procedure(sexp flags, sexp num_args,
|
||||
sexp bc, sexp vars) {
|
||||
sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure));
|
||||
proc->tag = SEXP_PROCEDURE;
|
||||
sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE);
|
||||
sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags;
|
||||
sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args;
|
||||
sexp_procedure_code(proc) = bc;
|
||||
|
|
@ -150,8 +147,7 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args,
|
|||
}
|
||||
|
||||
static sexp sexp_make_macro (sexp p, sexp e) {
|
||||
sexp mac = (sexp) SEXP_ALLOC(sexp_sizeof(macro));
|
||||
mac->tag = SEXP_MACRO;
|
||||
sexp mac = sexp_alloc_type(macro, SEXP_MACRO);
|
||||
sexp_macro_env(mac) = e;
|
||||
sexp_macro_proc(mac) = p;
|
||||
return mac;
|
||||
|
|
@ -166,13 +162,12 @@ sexp sexp_compile_error(char *message, sexp irritants) {
|
|||
}
|
||||
|
||||
sexp sexp_expand_macro (sexp mac, sexp form, sexp e) {
|
||||
sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
|
||||
sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE);
|
||||
sexp_uint_t i=0;
|
||||
/* fprintf(stderr, "expanding: "); */
|
||||
/* sexp_write(form, cur_error_port); */
|
||||
/* fprintf(stderr, "\n => "); */
|
||||
bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64);
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE);
|
||||
sexp_bytecode_length(bc) = 32;
|
||||
emit_push(&bc, &i, sexp_macro_env(mac));
|
||||
emit_push(&bc, &i, e);
|
||||
|
|
@ -184,11 +179,85 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) {
|
|||
res = vm(bc, e, stack, 0);
|
||||
sexp_write(res, cur_error_port);
|
||||
/* fprintf(stderr, "\n"); */
|
||||
SEXP_FREE(bc);
|
||||
SEXP_FREE(stack);
|
||||
sexp_free(bc);
|
||||
sexp_free(stack);
|
||||
return res;
|
||||
}
|
||||
|
||||
/* sexp analyze(sexp x, sexp env) { */
|
||||
/* sexp op, cell; */
|
||||
/* loop: */
|
||||
/* if (sexp_pairp(x)) { */
|
||||
/* if (sexp_idp(sexp_car(x))) { */
|
||||
/* cell = env_cell(sexp_car(x), env); */
|
||||
/* if (! cell) return analyze_app(x, env); */
|
||||
/* op = sexp_cdr(cell); */
|
||||
/* if (sexp_corep(op)) { */
|
||||
/* switch (sexp_core_code(op)) { */
|
||||
/* case CORE_DEFINE: */
|
||||
/* if (sexp_env_global_p(env)) */
|
||||
/* return sexp_make_set(sexp_make_global_ref(sexp_cadr(x), env), */
|
||||
/* analyze(sexp_caddr(x), env)); */
|
||||
/* else */
|
||||
/* return sexp_compile_error("bad define location", sexp_list1(x)); */
|
||||
/* case CORE_SET: */
|
||||
/* return sexp_make_set(sexp_make_ref(sexp_cadr(x), env), */
|
||||
/* analyze(sexp_caddr(x), env)); */
|
||||
/* case CORE_LAMBDA: */
|
||||
/* return analyze_lambda(x, env); */
|
||||
/* case CORE_IF: */
|
||||
/* return sexp_make_cnd(analyze(sexp_car(x), env), */
|
||||
/* analyze(sexp_cadr(x), env), */
|
||||
/* (sexp_pairp(sexp_cddr(x)) */
|
||||
/* ? analyze(sexp_caddr(x), env) : SEXP_UNDEF)); */
|
||||
/* case CORE_BEGIN: */
|
||||
/* return sexp_make_seq(analyze_app(x, env)); */
|
||||
/* case CORE_QUOTE: */
|
||||
/* return sexp_make_lit(x); */
|
||||
/* default: */
|
||||
/* return sexp_compile_error("unknown core form", sexp_list1(op)); */
|
||||
/* } */
|
||||
/* } else if (sexp_macrop(op)) { */
|
||||
/* x = sexp_expand_macro(op, x, env); */
|
||||
/* goto loop; */
|
||||
/* } else { */
|
||||
/* return analyze_app(x, env); */
|
||||
/* } */
|
||||
/* } else { */
|
||||
/* return analyze_app(x, env); */
|
||||
/* } */
|
||||
/* } else if (sexp_symbolp(x)) { */
|
||||
/* return analyze_var_ref(x, env); */
|
||||
/* } else if (sexp_synclop(x)) { */
|
||||
/* env = sexp_synclo_env(x); */
|
||||
/* x = sexp_synclo_expr(x); */
|
||||
/* goto loop; */
|
||||
/* } else { */
|
||||
/* return x; */
|
||||
/* } */
|
||||
/* } */
|
||||
|
||||
/* sexp analyze_lambda(sexp x, sexp env) { */
|
||||
/* } */
|
||||
|
||||
/* sexp analyze_app(sexp x, sexp env) { */
|
||||
/* sexp res=SEXP_NULL; */
|
||||
/* for ( ; sexp_pairp(x); x=sexp_cdr(x)) */
|
||||
/* res = sexp_cons(analyze(sexp_car(x), env), res); */
|
||||
/* return sexp_nreverse(res); */
|
||||
/* } */
|
||||
|
||||
/* sexp compile(sexp x, sexp res) { */
|
||||
/* if (sexp_pairp(x)) */
|
||||
/* else if (sexp_lambdap(x)) */
|
||||
/* else if (sexp_seqp(x)) */
|
||||
/* else if (sexp_cndp(x)) */
|
||||
/* else if (sexp_refp(x)) */
|
||||
/* else if (sexp_setp(x)) */
|
||||
/* else if (sexp_litp(x)) */
|
||||
/* else */
|
||||
/* } */
|
||||
|
||||
sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e,
|
||||
sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) {
|
||||
int tmp1, tmp2;
|
||||
|
|
@ -591,10 +660,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) {
|
|||
sexp_uint_t pos=0, d=0;
|
||||
if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op))
|
||||
return sexp_opcode_proc(op);
|
||||
bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE);
|
||||
bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE);
|
||||
params = make_param_list(i);
|
||||
e = extend_env(e, params, -4);
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
sexp_bytecode_length(bc) = INIT_BCODE_SIZE;
|
||||
analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params,
|
||||
SEXP_NULL, SEXP_NULL, &d, 0);
|
||||
|
|
@ -609,9 +677,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) {
|
|||
|
||||
sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) {
|
||||
sexp_uint_t i=0, j=0, d=0, define_ok=1, core;
|
||||
sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE);
|
||||
sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE,
|
||||
SEXP_BYTECODE);
|
||||
sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls;
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
sexp_bytecode_length(bc) = INIT_BCODE_SIZE;
|
||||
/* box mutable vars */
|
||||
for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) {
|
||||
|
|
@ -1119,7 +1187,7 @@ sexp sexp_close_port (sexp port) {
|
|||
}
|
||||
|
||||
sexp sexp_load (sexp source) {
|
||||
sexp obj, res, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
|
||||
sexp obj, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE);
|
||||
int closep = 0;
|
||||
if (sexp_stringp(source)) {
|
||||
source = sexp_open_input_file(source);
|
||||
|
|
@ -1132,7 +1200,7 @@ sexp sexp_load (sexp source) {
|
|||
res = SEXP_UNDEF;
|
||||
done:
|
||||
if (closep) sexp_close_port(source);
|
||||
SEXP_FREE(stack);
|
||||
sexp_free(stack);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -1225,8 +1293,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV),
|
|||
|
||||
sexp make_standard_env() {
|
||||
sexp_uint_t i;
|
||||
sexp e = (sexp) SEXP_ALLOC(sexp_sizeof(env));
|
||||
e->tag = SEXP_ENV;
|
||||
sexp e = sexp_alloc_type(env, SEXP_ENV);
|
||||
sexp_env_parent(e) = NULL;
|
||||
sexp_env_bindings(e) = SEXP_NULL;
|
||||
for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++)
|
||||
|
|
@ -1245,9 +1312,9 @@ sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) {
|
|||
}
|
||||
|
||||
sexp eval(sexp obj, sexp e) {
|
||||
sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE);
|
||||
sexp* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE);
|
||||
sexp res = eval_in_stack(obj, e, stack, 0);
|
||||
SEXP_FREE(stack);
|
||||
sexp_free(stack);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -1261,8 +1328,7 @@ void scheme_init() {
|
|||
cur_output_port = sexp_make_output_port(stdout);
|
||||
cur_error_port = sexp_make_output_port(stderr);
|
||||
the_compile_error_symbol = sexp_intern("compile-error");
|
||||
bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16);
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE);
|
||||
sexp_bytecode_length(bc) = 16;
|
||||
emit(&bc, &i, OP_RESUMECC);
|
||||
continuation_resumer = (sexp) bc;
|
||||
|
|
@ -1290,11 +1356,10 @@ int main (int argc, char **argv) {
|
|||
sexp_uint_t i, quit=0, init_loaded=0;
|
||||
|
||||
scheme_init();
|
||||
stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE);
|
||||
stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE);
|
||||
e = make_standard_env();
|
||||
interaction_environment = e;
|
||||
bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16);
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE);
|
||||
sexp_bytecode_length(bc) = 16;
|
||||
i = 0;
|
||||
emit_push(&bc, &i, SEXP_UNDEF);
|
||||
|
|
|
|||
107
sexp.c
107
sexp.c
|
|
@ -51,38 +51,47 @@ static unsigned long symbol_table_primes[] = {
|
|||
static int symbol_table_prime_index = 0;
|
||||
static int symbol_table_count = 0;
|
||||
|
||||
void sexp_free (sexp obj) {
|
||||
sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) {
|
||||
sexp res = (sexp) sexp_alloc(size);
|
||||
if (! res)
|
||||
errx(EX_OSERR, "out of memory: couldn't allocate %d bytes for %d",
|
||||
size ,tag);
|
||||
res->tag = tag;
|
||||
return res;
|
||||
}
|
||||
|
||||
#if ! USE_BOEHM
|
||||
void sexp_deep_free (sexp obj) {
|
||||
int len, i;
|
||||
sexp *elts;
|
||||
if (sexp_pointerp(obj)) {
|
||||
switch (obj->tag) {
|
||||
case SEXP_PAIR:
|
||||
sexp_free(sexp_car(obj));
|
||||
sexp_free(sexp_cdr(obj));
|
||||
sexp_deep_free(sexp_car(obj));
|
||||
sexp_deep_free(sexp_cdr(obj));
|
||||
break;
|
||||
case SEXP_VECTOR:
|
||||
len = sexp_vector_length(obj);
|
||||
elts = sexp_vector_data(obj);
|
||||
for (i=0; i<len; i++) {
|
||||
sexp_free(elts[i]);
|
||||
}
|
||||
SEXP_FREE(elts);
|
||||
for (i=0; i<len; i++)
|
||||
sexp_deep_free(elts[i]);
|
||||
sexp_free(elts);
|
||||
break;
|
||||
case SEXP_STRING:
|
||||
case SEXP_SYMBOL:
|
||||
SEXP_FREE(sexp_string_data(obj));
|
||||
sexp_free(sexp_string_data(obj));
|
||||
break;
|
||||
}
|
||||
SEXP_FREE(obj);
|
||||
sexp_free(obj);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
/***************************** exceptions *****************************/
|
||||
|
||||
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants,
|
||||
sexp file, sexp line) {
|
||||
sexp exn = SEXP_ALLOC(sexp_sizeof(exception));
|
||||
exn->tag = SEXP_EXCEPTION;
|
||||
sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION);
|
||||
sexp_exception_kind(exn) = kind;
|
||||
sexp_exception_message(exn) = message;
|
||||
sexp_exception_irritants(exn) = irritants;
|
||||
|
|
@ -133,8 +142,7 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) {
|
|||
/*************************** list utilities ***************************/
|
||||
|
||||
sexp sexp_cons(sexp head, sexp tail) {
|
||||
sexp pair = SEXP_ALLOC(sexp_sizeof(pair));
|
||||
pair->tag = SEXP_PAIR;
|
||||
sexp pair = sexp_alloc_type(pair, SEXP_PAIR);
|
||||
sexp_car(pair) = head;
|
||||
sexp_cdr(pair) = tail;
|
||||
return pair;
|
||||
|
|
@ -224,18 +232,16 @@ sexp sexp_length(sexp ls) {
|
|||
/********************* strings, symbols, vectors **********************/
|
||||
|
||||
sexp sexp_make_flonum(double f) {
|
||||
sexp x = SEXP_ALLOC(sexp_sizeof(flonum));
|
||||
x->tag = SEXP_FLONUM;
|
||||
sexp x = sexp_alloc_type(flonum, SEXP_FLONUM);
|
||||
sexp_flonum_value(x) = f;
|
||||
return x;
|
||||
}
|
||||
|
||||
sexp sexp_make_string(char *str) {
|
||||
sexp s = SEXP_ALLOC(sexp_sizeof(string));
|
||||
sexp s = sexp_alloc_type(string, SEXP_STRING);
|
||||
sexp_uint_t len = strlen(str);
|
||||
char *mystr = SEXP_ALLOC(len+1);
|
||||
char *mystr = sexp_alloc(len+1);
|
||||
memcpy(mystr, str, len+1);
|
||||
s->tag = SEXP_STRING;
|
||||
sexp_string_length(s) = len;
|
||||
sexp_string_data(s) = mystr;
|
||||
return s;
|
||||
|
|
@ -287,19 +293,18 @@ sexp sexp_intern(char *str) {
|
|||
|
||||
if (symbol_table_count*5 > d*4) {
|
||||
fprintf(stderr, "resizing symbol table!!!!!\n");
|
||||
newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++]
|
||||
newtable = sexp_alloc(symbol_table_primes[symbol_table_prime_index++]
|
||||
* sizeof(sexp));
|
||||
/* XXXX rehash */
|
||||
SEXP_FREE(symbol_table);
|
||||
sexp_free(symbol_table);
|
||||
symbol_table = newtable;
|
||||
}
|
||||
|
||||
sym = SEXP_ALLOC(sexp_sizeof(symbol));
|
||||
sym = sexp_alloc_type(symbol, SEXP_SYMBOL);
|
||||
len = strlen(str);
|
||||
mystr = SEXP_ALLOC(len+1);
|
||||
mystr = sexp_alloc(len+1);
|
||||
memcpy(mystr, str, len+1);
|
||||
mystr[len]=0;
|
||||
sym->tag = SEXP_SYMBOL;
|
||||
sexp_symbol_length(sym) = len;
|
||||
sexp_symbol_data(sym) = mystr;
|
||||
symbol_table[cell] = sym;
|
||||
|
|
@ -310,12 +315,11 @@ sexp sexp_make_vector(sexp len, sexp dflt) {
|
|||
sexp v, *x;
|
||||
int i, clen = sexp_unbox_integer(len);
|
||||
if (! clen) return the_empty_vector;
|
||||
v = SEXP_ALLOC(sexp_sizeof(vector));
|
||||
x = (sexp*) SEXP_ALLOC(clen*sizeof(sexp));
|
||||
v = sexp_alloc_type(vector, SEXP_VECTOR);
|
||||
x = (sexp*) sexp_alloc(clen*sizeof(sexp));
|
||||
for (i=0; i<clen; i++) {
|
||||
x[i] = dflt;
|
||||
}
|
||||
v->tag = SEXP_VECTOR;
|
||||
sexp_vector_length(v) = clen;
|
||||
sexp_vector_data(v) = x;
|
||||
return v;
|
||||
|
|
@ -375,7 +379,7 @@ off_t sstream_seek(void *vec, off_t offset, int whence) {
|
|||
}
|
||||
|
||||
int sstream_close(void *vec) {
|
||||
sexp_free((sexp)vec);
|
||||
sexp_deep_free((sexp)vec);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -395,16 +399,14 @@ sexp sexp_get_output_string(sexp port) {
|
|||
#endif
|
||||
|
||||
sexp sexp_make_input_port(FILE* in) {
|
||||
sexp p = SEXP_ALLOC(sexp_sizeof(port));
|
||||
p->tag = SEXP_IPORT;
|
||||
sexp p = sexp_alloc_type(port, SEXP_IPORT);
|
||||
sexp_port_stream(p) = in;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
}
|
||||
|
||||
sexp sexp_make_output_port(FILE* out) {
|
||||
sexp p = SEXP_ALLOC(sexp_sizeof(port));
|
||||
p->tag = SEXP_OPORT;
|
||||
sexp p = sexp_alloc_type(port, SEXP_OPORT);
|
||||
sexp_port_stream(p) = out;
|
||||
sexp_port_line(p) = 0;
|
||||
return p;
|
||||
|
|
@ -419,7 +421,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
if (! obj) {
|
||||
sexp_write_string("#<null>", out);
|
||||
} else if (sexp_pointerp(obj)) {
|
||||
switch (obj->tag) {
|
||||
switch (sexp_tag(obj)) {
|
||||
case SEXP_PAIR:
|
||||
sexp_write_char('(', out);
|
||||
sexp_write(sexp_car(obj), out);
|
||||
|
|
@ -474,7 +476,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
str = sexp_string_data(obj);
|
||||
/* ... FALLTHROUGH ... */
|
||||
case SEXP_SYMBOL:
|
||||
if (obj->tag != SEXP_STRING) {
|
||||
if (! sexp_stringp(obj)) {
|
||||
i = sexp_symbol_length(obj);
|
||||
str = sexp_symbol_data(obj);
|
||||
}
|
||||
|
|
@ -483,7 +485,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
sexp_write_char('\\', out);
|
||||
sexp_write_char(str[0], out);
|
||||
}
|
||||
if (obj->tag == SEXP_STRING)
|
||||
if (sexp_stringp(obj))
|
||||
sexp_write_char('"', out);
|
||||
break;
|
||||
}
|
||||
|
|
@ -530,12 +532,12 @@ char* sexp_read_string(sexp in) {
|
|||
char *buf, *tmp, *res;
|
||||
int c, len, size=128;
|
||||
|
||||
buf = SEXP_ALLOC(size); /* XXXX grow! */
|
||||
buf = sexp_alloc(size); /* XXXX grow! */
|
||||
tmp = buf;
|
||||
|
||||
for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) {
|
||||
if (c == EOF) {
|
||||
SEXP_FREE(buf);
|
||||
sexp_free(buf);
|
||||
return NULL;
|
||||
} else if (c == '\\') {
|
||||
c=sexp_read_char(in);
|
||||
|
|
@ -551,9 +553,9 @@ char* sexp_read_string(sexp in) {
|
|||
|
||||
*tmp++ = '\0';
|
||||
len = tmp - buf;
|
||||
res = SEXP_ALLOC(len);
|
||||
res = sexp_alloc(len);
|
||||
memcpy(res, buf, len);
|
||||
SEXP_FREE(buf);
|
||||
sexp_free(buf);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -561,7 +563,7 @@ char* sexp_read_symbol(sexp in, int init) {
|
|||
char *buf, *tmp, *res;
|
||||
int c, len, size=128;
|
||||
|
||||
buf = SEXP_ALLOC(size);
|
||||
buf = sexp_alloc(size);
|
||||
tmp = buf;
|
||||
|
||||
if (init != EOF)
|
||||
|
|
@ -578,9 +580,9 @@ char* sexp_read_symbol(sexp in, int init) {
|
|||
|
||||
*tmp++ = '\0';
|
||||
len = tmp - buf;
|
||||
res = SEXP_ALLOC(len);
|
||||
res = sexp_alloc(len);
|
||||
memcpy(res, buf, len);
|
||||
SEXP_FREE(buf);
|
||||
sexp_free(buf);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -666,7 +668,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
case '"':
|
||||
str = sexp_read_string(in);
|
||||
res = sexp_make_string(str);
|
||||
SEXP_FREE(str);
|
||||
sexp_free(str);
|
||||
break;
|
||||
case '(':
|
||||
res = SEXP_NULL;
|
||||
|
|
@ -679,7 +681,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
} else {
|
||||
tmp = sexp_read_raw(in);
|
||||
if (sexp_read_raw(in) != SEXP_CLOSE) {
|
||||
sexp_free(res);
|
||||
sexp_deep_free(res);
|
||||
return sexp_read_error("multiple tokens in dotted tail",
|
||||
SEXP_NULL, in);
|
||||
} else {
|
||||
|
|
@ -695,7 +697,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
}
|
||||
}
|
||||
if (tmp != SEXP_CLOSE) {
|
||||
sexp_free(res);
|
||||
sexp_deep_free(res);
|
||||
return sexp_read_error("missing trailing ')'", SEXP_NULL, in);
|
||||
}
|
||||
res = (sexp_pairp(res) ? sexp_nreverse(res) : res);
|
||||
|
|
@ -759,7 +761,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
res = sexp_read(in);
|
||||
if (! sexp_listp(res)) {
|
||||
if (! sexp_exceptionp(res)) {
|
||||
sexp_free(res);
|
||||
sexp_deep_free(res);
|
||||
return sexp_read_error("dotted list not allowed in vector syntax",
|
||||
SEXP_NULL,
|
||||
in);
|
||||
|
|
@ -784,7 +786,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
sexp_push_char(c1, in);
|
||||
str = sexp_read_symbol(in, '.');
|
||||
res = sexp_intern(str);
|
||||
SEXP_FREE(str);
|
||||
sexp_free(str);
|
||||
}
|
||||
break;
|
||||
case ')':
|
||||
|
|
@ -802,7 +804,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
sexp_push_char(c2, in);
|
||||
str = sexp_read_symbol(in, c1);
|
||||
res = sexp_intern(str);
|
||||
SEXP_FREE(str);
|
||||
sexp_free(str);
|
||||
}
|
||||
break;
|
||||
case '0': case '1': case '2': case '3': case '4':
|
||||
|
|
@ -813,7 +815,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
default:
|
||||
str = sexp_read_symbol(in, c1);
|
||||
res = sexp_intern(str);
|
||||
SEXP_FREE(str);
|
||||
sexp_free(str);
|
||||
break;
|
||||
}
|
||||
return res;
|
||||
|
|
@ -832,8 +834,8 @@ sexp sexp_read_from_string(char *str) {
|
|||
sexp s = sexp_make_string(str);
|
||||
sexp in = sexp_make_input_string_port(s);
|
||||
sexp res = sexp_read(in);
|
||||
sexp_free(s);
|
||||
sexp_free(in);
|
||||
sexp_deep_free(s);
|
||||
sexp_deep_free(in);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -843,15 +845,14 @@ void sexp_init() {
|
|||
#if USE_BOEHM
|
||||
GC_init();
|
||||
#endif
|
||||
symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp));
|
||||
symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp));
|
||||
the_dot_symbol = sexp_intern(".");
|
||||
the_quote_symbol = sexp_intern("quote");
|
||||
the_quasiquote_symbol = sexp_intern("quasiquote");
|
||||
the_unquote_symbol = sexp_intern("unquote");
|
||||
the_unquote_splicing_symbol = sexp_intern("unquote-splicing");
|
||||
the_read_error_symbol = sexp_intern("read-error");
|
||||
the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector));
|
||||
the_empty_vector->tag = SEXP_VECTOR;
|
||||
the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR);
|
||||
sexp_vector_length(the_empty_vector) = 0;
|
||||
sexp_vector_data(the_empty_vector) = NULL;
|
||||
}
|
||||
|
|
|
|||
78
sexp.h
78
sexp.h
|
|
@ -10,6 +10,7 @@
|
|||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdarg.h>
|
||||
#include <sysexits.h>
|
||||
|
||||
#include "config.h"
|
||||
#include "defaults.h"
|
||||
|
|
@ -17,7 +18,7 @@
|
|||
/* tagging system
|
||||
* bits end in 00: pointer
|
||||
* 01: fixnum
|
||||
* 011: symbol
|
||||
* 011: <unused>
|
||||
* 111: immediate symbol
|
||||
* 0110: char
|
||||
* 1110: other immediate object (NULL, TRUE, FALSE)
|
||||
|
|
@ -54,10 +55,17 @@ enum sexp_types {
|
|||
/* the following are used only by the evaluator */
|
||||
SEXP_PROCEDURE,
|
||||
SEXP_MACRO,
|
||||
SEXP_SYNCLO,
|
||||
SEXP_ENV,
|
||||
SEXP_BYTECODE,
|
||||
SEXP_CORE,
|
||||
SEXP_OPCODE,
|
||||
SEXP_LAMBDA,
|
||||
SEXP_CND,
|
||||
SEXP_REF,
|
||||
SEXP_SET,
|
||||
SEXP_SEQ,
|
||||
SEXP_LIT,
|
||||
};
|
||||
|
||||
typedef unsigned long sexp_uint_t;
|
||||
|
|
@ -68,6 +76,7 @@ typedef struct sexp_struct *sexp;
|
|||
struct sexp_struct {
|
||||
sexp_tag_t tag;
|
||||
union {
|
||||
/* basic types */
|
||||
double flonum;
|
||||
struct {
|
||||
sexp car, cdr;
|
||||
|
|
@ -92,6 +101,7 @@ struct sexp_struct {
|
|||
struct {
|
||||
sexp kind, message, irritants, file, line;
|
||||
} exception;
|
||||
/* runtime types */
|
||||
struct {
|
||||
char flags;
|
||||
sexp parent, bindings;
|
||||
|
|
@ -110,7 +120,7 @@ struct sexp_struct {
|
|||
} macro;
|
||||
struct {
|
||||
sexp env, free_vars, expr;
|
||||
} sc;
|
||||
} synclo;
|
||||
struct {
|
||||
unsigned char op_class, code, num_args, flags,
|
||||
arg1_type, arg2_type, inverse;
|
||||
|
|
@ -121,13 +131,37 @@ struct sexp_struct {
|
|||
char code;
|
||||
char *name;
|
||||
} core;
|
||||
/* ast types */
|
||||
struct {
|
||||
sexp name, params, flags, body, fv, sv;
|
||||
} lambda;
|
||||
struct {
|
||||
sexp test, pass, fail;
|
||||
} cnd;
|
||||
struct {
|
||||
sexp var, value;
|
||||
} set;
|
||||
struct {
|
||||
sexp var, value;
|
||||
} ref;
|
||||
struct {
|
||||
sexp ls;
|
||||
} seq;
|
||||
struct {
|
||||
sexp x;
|
||||
} lit;
|
||||
} value;
|
||||
};
|
||||
|
||||
#define sexp_sizeof_field(field) (sizeof((sexp)NULL)->value.field)
|
||||
#define sexp_sizeof(field) (sizeof(struct sexp_struct)-sexp_sizeof_field(exception)+sexp_sizeof_field(field))
|
||||
/* #define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) */
|
||||
|
||||
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) + SEXP_EXTENDED_TAG))
|
||||
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
|
||||
+ sizeof(((sexp)0)->value.x))
|
||||
|
||||
#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag)
|
||||
|
||||
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
|
||||
+ SEXP_EXTENDED_TAG))
|
||||
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
|
||||
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
|
||||
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
|
||||
|
|
@ -144,22 +178,24 @@ struct sexp_struct {
|
|||
#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG)
|
||||
#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
|
||||
|
||||
#define SEXP_CHECK_TAG(x,t) (sexp_pointerp(x) && (x)->tag == (t))
|
||||
#define sexp_tag(x) ((x)->tag)
|
||||
|
||||
#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))
|
||||
#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE))
|
||||
#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV))
|
||||
#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE))
|
||||
#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE))
|
||||
#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE))
|
||||
#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO))
|
||||
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_tag(x) == (t)))
|
||||
|
||||
#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))
|
||||
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE))
|
||||
#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV))
|
||||
#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE))
|
||||
#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE))
|
||||
#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE))
|
||||
#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO))
|
||||
#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x))
|
||||
|
||||
#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
|
||||
|
|
@ -293,6 +329,7 @@ void sexp_printf(sexp port, sexp fmt, ...);
|
|||
#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x)))
|
||||
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
|
||||
|
||||
sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag);
|
||||
sexp sexp_cons(sexp head, sexp tail);
|
||||
int sexp_listp(sexp obj);
|
||||
int sexp_list_index(sexp ls, sexp elt);
|
||||
|
|
@ -311,7 +348,6 @@ sexp sexp_make_vector(sexp len, sexp dflt);
|
|||
sexp sexp_list_to_vector(sexp ls);
|
||||
sexp sexp_vector(int count, ...);
|
||||
void sexp_write(sexp obj, sexp out);
|
||||
void sexp_free(sexp obj);
|
||||
char* sexp_read_string(sexp in);
|
||||
char* sexp_read_symbol(sexp in, int init);
|
||||
sexp sexp_read_number(sexp in, int base);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue