Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions
chibi-scheme/sexp.c
Alex Shinn d6e279eccd forgot these changes
2009-12-12 18:47:26 +09:00

1618 lines
52 KiB
C
Raw Blame History

/* sexp.c -- standalone sexp library implementation */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/sexp.h"
/* optional huffman-compressed immediate symbols */
struct sexp_huff_entry {
unsigned char len;
unsigned short bits;
};
#if USE_HUFF_SYMS
#include "opt/sexp-hufftabs.c"
static struct sexp_huff_entry huff_table[] = {
#include "opt/sexp-huff.c"
};
#endif
static int sexp_initialized_p = 0;
sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp);
static char sexp_separators[] = {
/* 1 2 3 4 5 6 7 8 9 a b c d e f */
0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */
1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */
};
static int digit_value (int c) {
return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10));
}
static int hex_digit (int n) {
return ((n<=9) ? ('0' + n) : ('A' + n - 10));
}
static int is_separator(int c) {
return 0<c && c<0x60 && sexp_separators[c];
}
#if USE_GLOBAL_SYMBOLS
sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
#endif
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
sexp res = (sexp) sexp_alloc(ctx, size);
if (res && ! sexp_exceptionp(res)) sexp_pointer_tag(res) = tag;
return res;
}
#if USE_AUTOCLOSE_PORTS
static sexp sexp_finalize_port (sexp ctx, sexp port) {
if (sexp_port_openp(port) && sexp_port_stream(port)
&& sexp_stringp(sexp_port_name(port)))
fclose(sexp_port_stream(port));
return SEXP_VOID;
}
#define SEXP_FINALIZE_PORT sexp_finalize_port
#else
#define SEXP_FINALIZE_PORT NULL
#endif
#define _DEF_TYPE(t,fb,felb,flb,flo,fls,sb,so,sc,n,f) \
{.tag=SEXP_TYPE, .value={.type={t,fb,felb,flb,flo,fls,sb,so,sc,n,f}}}
static struct sexp_struct _sexp_type_specs[] = {
_DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL),
_DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type", NULL),
_DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, "fixnum", NULL),
_DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL),
_DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL),
_DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair", NULL),
_DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol", NULL),
_DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string", NULL),
_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", NULL),
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL),
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL),
_DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT),
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT),
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL),
_DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure", NULL),
_DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro", NULL),
_DEF_TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure", NULL),
_DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, "environment", NULL),
_DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL),
_DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL),
_DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL),
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL),
_DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL),
_DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL),
_DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 2, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL),
_DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL),
_DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL),
_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", NULL),
_DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL),
};
#undef _DEF_TYPE
struct sexp_struct *sexp_type_specs = _sexp_type_specs;
#if USE_TYPE_DEFS
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 felb, sexp flb,
sexp flo, sexp fls, sexp sb, sexp so, sexp sc,
sexp_proc2 f) {
struct sexp_struct *type, *new, *tmp;
sexp res;
sexp_uint_t i, len;
if (sexp_num_types >= SEXP_MAXIMUM_TYPES) {
fprintf(stderr, "chibi: exceeded maximum type limit\n");
res = SEXP_FALSE;
} else if (! sexp_stringp(name)) {
res = sexp_type_exception(ctx, "register-type: not a string", name);
} else {
if (sexp_num_types >= sexp_type_array_size) {
len = sexp_type_array_size*2;
if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES;
new = malloc(len * sizeof(_sexp_type_specs[0]));
for (i=0; i<sexp_num_types; i++)
memcpy(&(new[i]), &(sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
tmp = sexp_type_specs;
sexp_type_specs = new;
if (sexp_type_array_size > sexp_num_types) free(tmp);
sexp_type_array_size = len;
}
type = &(sexp_type_specs[sexp_num_types]);
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);
sexp_type_size_base(type) = sexp_unbox_fixnum(sb);
sexp_type_size_off(type) = sexp_unbox_fixnum(so);
sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
sexp_type_name(type) = strdup(sexp_string_data(name));
sexp_type_finalize(type) = f;
res = sexp_make_fixnum(sexp_type_tag(type));
}
return res;
}
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, slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
sexp_make_fixnum(type_size), sexp_make_fixnum(0),
sexp_make_fixnum(0), NULL);
}
sexp sexp_finalize_c_type (sexp ctx, sexp obj) {
if (sexp_cpointer_freep(obj))
free(sexp_cpointer_value(obj));
return SEXP_VOID;
}
#else
#define sexp_num_types SEXP_NUM_CORE_TYPES
#endif
#if ! USE_BOEHM
#if ! USE_MALLOC
#include "gc.c"
#endif
#endif /* ! USE_BOEHM */
/****************************** contexts ******************************/
void sexp_init_context_globals (sexp ctx) {
sexp_context_globals(ctx)
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_G_NUM_GLOBALS), SEXP_VOID);
#if ! USE_GLOBAL_SYMBOLS
sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL);
#endif
sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL);
sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL);
sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote");
sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote");
sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote");
sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing");
sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*");
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*");
sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*");
sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL) = sexp_intern(ctx, "*current-exception-handler*");
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*");
sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
}
#if ! USE_GLOBAL_HEAP
sexp sexp_bootstrap_context (void) {
sexp dummy_ctx, ctx;
sexp_heap heap = sexp_make_heap(sexp_heap_align(SEXP_INITIAL_HEAP_SIZE));
dummy_ctx = (sexp) malloc(sexp_sizeof(context));
sexp_pointer_tag(dummy_ctx) = SEXP_CONTEXT;
sexp_context_saves(dummy_ctx) = NULL;
sexp_context_heap(dummy_ctx) = heap;
ctx = sexp_alloc_type(dummy_ctx, context, SEXP_CONTEXT);
sexp_context_heap(dummy_ctx) = NULL;
sexp_context_heap(ctx) = heap;
free(dummy_ctx);
return ctx;
}
#endif
sexp sexp_make_context (sexp ctx) {
sexp_gc_var1(res);
if (ctx) sexp_gc_preserve1(ctx, res);
#if ! USE_GLOBAL_HEAP
if (! ctx) res = sexp_bootstrap_context();
else
#endif
{
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
#if ! USE_BOEHM && ! USE_MALLOC
sexp_context_heap(res) = sexp_context_heap(ctx);
#endif
}
sexp_context_parent(res) = ctx;
sexp_context_lambda(res) = SEXP_FALSE;
sexp_context_fv(res) = SEXP_NULL;
sexp_context_saves(res) = 0;
sexp_context_depth(res) = 0;
sexp_context_pos(res) = 0;
sexp_context_tailp(res) = 1;
sexp_context_tracep(res) = 0;
if (ctx) {
sexp_context_globals(res) = sexp_context_globals(ctx);
sexp_gc_release1(ctx);
} else {
sexp_init_context_globals(res);
}
return res;
}
#if ! USE_GLOBAL_HEAP
void sexp_destroy_context (sexp ctx) {
sexp_heap heap;
if (sexp_context_heap(ctx)) {
heap = sexp_context_heap(ctx);
sexp_context_heap(ctx) = NULL;
free(heap);
}
}
#endif
/***************************** exceptions *****************************/
sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants,
sexp procedure, sexp source) {
sexp exn = sexp_alloc_type(ctx, exception, SEXP_EXCEPTION);
sexp_exception_kind(exn) = kind;
sexp_exception_message(exn) = message;
sexp_exception_irritants(exn) = irritants;
sexp_exception_procedure(exn) = procedure;
sexp_exception_source(exn) = source;
return exn;
}
sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) {
sexp res;
sexp_gc_var3(sym, str, irr);
sexp_gc_preserve3(ctx, sym, str, irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"),
str = sexp_c_string(ctx, message, -1),
((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : (irr = sexp_list1(ctx, irritants))),
self, SEXP_FALSE);
sexp_gc_release3(ctx);
return res;
}
sexp sexp_type_exception (sexp ctx, char *message, sexp obj) {
sexp res;
sexp_gc_var3(sym, str, irr);
sexp_gc_preserve3(ctx, sym, str, irr);
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"),
str = sexp_c_string(ctx, message, -1),
irr = sexp_list1(ctx, obj),
SEXP_FALSE, SEXP_FALSE);
sexp_gc_release3(ctx);
return res;
}
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
sexp_gc_var2(res, msg);
sexp_gc_preserve2(ctx, res, msg);
msg = sexp_c_string(ctx, "bad index range", -1);
res = sexp_list2(ctx, start, end);
res = sexp_cons(ctx, obj, res);
res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res,
SEXP_FALSE, SEXP_FALSE);
sexp_gc_release2(ctx);
return res;
}
sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
sexp ls;
if (! sexp_oportp(out))
out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_write_string(ctx, "ERROR", out);
if (sexp_exceptionp(exn)) {
if (sexp_procedurep(sexp_exception_procedure(exn))) {
ls = sexp_bytecode_name(
sexp_procedure_code(sexp_exception_procedure(exn)));
if (sexp_symbolp(ls)) {
sexp_write_string(ctx, " in ", out);
sexp_write(ctx, ls, out);
}
}
if (sexp_pairp(sexp_exception_source(exn))) {
ls = sexp_exception_source(exn);
if (sexp_fixnump(sexp_cdr(ls))
&& (sexp_cdr(ls) >= sexp_make_fixnum(0))) {
sexp_write_string(ctx, " on line ", out);
sexp_write(ctx, sexp_cdr(ls), out);
}
if (sexp_stringp(sexp_car(ls))) {
sexp_write_string(ctx, " of file ", out);
sexp_write_string(ctx, sexp_string_data(sexp_car(ls)), out);
}
}
sexp_write_string(ctx, ": ", out);
if (sexp_stringp(sexp_exception_message(exn)))
sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out);
else
sexp_write(ctx, sexp_exception_message(exn), out);
if (sexp_exception_irritants(exn)
&& sexp_pairp(sexp_exception_irritants(exn))) {
if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
sexp_write_string(ctx, ": ", out);
sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out);
sexp_write_string(ctx, "\n", out);
} else {
sexp_write_string(ctx, "\n", out);
for (ls=sexp_exception_irritants(exn);
sexp_pairp(ls); ls=sexp_cdr(ls)) {
sexp_write_string(ctx, " ", out);
sexp_write(ctx, sexp_car(ls), out);
sexp_write_char(ctx, '\n', out);
}
}
} else {
sexp_write_char(ctx, '\n', out);
}
} else {
sexp_write_string(ctx, ": ", out);
if (sexp_stringp(exn))
sexp_write_string(ctx, sexp_string_data(exn), out);
else
sexp_write(ctx, exn, out);
sexp_write_char(ctx, '\n', out);
}
return SEXP_VOID;
}
static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) {
sexp res;
sexp_gc_var4(sym, name, str, irr);
sexp_gc_preserve4(ctx, sym, name, str, irr);
name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE);
name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port)));
str = sexp_c_string(ctx, msg, -1);
irr = ((sexp_pairp(irritants) || sexp_nullp(irritants))
? irritants : sexp_list1(ctx, irritants));
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"),
str, irr, SEXP_FALSE, name);
sexp_gc_release4(ctx);
return res;
}
/*************************** list utilities ***************************/
sexp sexp_cons (sexp ctx, sexp head, sexp tail) {
sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR);
if (sexp_exceptionp(pair)) return pair;
sexp_car(pair) = head;
sexp_cdr(pair) = tail;
sexp_pair_source(pair) = SEXP_FALSE;
return pair;
}
sexp sexp_list2 (sexp ctx, sexp a, sexp b) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_cons(ctx, b, SEXP_NULL);
res = sexp_cons(ctx, a, res);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_listp (sexp ctx, sexp hare) {
sexp turtle;
if (! sexp_pairp(hare))
return sexp_make_boolean(sexp_nullp(hare));
turtle = hare;
hare = sexp_cdr(hare);
for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) {
if (hare == turtle) return SEXP_FALSE;
hare = sexp_cdr(hare);
if (sexp_pairp(hare)) hare = sexp_cdr(hare);
}
return sexp_make_boolean(sexp_nullp(hare));
}
sexp sexp_memq (sexp ctx, sexp x, sexp ls) {
while (sexp_pairp(ls))
if (x == sexp_car(ls))
return ls;
else
ls = sexp_cdr(ls);
return SEXP_FALSE;
}
sexp sexp_assq (sexp ctx, sexp x, sexp ls) {
while (sexp_pairp(ls))
if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls)))
return sexp_car(ls);
else
ls = sexp_cdr(ls);
return SEXP_FALSE;
}
sexp sexp_reverse (sexp ctx, sexp ls) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(ctx, sexp_car(ls), res);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_nreverse (sexp ctx, sexp ls) {
sexp a, b, tmp;
if (ls == SEXP_NULL) {
return ls;
} else if (! sexp_pairp(ls)) {
return sexp_type_exception(ctx, "not a list", ls);
} else {
b = ls;
a = sexp_cdr(ls);
sexp_cdr(b) = SEXP_NULL;
for ( ; sexp_pairp(a); b=a, a=tmp) {
tmp = sexp_cdr(a);
sexp_cdr(a) = b;
}
return b;
}
}
sexp sexp_append2 (sexp ctx, sexp a, sexp b) {
sexp_gc_var2(a1, b1);
sexp_gc_preserve2(ctx, a1, b1);
b1 = b;
for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1))
b1 = sexp_cons(ctx, sexp_car(a1), b1);
sexp_gc_release2(ctx);
return b1;
}
sexp sexp_length (sexp ctx, sexp ls) {
sexp_uint_t res=0;
for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls))
;
return sexp_make_fixnum(res);
}
sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
sexp_uint_t size;
sexp_sint_t i, len;
sexp t, *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((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_flonump(b)
&& (sexp_unbox_fixnum(a) == sexp_flonum_value(b)));
else if (! sexp_pointerp(b))
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) {t=a; a=b; b=t;}
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
return SEXP_FALSE;
}
/* a and b are both pointers of the same type */
#if USE_BIGNUMS
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
return sexp_make_boolean(!sexp_bignum_compare(a, b));
#endif
#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
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))
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 **********************/
#if ! USE_IMMEDIATE_FLONUMS
sexp sexp_make_flonum(sexp ctx, double f) {
sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM);
if (sexp_exceptionp(x)) return x;
sexp_flonum_value(x) = f;
return x;
}
#endif
sexp sexp_make_string(sexp ctx, sexp len, sexp ch) {
sexp_sint_t clen = sexp_unbox_fixnum(len);
sexp s;
if (! sexp_fixnump(len)) return sexp_type_exception(ctx, "bad length", len);
if (clen < 0) return sexp_type_exception(ctx, "negative length", len);
s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1);
if (sexp_exceptionp(s)) return s;
sexp_pointer_tag(s) = SEXP_STRING;
sexp_string_length(s) = clen;
if (sexp_charp(ch))
memset(sexp_string_data(s), sexp_unbox_character(ch), clen);
sexp_string_data(s)[clen] = '\0';
return s;
}
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_fixnum(len), SEXP_VOID);
memcpy(sexp_string_data(s), str, len);
sexp_string_data(s)[len] = '\0';
return s;
}
sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) {
sexp res;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, "not a string", str);
if (! sexp_fixnump(start))
return sexp_type_exception(ctx, "not a number", start);
if (sexp_not(end))
end = sexp_make_fixnum(sexp_string_length(str));
if (! sexp_fixnump(end))
return sexp_type_exception(ctx, "not a number", end);
if ((sexp_unbox_fixnum(start) < 0)
|| (sexp_unbox_fixnum(start) > sexp_string_length(str))
|| (sexp_unbox_fixnum(end) < 0)
|| (sexp_unbox_fixnum(end) > sexp_string_length(str))
|| (end < start))
return sexp_range_exception(ctx, str, start, end);
res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID);
memcpy(sexp_string_data(res),
sexp_string_data(str)+sexp_unbox_fixnum(start),
sexp_string_length(res));
sexp_string_data(res)[sexp_string_length(res)] = '\0';
return res;
}
sexp sexp_string_concatenate (sexp ctx, sexp str_ls) {
sexp res, ls;
sexp_uint_t len=0;
char *p;
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_stringp(sexp_car(ls)))
return sexp_type_exception(ctx, "not a string", sexp_car(ls));
else
len += sexp_string_length(sexp_car(ls));
res = sexp_make_string(ctx, sexp_make_fixnum(len), SEXP_VOID);
p = sexp_string_data(res);
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) {
len = sexp_string_length(sexp_car(ls));
memcpy(p, sexp_string_data(sexp_car(ls)), len);
p += len;
}
*p = '\0';
return res;
}
#define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL
#if USE_HASH_SYMS
static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) {
while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
return acc;
}
#endif
sexp sexp_intern(sexp ctx, char *str) {
struct sexp_huff_entry he;
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket;
char c, *p=str;
sexp ls;
sexp_gc_var1(sym);
#if USE_HUFF_SYMS
res = 0;
for ( ; (c=*p); p++) {
he = huff_table[(unsigned char)c];
newbits = he.len;
if ((space+newbits) > (sizeof(sexp)*8)) {
goto normal_intern;
}
res |= (((sexp_uint_t) he.bits) << space);
space += newbits;
}
return (sexp) (res + SEXP_ISYMBOL_TAG);
#endif
normal_intern:
#if USE_HASH_SYMS
bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE);
#else
bucket = 0;
#endif
len = strlen(str);
for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls))
if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len))
return sexp_car(ls);
/* not found, make a new symbol */
sexp_gc_preserve1(ctx, sym);
sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL);
if (sexp_exceptionp(sym)) return sym;
sexp_symbol_string(sym) = sexp_c_string(ctx, str, len);
sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym);
sexp_gc_release1(ctx);
return sym;
}
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));
}
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) {
sexp vec, *x;
int i, clen = sexp_unbox_fixnum(len);
if (! clen) return sexp_global(ctx, SEXP_G_EMPTY_VECTOR);
vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp),
SEXP_VECTOR);
if (sexp_exceptionp(vec)) return vec;
x = sexp_vector_data(vec);
for (i=0; i<clen; i++)
x[i] = dflt;
sexp_vector_length(vec) = clen;
return vec;
}
sexp sexp_list_to_vector(sexp ctx, sexp ls) {
sexp x, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID);
sexp *elts;
int i;
if (sexp_exceptionp(vec)) return vec;
elts = sexp_vector_data(vec);
for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x))
elts[i] = sexp_car(x);
return vec;
}
sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, int freep) {
sexp ptr;
if (! value) return SEXP_FALSE;
ptr = sexp_alloc_type(ctx, cpointer, typeid);
if (sexp_exceptionp(ptr)) return ptr;
sexp_freep(ptr) = freep;
sexp_cpointer_value(ptr) = value;
sexp_cpointer_parent(ptr) = parent;
sexp_cpointer_length(ptr) = 0;
return ptr;
}
/************************ reading and writing *************************/
#if USE_BIGNUMS
#include "opt/bignum.c"
#endif
#if USE_STRING_STREAMS
#define SEXP_INIT_STRING_PORT_SIZE 128
#if SEXP_BSD
#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(0))
#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(1))
#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(2))
#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_fixnum(3))
int sstream_read (void *vec, char *dst, int n) {
sexp_uint_t len = sexp_unbox_fixnum(sexp_stream_size(vec));
sexp_uint_t pos = sexp_unbox_fixnum(sexp_stream_pos(vec));
if (pos >= len) return 0;
if (n > (len - pos)) n = (len - pos);
memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n);
sexp_stream_pos(vec) = sexp_make_fixnum(n);
return n;
}
int sstream_write (void *vec, const char *src, int n) {
sexp_uint_t len, pos, newpos;
sexp newbuf;
len = sexp_unbox_fixnum(sexp_stream_size(vec));
pos = sexp_unbox_fixnum(sexp_stream_pos(vec));
newpos = pos+n;
if (newpos >= len) {
newbuf = sexp_make_string(sexp_stream_ctx(vec),
sexp_make_fixnum(newpos*2),
SEXP_VOID);
memcpy(sexp_string_data(newbuf),
sexp_string_data(sexp_stream_buf(vec)),
pos);
sexp_stream_buf(vec) = newbuf;
sexp_stream_size(vec) = sexp_make_fixnum(newpos*2);
}
memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n);
sexp_stream_pos(vec) = sexp_make_fixnum(newpos);
return n;
}
off_t sstream_seek (void *vec, off_t offset, int whence) {
sexp_sint_t pos;
if (whence == SEEK_SET) {
pos = offset;
} else if (whence == SEEK_CUR) {
pos = sexp_unbox_fixnum(sexp_stream_pos(vec)) + offset;
} else { /* SEEK_END */
pos = sexp_unbox_fixnum(sexp_stream_size(vec)) + offset;
}
sexp_stream_pos(vec) = sexp_make_fixnum(pos);
return pos;
}
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
FILE *in;
sexp res;
sexp_gc_var1(cookie);
sexp_gc_preserve1(ctx, cookie);
cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
sexp_stream_ctx(cookie) = ctx;
sexp_stream_buf(cookie) = str;
sexp_stream_size(cookie) = sexp_make_fixnum(sexp_string_length(str));
sexp_stream_pos(cookie) = sexp_make_fixnum(0);
in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
sexp_port_cookie(res) = cookie;
sexp_gc_release1(ctx);
return res;
}
sexp sexp_make_output_string_port (sexp ctx) {
FILE *out;
sexp res, size;
sexp_gc_var1(cookie);
sexp_gc_preserve1(ctx, cookie);
size = sexp_make_fixnum(SEXP_INIT_STRING_PORT_SIZE);
cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
sexp_stream_ctx(cookie) = ctx;
sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID);
sexp_stream_size(cookie) = size;
sexp_stream_pos(cookie) = sexp_make_fixnum(0);
out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
res = sexp_make_output_port(ctx, out, SEXP_FALSE);
sexp_port_cookie(res) = cookie;
sexp_gc_release1(ctx);
return res;
}
sexp sexp_get_output_string (sexp ctx, sexp port) {
sexp cookie = sexp_port_cookie(port);
fflush(sexp_port_stream(port));
return sexp_substring(ctx,
sexp_stream_buf(cookie),
sexp_make_fixnum(0),
sexp_stream_pos(cookie));
}
#else
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
sexp res = sexp_make_input_port(ctx, in, SEXP_FALSE);
sexp_port_cookie(res) = str; /* for gc preservation */
return res;
}
sexp sexp_make_output_string_port (sexp ctx) {
sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
sexp_port_stream(res)
= open_memstream(&sexp_port_buf(res), &sexp_port_size(res));
return res;
}
sexp sexp_get_output_string (sexp ctx, sexp port) {
fflush(sexp_port_stream(port));
return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port));
}
#endif
#else
#define SEXP_PORT_BUFFER_SIZE 4096
int sexp_buffered_read_char (sexp ctx, sexp p) {
if (sexp_port_offset(p) < sexp_port_size(p)) {
return sexp_port_buf(p)[sexp_port_offset(p)++];
} else if (! sexp_port_stream(p)) {
return EOF;
} else {
sexp_port_size(p)
= fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p));
sexp_port_offset(p) = 0;
return ((sexp_port_offset(p) < sexp_port_size(p))
? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF);
}
}
sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) {
if (sexp_port_offset(p) >= sexp_port_size(p))
sexp_buffered_flush(ctx, p);
sexp_port_buf(p)[sexp_port_offset(p)++] = c;
return SEXP_VOID;
}
sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) {
if (sexp_port_offset(p) >= sexp_port_size(p))
sexp_buffered_flush(ctx, p);
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len);
sexp_port_offset(p) += len;
return SEXP_VOID;
}
sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) {
return sexp_buffered_write_string_n(ctx, str, strlen(str), p);
}
sexp sexp_buffered_flush (sexp ctx, sexp p) {
sexp_gc_var1(tmp);
if (! sexp_oportp(p))
return sexp_type_exception(ctx, "not an output-port", p);
else if (! sexp_port_openp(p))
return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p);
else {
if (sexp_port_stream(p)) {
fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
fflush(sexp_port_stream(p));
} else if (sexp_port_offset(p) > 0) {
sexp_gc_preserve1(ctx, tmp);
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
sexp_push(ctx, sexp_port_cookie(p), tmp);
sexp_gc_release1(ctx);
}
sexp_port_offset(p) = 0;
return SEXP_VOID;
}
}
sexp sexp_make_input_string_port (sexp ctx, sexp str) {
sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE);
if (sexp_exceptionp(res)) return res;
sexp_port_cookie(res) = str;
sexp_port_buf(res) = sexp_string_data(str);
sexp_port_offset(res) = 0;
sexp_port_size(res) = sexp_string_length(str);
return res;
}
sexp sexp_make_output_string_port (sexp ctx) {
sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
if (sexp_exceptionp(res)) return res;
sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE);
sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE;
sexp_port_offset(res) = 0;
sexp_port_cookie(res) = SEXP_NULL;
return res;
}
sexp sexp_get_output_string (sexp ctx, sexp out) {
sexp res;
sexp_gc_var2(ls, tmp);
sexp_gc_preserve2(ctx, ls, tmp);
if (sexp_port_offset(out) > 0) {
tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out));
ls = sexp_cons(ctx, tmp, sexp_port_cookie(out));
} else {
ls = sexp_port_cookie(out);
}
res = sexp_string_concatenate(ctx, ls);
sexp_gc_release2(ctx);
return res;
}
#endif
sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT);
if (sexp_exceptionp(p)) return p;
sexp_port_stream(p) = in;
sexp_port_name(p) = name;
sexp_port_line(p) = 1;
sexp_port_buf(p) = NULL;
sexp_port_openp(p) = 1;
sexp_port_sourcep(p) = 1;
sexp_port_cookie(p) = SEXP_VOID;
return p;
}
sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
sexp p = sexp_make_input_port(ctx, out, name);
if (sexp_exceptionp(p)) return p;
sexp_pointer_tag(p) = SEXP_OPORT;
return p;
}
sexp sexp_write (sexp ctx, sexp obj, sexp out) {
unsigned long len, c, res;
long i=0;
double f;
sexp x, *elts;
char *str=NULL, numbuf[20];
if (! obj) {
sexp_write_string(ctx, "#<null>", out); /* shouldn't happen */
} else if (sexp_pointerp(obj)) {
switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR:
sexp_write_char(ctx, '(', out);
sexp_write(ctx, sexp_car(obj), out);
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
sexp_write_char(ctx, ' ', out);
sexp_write(ctx, sexp_car(x), out);
}
if (! sexp_nullp(x)) {
sexp_write_string(ctx, " . ", out);
sexp_write(ctx, x, out);
}
sexp_write_char(ctx, ')', out);
break;
case SEXP_VECTOR:
len = sexp_vector_length(obj);
elts = sexp_vector_data(obj);
if (len == 0) {
sexp_write_string(ctx, "#()", out);
} else {
sexp_write_string(ctx, "#(", out);
sexp_write(ctx, elts[0], out);
for (i=1; i<len; i++) {
sexp_write_char(ctx, ' ', out);
sexp_write(ctx, elts[i], out);
}
sexp_write_char(ctx, ')', out);
}
break;
#if ! USE_IMMEDIATE_FLONUMS
case SEXP_FLONUM:
f = sexp_flonum_value(obj);
#if USE_INFINITIES
if (isinf(f) || isnan(f)) {
numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
} else
#endif
{
i = sprintf(numbuf, "%.15g", f);
if (f == trunc(f) && ! strchr(numbuf, '.')) {
numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
}
}
sexp_write_string(ctx, numbuf, out);
break;
#endif
case SEXP_PROCEDURE:
sexp_write_string(ctx, "#<procedure: ", out);
sexp_write(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out);
sexp_write_string(ctx, ">", out);
break;
case SEXP_STRING:
sexp_write_char(ctx, '"', out);
i = sexp_string_length(obj);
str = sexp_string_data(obj);
for ( ; i>0; str++, i--) {
switch (str[0]) {
case '\\': sexp_write_string(ctx, "\\\\", out); break;
case '"': sexp_write_string(ctx, "\\\"", out); break;
case '\n': sexp_write_string(ctx, "\\n", out); break;
case '\r': sexp_write_string(ctx, "\\r", out); break;
case '\t': sexp_write_string(ctx, "\\t", out); break;
default: sexp_write_char(ctx, str[0], out);
}
}
sexp_write_char(ctx, '"', out);
break;
case SEXP_SYMBOL:
i = sexp_string_length(sexp_symbol_string(obj));
str = sexp_string_data(sexp_symbol_string(obj));
for ( ; i>0; str++, i--) {
if ((str[0] == '\\') || is_separator(str[0]))
sexp_write_char(ctx, '\\', out);
sexp_write_char(ctx, str[0], out);
}
break;
#if USE_BIGNUMS
case SEXP_BIGNUM:
sexp_write_bignum(ctx, obj, out, 10);
break;
#endif
default:
i = sexp_pointer_tag(obj);
sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx,
(i < sexp_num_types)
? sexp_type_name_by_index(i) : "invalid",
out);
sexp_write_char(ctx, '>', out);
break;
}
} else if (sexp_fixnump(obj)) {
sprintf(numbuf, "%ld", sexp_unbox_fixnum(obj));
sexp_write_string(ctx, numbuf, out);
#if USE_IMMEDIATE_FLONUMS
} else if (sexp_flonump(obj)) {
f = sexp_flonum_value(obj);
#if USE_INFINITIES
if (isinf(f) || isnan(f)) {
numbuf[0] = (isinf(f) && f < 0 ? '-' : '+');
strcpy(numbuf+1, isinf(f) ? "inf.0" : "nan.0");
} else
#endif
{
i = sprintf(numbuf, "%.15g", f);
if (f == trunc(f) && ! strchr(numbuf, '.')) {
numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0';
}
}
sexp_write_string(ctx, numbuf, out);
#endif
} else if (sexp_charp(obj)) {
if (obj == sexp_make_character(' '))
sexp_write_string(ctx, "#\\space", out);
else if (obj == sexp_make_character('\n'))
sexp_write_string(ctx, "#\\newline", out);
else if (obj == sexp_make_character('\r'))
sexp_write_string(ctx, "#\\return", out);
else if (obj == sexp_make_character('\t'))
sexp_write_string(ctx, "#\\tab", out);
else if ((33 <= sexp_unbox_character(obj))
&& (sexp_unbox_character(obj) < 127)) {
sexp_write_string(ctx, "#\\", out);
sexp_write_char(ctx, sexp_unbox_character(obj), out);
} else {
sexp_write_string(ctx, "#\\x", out);
sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out);
sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out);
}
} else if (sexp_symbolp(obj)) {
#if USE_HUFF_SYMS
if (((sexp_uint_t)obj&7)==7) {
c = ((sexp_uint_t)obj)>>3;
while (c) {
#include "opt/sexp-unhuff.c"
sexp_write_char(ctx, res, out);
}
}
#endif
} else {
switch ((sexp_uint_t) obj) {
case (sexp_uint_t) SEXP_NULL:
sexp_write_string(ctx, "()", out); break;
case (sexp_uint_t) SEXP_TRUE:
sexp_write_string(ctx, "#t", out); break;
case (sexp_uint_t) SEXP_FALSE:
sexp_write_string(ctx, "#f", out); break;
case (sexp_uint_t) SEXP_EOF:
sexp_write_string(ctx, "#<eof>", out); break;
case (sexp_uint_t) SEXP_UNDEF:
case (sexp_uint_t) SEXP_VOID:
sexp_write_string(ctx, "#<undef>", out); break;
default:
sexp_write_string(ctx, "#<invalid immediate>", out);
}
}
return SEXP_VOID;
}
sexp sexp_display (sexp ctx, sexp obj, sexp out) {
if (sexp_stringp(obj))
sexp_write_string(ctx, sexp_string_data(obj), out);
else if (sexp_charp(obj))
sexp_write_char(ctx, sexp_unbox_character(obj), out);
else
sexp_write(ctx, obj, out);
return SEXP_VOID;
}
sexp sexp_flush_output (sexp ctx, sexp out) {
sexp_flush(ctx, out);
return SEXP_VOID;
}
#define INIT_STRING_BUFFER_SIZE 128
sexp sexp_read_string(sexp ctx, sexp in) {
int c, i=0, size=INIT_STRING_BUFFER_SIZE;
char initbuf[INIT_STRING_BUFFER_SIZE];
char *buf=initbuf, *tmp;
sexp res;
for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
if (c == '\\') {
c = sexp_read_char(ctx, in);
switch (c) {
case 'n': c = '\n'; break;
case 'r': c = '\r'; break;
case 't': c = '\t'; break;
}
}
if (c == EOF) {
res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in);
break;
}
buf[i++] = c;
if (i >= size) { /* expand buffer w/ malloc(), later free() it */
tmp = (char*) malloc(size*2);
memcpy(tmp, buf, i);
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
buf = tmp;
size *= 2;
}
}
buf[i] = '\0';
res = sexp_c_string(ctx, buf, i);
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
return res;
}
sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) {
int c, i=0, size=INIT_STRING_BUFFER_SIZE;
char initbuf[INIT_STRING_BUFFER_SIZE];
char *buf=initbuf, *tmp;
sexp res;
if (init != EOF)
buf[i++] = init;
for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
if (c == '\\') c = sexp_read_char(ctx, in);
if (c == EOF || is_separator(c)) {
sexp_push_char(ctx, c, in);
break;
}
buf[i++] = c;
if (i >= size) { /* expand buffer w/ malloc(), later free() it */
tmp = (char*) malloc(size*2);
memcpy(tmp, buf, i);
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
buf = tmp;
size *= 2;
}
}
buf[i] = '\0';
res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i));
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
return res;
}
sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_uint_t whole, int negp) {
sexp exponent=SEXP_VOID;
double res=0.0, scale=0.1, e=0.0;
int c;
for (c=sexp_read_char(ctx, in);
isdigit(c);
c=sexp_read_char(ctx, in), scale*=0.1)
res += digit_value(c)*scale;
if (c=='e' || c=='E') {
exponent = sexp_read_number(ctx, in, 10);
if (sexp_exceptionp(exponent)) return exponent;
e = (sexp_fixnump(exponent) ? sexp_unbox_fixnum(exponent)
: sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0);
} else if ((c!=EOF) && ! is_separator(c)) {
return sexp_read_error(ctx, "invalid numeric syntax",
sexp_make_character(c), in);
} else {
sexp_push_char(ctx, c, in);
}
res = ((double)whole + res) * pow(10, e);
if (negp) res *= -1;
if ((scale == 0.1) && (exponent != SEXP_VOID) && (res == round(res)))
return sexp_make_fixnum(res);
else
return sexp_make_flonum(ctx, res);
}
sexp sexp_read_number(sexp ctx, sexp in, int base) {
sexp den;
sexp_uint_t res = 0, tmp;
int c, digit, negativep = 0;
c = sexp_read_char(ctx, in);
if (c == '-')
negativep = 1;
else if (isdigit(c))
res = digit_value(c);
for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) {
digit = digit_value(c);
if ((digit < 0) || (digit >= base))
break;
tmp = res * base + digit;
#if USE_BIGNUMS
if ((tmp < res) || (tmp > SEXP_MAX_FIXNUM)) {
sexp_push_char(ctx, c, in);
return sexp_read_bignum(ctx, in, res, (negativep ? -1 : 1), base);
}
#endif
res = tmp;
}
if (c=='.' || c=='e' || c=='E') {
if (base != 10)
return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
if (c!='.') sexp_push_char(ctx, c, in);
return sexp_read_float_tail(ctx, in, res, negativep);
} else if (c=='/') {
den = sexp_read_number(ctx, in, base);
if (! sexp_fixnump(den))
return (sexp_exceptionp(den)
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
return sexp_make_flonum(ctx, (double)(negativep ? -res : res)
/ (double)sexp_unbox_fixnum(den));
} else {
if ((c!=EOF) && ! is_separator(c))
return sexp_read_error(ctx, "invalid numeric syntax",
sexp_make_character(c), in);
sexp_push_char(ctx, c, in);
}
return sexp_make_fixnum(negativep ? -res : res);
}
sexp sexp_read_raw (sexp ctx, sexp in) {
char *str;
int c1, c2, line;
sexp tmp2;
sexp_gc_var2(res, tmp);
sexp_gc_preserve2(ctx, res, tmp);
scan_loop:
switch (c1 = sexp_read_char(ctx, in)) {
case EOF:
res = SEXP_EOF;
break;
case ';':
while ((c1 = sexp_read_char(ctx, in)) != EOF)
if (c1 == '\n')
break;
/* ... FALLTHROUGH ... */
case '\n':
sexp_port_line(in)++;
goto scan_loop;
case ' ':
case '\t':
case '\r':
goto scan_loop;
case '\'':
res = sexp_read(ctx, in);
if (! sexp_exceptionp(res))
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUOTE_SYMBOL), res);
break;
case '`':
res = sexp_read(ctx, in);
if (! sexp_exceptionp(res))
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL), res);
break;
case ',':
if ((c1 = sexp_read_char(ctx, in)) == '@') {
res = sexp_read(ctx, in);
if (! sexp_exceptionp(res))
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL), res);
} else {
sexp_push_char(ctx, c1, in);
res = sexp_read(ctx, in);
if (! sexp_exceptionp(res))
res = sexp_list2(ctx, sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL), res);
}
break;
case '"':
res = sexp_read_string(ctx, in);
break;
case '(':
line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1);
res = SEXP_NULL;
tmp = sexp_read_raw(ctx, in);
while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) {
if (sexp_exceptionp(tmp)) {
res = tmp;
break;
}
res = sexp_cons(ctx, tmp, res);
tmp = sexp_read_raw(ctx, in);
}
if (! sexp_exceptionp(res)) {
if (tmp == SEXP_RAWDOT) { /* dotted list */
if (res == SEXP_NULL) {
res = sexp_read_error(ctx, "dot before any elements in list",
SEXP_NULL, in);
} else {
tmp = sexp_read_raw(ctx, in);
if (sexp_exceptionp(tmp)) {
res = tmp;
} else if (tmp == SEXP_CLOSE) {
res = sexp_read_error(ctx, "no final element in list after dot",
SEXP_NULL, in);
} else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) {
res = sexp_read_error(ctx, "multiple tokens in dotted tail",
SEXP_NULL, in);
} else {
tmp2 = res;
res = sexp_nreverse(ctx, res);
sexp_cdr(tmp2) = tmp;
}
}
} else if (tmp == SEXP_CLOSE) {
res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res);
} else {
res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in);
}
}
if ((line >= 0) && sexp_pairp(res)) {
sexp_pair_source(res)
= sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line));
}
if (sexp_port_sourcep(in))
for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp))
sexp_immutablep(tmp) = 1;
break;
case '#':
switch (c1=sexp_read_char(ctx, in)) {
case 'b':
res = sexp_read_number(ctx, in, 2); break;
case 'o':
res = sexp_read_number(ctx, in, 8); break;
case 'd':
res = sexp_read_number(ctx, in, 10); break;
case 'x':
res = sexp_read_number(ctx, in, 16); break;
case 'e':
res = sexp_read(ctx, in);
if (sexp_flonump(res))
res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(res));
break;
case 'i':
res = sexp_read(ctx, in);
if (sexp_fixnump(res))
res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res));
break;
case 'f':
case 't':
c2 = sexp_read_char(ctx, in);
if (c2 == EOF || is_separator(c2)) {
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
sexp_push_char(ctx, c2, in);
} else {
tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2));
res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in);
}
break;
/* case '0': case '1': case '2': case '3': case '4': */
/* case '5': case '6': case '7': case '8': case '9': */
case ';':
tmp = sexp_read_raw(ctx, in); /* discard */
if (sexp_exceptionp(tmp))
res = tmp;
else
goto scan_loop;
break;
case '!':
while ((c1 = sexp_read_char(ctx, in)) != EOF)
if (c1 == '\n')
break;
sexp_port_line(in)++;
goto scan_loop;
case '\\':
c1 = sexp_read_char(ctx, in);
res = sexp_read_symbol(ctx, in, c1, 0);
if (sexp_stringp(res)) {
str = sexp_string_data(res);
if (sexp_string_length(res) == 0)
res =
sexp_read_error(ctx, "unexpected end of character literal",
SEXP_NULL, in);
if (sexp_string_length(res) == 1) {
res = sexp_make_character(c1);
} else if ((c1 == 'x' || c1 == 'X') &&
isxdigit(str[1]) && isxdigit(str[2]) && str[3] == '\0') {
res = sexp_make_character(16 * digit_value(str[1])
+ digit_value(str[2]));
} else {
if (strcasecmp(str, "space") == 0)
res = sexp_make_character(' ');
else if (strcasecmp(str, "newline") == 0)
res = sexp_make_character('\n');
else if (strcasecmp(str, "return") == 0)
res = sexp_make_character('\r');
else if (strcasecmp(str, "tab") == 0)
res = sexp_make_character('\t');
else {
tmp = sexp_c_string(ctx, str, -1);
res = sexp_read_error(ctx, "unknown character name", tmp, in);
}
}
}
break;
case '(':
sexp_push_char(ctx, c1, in);
res = sexp_read(ctx, in);
if (sexp_not(sexp_listp(ctx, res))) {
if (! sexp_exceptionp(res)) {
res = sexp_read_error(ctx, "dotted list not allowed in vector syntax",
SEXP_NULL,
in);
}
} else {
res = sexp_list_to_vector(ctx, res);
}
break;
default:
res = sexp_read_error(ctx, "invalid # syntax",
sexp_make_character(c1), in);
}
break;
case '.':
c1 = sexp_read_char(ctx, in);
if (c1 == EOF || is_separator(c1)) {
res = SEXP_RAWDOT;
} else if (isdigit(c1)) {
sexp_push_char(ctx, c1, in);
res = sexp_read_float_tail(ctx, in, 0, 0);
} else {
sexp_push_char(ctx, c1, in);
res = sexp_read_symbol(ctx, in, '.', 1);
}
break;
case ')':
res = SEXP_CLOSE;
break;
case '+':
case '-':
c2 = sexp_read_char(ctx, in);
if (c2 == '.' || isdigit(c2)) {
sexp_push_char(ctx, c2, in);
res = sexp_read_number(ctx, in, 10);
if ((c1 == '-') && ! sexp_exceptionp(res)) {
#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
#if USE_BIGNUMS
if (sexp_bignump(res))
sexp_bignum_sign(res) = -sexp_bignum_sign(res);
else
#endif
res = sexp_fx_mul(res, sexp_make_fixnum(-1));
}
} else {
sexp_push_char(ctx, c2, in);
res = sexp_read_symbol(ctx, in, c1, 1);
#if USE_INFINITIES
if (res == sexp_intern(ctx, "+inf.0"))
res = sexp_make_flonum(ctx, 1.0/0.0);
else if (res == sexp_intern(ctx, "-inf.0"))
res = sexp_make_flonum(ctx, -1.0/0.0);
else if (res == sexp_intern(ctx, "+nan.0"))
res = sexp_make_flonum(ctx, 0.0/0.0);
#endif
}
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
sexp_push_char(ctx, c1, in);
res = sexp_read_number(ctx, in, 10);
break;
default:
res = sexp_read_symbol(ctx, in, c1, 1);
break;
}
if (sexp_port_sourcep(in) && sexp_pointerp(res))
sexp_immutablep(res) = 1;
sexp_gc_release2(ctx);
return res;
}
sexp sexp_read (sexp ctx, sexp in) {
sexp res = sexp_read_raw(ctx, in);
if (res == SEXP_CLOSE)
return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
if (res == SEXP_RAWDOT)
return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in);
return res;
}
sexp sexp_read_from_string(sexp ctx, char *str) {
sexp res;
sexp_gc_var2(s, in);
sexp_gc_preserve2(ctx, s, in);
s = sexp_c_string(ctx, str, -1);
in = sexp_make_input_string_port(ctx, s);
res = sexp_read(ctx, in);
sexp_gc_release2(ctx);
return res;
}
sexp sexp_write_to_string(sexp ctx, sexp obj) {
sexp str;
sexp_gc_var1(out);
sexp_gc_preserve1(ctx, out);
out = sexp_make_output_string_port(ctx);
sexp_write(ctx, obj, out);
str = sexp_get_output_string(ctx, out);
sexp_gc_release1(ctx);
return str;
}
void sexp_init(void) {
#if USE_GLOBAL_SYMBOLS
int i;
#endif
if (! sexp_initialized_p) {
sexp_initialized_p = 1;
#if USE_BOEHM
GC_init();
#if USE_GLOBAL_SYMBOLS
GC_add_roots((char*)&sexp_symbol_table,
((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1);
#endif
#elif ! USE_MALLOC
sexp_gc_init();
#endif
#if USE_GLOBAL_SYMBOLS
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
sexp_symbol_table[i] = SEXP_NULL;
#endif
}
}
Reference in a new issue View git blame Copy permalink