mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
2552 lines
88 KiB
C
2552 lines
88 KiB
C
/* sexp.c -- standalone sexp library implementation */
|
|
/* Copyright (c) 2009-2011 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 SEXP_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, double whole, int negp);
|
|
|
|
static const 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_ */
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x6_ */
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x7_ */
|
|
};
|
|
|
|
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<0x80 && sexp_separators[c];
|
|
}
|
|
|
|
#if SEXP_USE_GLOBAL_SYMBOLS
|
|
sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE];
|
|
#endif
|
|
|
|
sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param) {
|
|
sexp res = (sexp) sexp_alloc(ctx, size);
|
|
if (res && ! sexp_exceptionp(res)) {
|
|
sexp_pointer_tag(res) = tag;
|
|
#if SEXP_USE_TRACK_ALLOC_SOURCE
|
|
sexp_pointer_source(res) = source;
|
|
#endif
|
|
#if SEXP_USE_HEADER_MAGIC
|
|
sexp_pointer_magic(res) = SEXP_POINTER_MAGIC;
|
|
#endif
|
|
}
|
|
return res;
|
|
}
|
|
|
|
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
|
sexp sexp_write_simple_object (sexp ctx sexp_api_params(self, n), sexp obj, sexp writer, sexp out) {
|
|
sexp t, x, *elts;
|
|
sexp_gc_var1(args);
|
|
sexp_sint_t i, len, nulls=0;
|
|
i = sexp_pointer_tag(obj);
|
|
sexp_write_char(ctx, '{', out);
|
|
if (i >= sexp_context_num_types(ctx)) {
|
|
sexp_write_string(ctx, "invalid", out);
|
|
} else {
|
|
sexp_gc_preserve1(ctx, args);
|
|
t = sexp_object_type(ctx, obj);
|
|
sexp_write_string(ctx, sexp_string_data(sexp_type_name(t)), out);
|
|
sexp_write_char(ctx, ' ', out);
|
|
if (sexp_type_id(t) && sexp_truep(sexp_type_id(t))) {
|
|
sexp_write(ctx, sexp_type_id(t), out);
|
|
} else {
|
|
sexp_write_char(ctx, '#', out);
|
|
sexp_write(ctx, sexp_make_fixnum(sexp_type_tag(t)), out);
|
|
}
|
|
len = sexp_type_num_slots_of_object(t, obj);
|
|
elts = (sexp*) (((char*)obj) + sexp_type_field_base(t));
|
|
args = sexp_list1(ctx, SEXP_FALSE);
|
|
for (i=0; i<len; i++) {
|
|
x = sexp_slot_ref(obj, i);
|
|
if (x) {
|
|
if (nulls)
|
|
while (--nulls) sexp_write_string(ctx, " #<null>", out);
|
|
sexp_write_char(ctx, ' ', out);
|
|
if (writer && sexp_applicablep(writer)) {
|
|
sexp_car(args) = x;
|
|
x = sexp_apply(ctx, writer, args);
|
|
if (sexp_exceptionp(x)) sexp_print_exception(ctx, x, out);
|
|
} else {
|
|
sexp_write(ctx, sexp_slot_ref(obj, i), out);
|
|
}
|
|
} else {
|
|
nulls++;
|
|
}
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
sexp_write_char(ctx, '}', out);
|
|
return SEXP_VOID;
|
|
}
|
|
#else
|
|
#define sexp_write_simple_object NULL
|
|
#endif
|
|
|
|
sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) {
|
|
if (sexp_port_openp(port)) {
|
|
sexp_port_openp(port) = 0;
|
|
if (sexp_port_stream(port) && ! sexp_port_no_closep(port)) {
|
|
fclose(sexp_port_stream(port));
|
|
if (sexp_port_buf(port) && sexp_oportp(port))
|
|
free(sexp_port_buf(port));
|
|
}
|
|
}
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
#if SEXP_USE_AUTOCLOSE_PORTS
|
|
#define SEXP_FINALIZE_PORT sexp_finalize_port
|
|
#else
|
|
#define SEXP_FINALIZE_PORT NULL
|
|
#endif
|
|
|
|
#if SEXP_USE_DL
|
|
sexp sexp_finalize_dl (sexp ctx sexp_api_params(self, n), sexp dl) {
|
|
dlclose(sexp_dl_handle(dl));
|
|
return SEXP_VOID;
|
|
}
|
|
#endif
|
|
|
|
static struct sexp_type_struct _sexp_type_specs[] = {
|
|
{SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Object", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_TYPE, sexp_offsetof(type, name), 4+SEXP_USE_DL, 4+SEXP_USE_DL, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Type", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Integer", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Number", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Char", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Boolean", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Pair", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Symbol", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Byte-Vector", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#if SEXP_USE_PACKED_STRINGS
|
|
{SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#else
|
|
{SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"String", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#endif
|
|
{SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, (sexp)"Vector", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Flonum", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, (sexp)"Bignum", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#if SEXP_USE_RATIOS
|
|
{SEXP_RATIO, sexp_offsetof(ratio, numerator), 2, 2, 0, 0, sexp_sizeof(ratio), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Ratio", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
{SEXP_COMPLEX, sexp_offsetof(complex, real), 2, 2, 0, 0, sexp_sizeof(complex), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Complex", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#endif
|
|
{SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Input-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL},
|
|
{SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, SEXP_FINALIZE_PORT, NULL},
|
|
{SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Exception", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_MACRO, sexp_offsetof(macro, proc), 3, 3, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Macro", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Syntactic-Closure", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_ENV, sexp_offsetof(env, parent), 3+SEXP_USE_RENAME_BINDINGS, 3+SEXP_USE_RENAME_BINDINGS, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Environment", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Bytecode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_CORE, sexp_offsetof(core, name), 1, 1, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Core-Form", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#if SEXP_USE_DL
|
|
{SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, sexp_finalize_dl, NULL},
|
|
#endif
|
|
{SEXP_OPCODE, sexp_offsetof(opcode, name), 8+SEXP_USE_DL, 8+SEXP_USE_DL, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Conditional", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Reference", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Set!", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sequence", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Literal", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, (sexp_proc4)sexp_write_simple_object},
|
|
{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), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_CONTEXT, sexp_offsetof(context, bc), 13+SEXP_USE_DL, 13+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
{SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#if SEXP_USE_AUTO_FORCE
|
|
{SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
|
|
#endif
|
|
};
|
|
|
|
#define SEXP_INIT_NUM_TYPES (SEXP_NUM_CORE_TYPES*2)
|
|
|
|
#if SEXP_USE_TYPE_DEFS
|
|
|
|
sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
|
|
sexp parent, sexp slots,
|
|
sexp fb, sexp felb, sexp flb, sexp flo, sexp fls,
|
|
sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo,
|
|
sexp ws, sexp we, sexp_proc2 f, sexp_proc4 p) {
|
|
sexp *v1, *v2;
|
|
sexp_gc_var2(res, type);
|
|
sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
|
|
type_array_size=sexp_context_type_array_size(ctx);
|
|
sexp_gc_preserve2(ctx, res, type);
|
|
if (num_types >= SEXP_MAXIMUM_TYPES) {
|
|
res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name);
|
|
} else if (! sexp_stringp(name)) {
|
|
res = sexp_type_exception(ctx, self, SEXP_STRING, name);
|
|
} else {
|
|
if (num_types >= type_array_size) {
|
|
len = type_array_size*2;
|
|
if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES;
|
|
res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID);
|
|
if (sexp_exceptionp(res)) {
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
v1 = sexp_vector_data(res);
|
|
v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
|
|
for (i=0; i<num_types; i++)
|
|
v1[i] = v2[i];
|
|
sexp_global(ctx, SEXP_G_TYPES) = res;
|
|
}
|
|
sexp_type_by_index(ctx, num_types) = sexp_alloc_type(ctx, type, SEXP_TYPE);
|
|
type = sexp_type_by_index(ctx, num_types);
|
|
if (!sexp_exceptionp(type)) {
|
|
sexp_pointer_tag(type) = SEXP_TYPE;
|
|
sexp_type_tag(type) = num_types;
|
|
sexp_type_slots(type) = slots;
|
|
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_weak_base(type) = sexp_unbox_fixnum(w);
|
|
sexp_type_weak_len_base(type) = sexp_unbox_fixnum(wb);
|
|
sexp_type_weak_len_off(type) = sexp_unbox_fixnum(wo);
|
|
sexp_type_weak_len_scale(type) = sexp_unbox_fixnum(ws);
|
|
sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we);
|
|
sexp_type_name(type) = name;
|
|
sexp_type_finalize(type) = f;
|
|
sexp_type_id(type) = SEXP_FALSE;
|
|
if (f) sexp_type_dl(type) = sexp_context_dl(ctx);
|
|
sexp_type_print(type) = p;
|
|
if (sexp_typep(parent)) {
|
|
len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1;
|
|
sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID);
|
|
if (sexp_vectorp(sexp_type_cpl(parent)))
|
|
memcpy(sexp_vector_data(sexp_type_cpl(type)),
|
|
sexp_vector_data(sexp_type_cpl(parent)),
|
|
len * sizeof(sexp));
|
|
else
|
|
sexp_vector_data(sexp_type_cpl(type))[len-1] = parent;
|
|
} else {
|
|
len = 0;
|
|
sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID);
|
|
}
|
|
sexp_vector_data(sexp_type_cpl(type))[len] = type;
|
|
sexp_type_depth(type) = len;
|
|
sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1);
|
|
}
|
|
res = type;
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp parent, sexp slots) {
|
|
short i, num_slots = sexp_unbox_fixnum(sexp_length(ctx, slots));
|
|
sexp type_size, num_slots_obj, cpl, tmp;
|
|
if (parent && sexp_typep(parent)) {
|
|
num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(parent)));
|
|
if (sexp_vectorp((cpl = sexp_type_cpl(parent))))
|
|
for (i=sexp_vector_length(cpl)-1; i>=0; i--) {
|
|
tmp = sexp_vector_ref(cpl, sexp_make_fixnum(i));
|
|
num_slots += sexp_unbox_fixnum(sexp_length(ctx, sexp_type_slots(tmp)));
|
|
}
|
|
}
|
|
num_slots_obj = sexp_make_fixnum(num_slots);
|
|
type_size = sexp_make_fixnum(sexp_sizeof_header + sizeof(sexp)*num_slots);
|
|
return
|
|
sexp_register_type(ctx, name, parent, slots,
|
|
sexp_make_fixnum(sexp_offsetof_slot0),
|
|
num_slots_obj, num_slots_obj, SEXP_ZERO, SEXP_ZERO,
|
|
type_size, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
|
|
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL,
|
|
(sexp_proc4)sexp_write_simple_object);
|
|
}
|
|
|
|
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
|
sexp sexp_lookup_type_op(sexp ctx sexp_api_params(self, n), sexp name, sexp id) {
|
|
int i;
|
|
sexp res;
|
|
const char* str = sexp_string_data(name);
|
|
if (sexp_fixnump(id)) {
|
|
i = sexp_unbox_fixnum(id);
|
|
if (i < sexp_context_num_types(ctx)
|
|
&& strcmp(str, sexp_string_data(sexp_type_name_by_index(ctx, i))) == 0)
|
|
return sexp_type_by_index(ctx, i);
|
|
else
|
|
return SEXP_FALSE;
|
|
}
|
|
for (i=sexp_context_num_types(ctx)-1; i>=0; i--)
|
|
if (strcmp(str, sexp_string_data(sexp_type_name_by_index(ctx, i))) == 0) {
|
|
res = sexp_type_by_index(ctx, i);
|
|
if (sexp_stringp(id)
|
|
&& !(sexp_stringp(sexp_type_id(res))
|
|
&& strcmp(sexp_string_data(id), sexp_string_data(sexp_type_id(res))) == 0))
|
|
return SEXP_FALSE;
|
|
return res;
|
|
}
|
|
return SEXP_FALSE;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), 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 ! SEXP_USE_BOEHM
|
|
|
|
#if ! SEXP_USE_MALLOC
|
|
#include "gc.c"
|
|
#endif
|
|
|
|
#endif /* ! SEXP_USE_BOEHM */
|
|
|
|
/****************************** contexts ******************************/
|
|
|
|
void sexp_init_context_globals (sexp ctx) {
|
|
sexp type, *vec;
|
|
int i;
|
|
sexp_context_globals(ctx)
|
|
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_G_NUM_GLOBALS), SEXP_VOID);
|
|
#if ! SEXP_USE_GLOBAL_SYMBOLS
|
|
sexp_global(ctx, SEXP_G_SYMBOLS) = sexp_make_vector(ctx, sexp_make_fixnum(SEXP_SYMBOL_TABLE_SIZE), SEXP_NULL);
|
|
#endif
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
sexp_global(ctx, SEXP_G_FOLD_CASE_P) = sexp_make_boolean(SEXP_DEFAULT_FOLD_CASE_SYMS);
|
|
#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", -1);
|
|
sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1);
|
|
sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1);
|
|
sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1);
|
|
sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "current-input-port", -1);
|
|
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "current-output-port", -1);
|
|
sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "current-error-port", -1);
|
|
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "interaction-environment", -1);
|
|
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;
|
|
sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(SEXP_NUM_CORE_TYPES);
|
|
sexp_global(ctx, SEXP_G_TYPES)
|
|
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_INIT_NUM_TYPES), SEXP_VOID);
|
|
vec = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
|
|
for (i=0; i<SEXP_NUM_CORE_TYPES; i++) {
|
|
type = sexp_alloc_type(ctx, type, SEXP_TYPE);
|
|
memcpy(&(type->value), &(_sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
|
|
vec[i] = type;
|
|
sexp_type_name(type) = sexp_c_string(ctx, (char*)sexp_type_name(type), -1);
|
|
}
|
|
}
|
|
|
|
#if ! SEXP_USE_GLOBAL_HEAP
|
|
sexp sexp_bootstrap_context (sexp_uint_t size, sexp_uint_t max_size) {
|
|
sexp ctx;
|
|
sexp_heap heap;
|
|
struct sexp_struct dummy_ctx;
|
|
if (size < SEXP_MINIMUM_HEAP_SIZE) size = SEXP_INITIAL_HEAP_SIZE;
|
|
heap = sexp_make_heap(sexp_heap_align(size), sexp_heap_align(max_size));
|
|
if (!heap) return 0;
|
|
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);
|
|
if (!ctx || sexp_exceptionp(ctx)) {
|
|
sexp_free_heap(heap);
|
|
} else {
|
|
sexp_context_heap(ctx) = heap;
|
|
}
|
|
return ctx;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) {
|
|
sexp_gc_var1(res);
|
|
if (ctx) sexp_gc_preserve1(ctx, res);
|
|
#if ! SEXP_USE_GLOBAL_HEAP
|
|
if (! ctx) {
|
|
res = sexp_bootstrap_context(size, max_size);
|
|
if (!res || sexp_exceptionp(res)) return res;
|
|
} else
|
|
#endif
|
|
{
|
|
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
|
|
#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC
|
|
sexp_context_heap(res) = sexp_context_heap(ctx);
|
|
#endif
|
|
}
|
|
if (!res || sexp_exceptionp(res)) return res;
|
|
sexp_context_parent(res) = ctx;
|
|
sexp_context_lambda(res) = SEXP_FALSE;
|
|
sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE;
|
|
sexp_context_fv(res) = SEXP_NULL;
|
|
sexp_context_saves(res) = NULL;
|
|
sexp_context_params(res) = SEXP_NULL;
|
|
sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0;
|
|
sexp_context_tailp(res) = 1;
|
|
#if SEXP_USE_GREEN_THREADS
|
|
sexp_context_event(res) = SEXP_FALSE;
|
|
sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM;
|
|
#endif
|
|
#if SEXP_USE_DL
|
|
sexp_context_dl(res) = ctx ? sexp_context_dl(ctx) : SEXP_FALSE;
|
|
#endif
|
|
if (ctx) {
|
|
sexp_context_globals(res) = sexp_context_globals(ctx);
|
|
sexp_gc_release1(ctx);
|
|
} else {
|
|
sexp_init_context_globals(res);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
#if ! SEXP_USE_GLOBAL_HEAP
|
|
void sexp_destroy_context (sexp ctx) {
|
|
sexp_heap heap, tmp;
|
|
size_t sum_freed;
|
|
if (sexp_context_heap(ctx)) {
|
|
heap = sexp_context_heap(ctx);
|
|
sexp_markedp(ctx) = 1;
|
|
sexp_markedp(sexp_context_globals(ctx)) = 1;
|
|
sexp_mark(ctx, sexp_global(ctx, SEXP_G_TYPES));
|
|
sexp_sweep(ctx, &sum_freed); /* sweep w/o mark to run finalizers */
|
|
sexp_context_heap(ctx) = NULL;
|
|
for ( ; heap; heap=tmp) {
|
|
tmp = heap->next;
|
|
sexp_free_heap(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_string_cat3 (sexp ctx, char *pre, char *mid, char* suf) {
|
|
int plen=strlen(pre), mlen=strlen(mid), slen=strlen(suf);
|
|
char *s;
|
|
sexp str;
|
|
str = sexp_make_string(ctx, sexp_make_fixnum(plen+mlen+slen), SEXP_VOID);
|
|
memcpy(s=sexp_string_data(str), pre, plen);
|
|
memcpy(s+plen, mid, mlen);
|
|
memcpy(s+plen+mlen, suf, slen);
|
|
return str;
|
|
}
|
|
|
|
sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) {
|
|
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", -1),
|
|
str = sexp_c_string(ctx, ms, -1),
|
|
((sexp_pairp(ir) || sexp_nullp(ir))
|
|
? ir : (irr = sexp_list1(ctx, ir))),
|
|
self, SEXP_FALSE);
|
|
sexp_gc_release3(ctx);
|
|
return res;
|
|
}
|
|
|
|
static sexp type_exception (sexp ctx, sexp self, sexp str, sexp obj, sexp src) {
|
|
sexp_gc_var2(res, sym);
|
|
sexp_gc_preserve2(ctx, res, sym);
|
|
sym = sexp_intern(ctx, "type", -1);
|
|
res = sexp_make_exception(ctx, sym, str, obj, self, src);
|
|
sexp_exception_irritants(res)=sexp_list1(ctx, sexp_exception_irritants(res));
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp obj) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = sexp_c_string(ctx, msg, -1);
|
|
res = type_exception(ctx, self, res, obj, SEXP_FALSE);
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp obj) {
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
res = sexp_string_cat3(ctx, "invalid type, expected ",
|
|
sexp_string_data(sexp_type_name_by_index(ctx, type_id)), "");
|
|
res = type_exception(ctx, self, res, obj, SEXP_FALSE);
|
|
sexp_gc_release1(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", -1), msg, res,
|
|
SEXP_FALSE, SEXP_FALSE);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), 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_exception_procedure(exn)) {
|
|
if (sexp_procedurep(sexp_exception_procedure(exn))) {
|
|
ls = sexp_bytecode_name(
|
|
sexp_procedure_code(sexp_exception_procedure(exn)));
|
|
if (ls && sexp_symbolp(ls)) {
|
|
sexp_write_string(ctx, " in ", out);
|
|
sexp_write(ctx, ls, out);
|
|
}
|
|
} else if (sexp_opcodep(sexp_exception_procedure(exn))) {
|
|
sexp_write_string(ctx, " in ", out);
|
|
sexp_display(ctx, sexp_opcode_name(sexp_exception_procedure(exn)), out);
|
|
}
|
|
}
|
|
ls = sexp_exception_source(exn);
|
|
if ((! (ls && sexp_pairp(ls)))
|
|
&& sexp_exception_procedure(exn)
|
|
&& sexp_procedurep(sexp_exception_procedure(exn)))
|
|
ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn)));
|
|
if (ls && sexp_pairp(ls)) {
|
|
if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) {
|
|
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, const char *msg, sexp ir, 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(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir));
|
|
res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1),
|
|
str, irr, SEXP_FALSE, name);
|
|
sexp_gc_release4(ctx);
|
|
return res;
|
|
}
|
|
|
|
/*************************** list utilities ***************************/
|
|
|
|
sexp sexp_cons_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) {
|
|
sexp a, b, tmp;
|
|
if (ls == SEXP_NULL) return ls;
|
|
sexp_assert_type(ctx, sexp_pairp, SEXP_PAIR, ls);
|
|
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_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) {
|
|
sexp tmp;
|
|
sexp_gc_var1(res);
|
|
if (! sexp_pairp(ls)) return ls;
|
|
sexp_gc_preserve1(ctx, res);
|
|
tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls));
|
|
for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp))
|
|
sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls));
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls1) {
|
|
sexp ls2;
|
|
sexp_uint_t res = 1;
|
|
if (!sexp_pairp(ls1))
|
|
return SEXP_ZERO;
|
|
for (ls2=sexp_cdr(ls1); sexp_pairp(ls2) && sexp_pairp(sexp_cdr(ls2));
|
|
res+=2, ls1=sexp_cdr(ls1), ls2=sexp_cddr(ls2))
|
|
if (ls1 == ls2)
|
|
return SEXP_FALSE;
|
|
return sexp_make_fixnum(res + (sexp_pairp(ls2) ? 1 : 0));
|
|
}
|
|
|
|
sexp sexp_equalp_bound (sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp bound) {
|
|
sexp_uint_t size;
|
|
sexp_sint_t i, len;
|
|
sexp t, *p, *q;
|
|
char *p0, *q0;
|
|
|
|
loop:
|
|
if (a == b)
|
|
return bound;
|
|
else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))
|
|
|| (sexp_pointer_tag(a) != sexp_pointer_tag(b)))
|
|
return SEXP_FALSE;
|
|
|
|
/* a and b are both pointers of the same type */
|
|
#if SEXP_USE_BIGNUMS
|
|
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
|
|
return !sexp_bignum_compare(a, b) ? bound : SEXP_FALSE;
|
|
#endif
|
|
#if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS
|
|
if (sexp_pointer_tag(a) == SEXP_FLONUM)
|
|
return (sexp_flonum_value(a) == sexp_flonum_value(b)) ? bound : SEXP_FALSE;
|
|
#endif
|
|
if (sexp_unbox_fixnum(bound) < 0)
|
|
return bound;
|
|
bound = sexp_fx_sub(bound, SEXP_ONE);
|
|
t = sexp_object_type(ctx, 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++) {
|
|
bound = sexp_equalp_bound(ctx sexp_api_pass(self, n), p[i], q[i], bound);
|
|
if (sexp_not(bound)) return SEXP_FALSE;
|
|
}
|
|
/* tail-recurse on the last value */
|
|
a = p[len-1]; b = q[len-1]; goto loop;
|
|
}
|
|
return bound;
|
|
}
|
|
|
|
sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
|
|
return sexp_make_boolean(
|
|
sexp_truep(sexp_equalp_bound(ctx sexp_api_pass(self, n), a, b,
|
|
sexp_make_fixnum(SEXP_MAX_FIXNUM))));
|
|
}
|
|
|
|
/********************* strings, symbols, vectors **********************/
|
|
|
|
sexp sexp_flonump_op (sexp ctx sexp_api_params(self, n), sexp x) {
|
|
return sexp_make_boolean(sexp_flonump(x));
|
|
}
|
|
|
|
#if ! SEXP_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;
|
|
}
|
|
#else
|
|
#if SEXP_64_BIT
|
|
float sexp_flonum_value (sexp x) {
|
|
union sexp_flonum_conv r;
|
|
r.bits = (sexp_uint_t)x >> 32;
|
|
return r.flonum;
|
|
}
|
|
sexp sexp_make_flonum (sexp ctx, float f) {
|
|
union sexp_flonum_conv x;
|
|
x.flonum = f;
|
|
return (sexp)(((sexp_uint_t)(x.bits) << 32) + SEXP_IFLONUM_TAG);
|
|
}
|
|
#endif
|
|
#endif
|
|
|
|
sexp sexp_make_bytes_op (sexp ctx sexp_api_params(self, n), sexp len, sexp i) {
|
|
sexp_sint_t clen = sexp_unbox_fixnum(len);
|
|
sexp s;
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
|
|
if (clen < 0) return sexp_xtype_exception(ctx, self, "negative length", len);
|
|
s = sexp_alloc_atomic(ctx, sexp_sizeof(bytes)+clen+1);
|
|
if (sexp_exceptionp(s)) return s;
|
|
sexp_pointer_tag(s) = SEXP_BYTES;
|
|
#if SEXP_USE_HEADER_MAGIC
|
|
sexp_pointer_magic(s) = SEXP_POINTER_MAGIC;
|
|
#endif
|
|
sexp_bytes_length(s) = clen;
|
|
if (sexp_fixnump(i))
|
|
memset(sexp_bytes_data(s), sexp_unbox_fixnum(i), clen);
|
|
sexp_bytes_data(s)[clen] = '\0';
|
|
return s;
|
|
}
|
|
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
|
|
static int sexp_utf8_initial_byte_count (int c) {
|
|
if (c < 0xC0) return 1;
|
|
if (c < 0xE0) return 2;
|
|
return ((c>>4)&1)+3;
|
|
}
|
|
|
|
static int sexp_utf8_char_byte_count (int c) {
|
|
if (c < 0x80) return 1;
|
|
if (c < 0x800) return 2;
|
|
if (c < 0x10000) return 3;
|
|
return 4;
|
|
}
|
|
|
|
void sexp_utf8_encode_char (unsigned char* p, int len, int c) {
|
|
switch (len) {
|
|
case 4: *p++ = (0xF0 + ((c)>>18)); *p++ = (0x80 + ((c>>12)&0x3F));
|
|
*p++ = (0x80 + ((c>>6)&0x3F)); *p = (0x80 + (c&0x3F)); break;
|
|
case 3: *p++ = (0xE0 + ((c)>>12)); *p++ = (0x80 + ((c>>6)&0x3F));
|
|
*p = (0x80 + (c&0x3F)); break;
|
|
case 2: *p++ = (0xC0 + ((c)>>6)); *p = (0x80 + (c&0x3F)); break;
|
|
default: *p = c; break;
|
|
}
|
|
}
|
|
|
|
sexp sexp_string_index_to_offset (sexp ctx sexp_api_params(self, n), sexp str, sexp index) {
|
|
sexp_sint_t i, j, limit;
|
|
unsigned char *p;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, index);
|
|
p = (unsigned char*)sexp_string_data(str);
|
|
limit = sexp_string_length(str);
|
|
for (j=0, i=sexp_unbox_fixnum(index); i>0 && j<limit; i--)
|
|
j += sexp_utf8_initial_byte_count(p[j]);
|
|
if (i>0)
|
|
return sexp_user_exception(ctx, self, "string-index->offset: index out of range", index);
|
|
return sexp_make_fixnum(j);
|
|
}
|
|
|
|
#endif
|
|
|
|
sexp sexp_make_string_op (sexp ctx sexp_api_params(self, n), sexp len, sexp ch)
|
|
{
|
|
sexp i = (sexp_charp(ch) ? sexp_make_fixnum(sexp_unbox_character(ch)) : ch);
|
|
sexp_gc_var2(b, s);
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
int j, clen;
|
|
if (sexp_charp(ch) && (sexp_unbox_character(ch) >= 0x80)) {
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
|
|
clen = sexp_utf8_char_byte_count(sexp_unbox_character(ch));
|
|
b = sexp_make_bytes_op(ctx sexp_api_pass(self, n),
|
|
sexp_fx_mul(len, sexp_make_fixnum(clen)), SEXP_VOID);
|
|
if (sexp_exceptionp(b)) return b;
|
|
for (j=0; j<sexp_unbox_fixnum(len); j++)
|
|
sexp_utf8_encode_char((unsigned char*)sexp_bytes_data(b)+(j*clen), clen,
|
|
sexp_unbox_character(ch));
|
|
} else
|
|
#endif
|
|
b = sexp_make_bytes_op(ctx sexp_api_pass(self, n), len, i);
|
|
if (sexp_exceptionp(b)) return b;
|
|
#if SEXP_USE_PACKED_STRINGS
|
|
sexp_pointer_tag(b) = SEXP_STRING;
|
|
return b;
|
|
#else
|
|
sexp_gc_preserve2(ctx, b, s);
|
|
s = sexp_alloc_type(ctx, string, SEXP_STRING);
|
|
sexp_string_bytes(s) = b;
|
|
sexp_string_offset(s) = 0;
|
|
sexp_string_length(s) = sexp_bytes_length(b);
|
|
sexp_gc_release2(ctx);
|
|
return s;
|
|
#endif
|
|
}
|
|
|
|
sexp sexp_c_string (sexp ctx, const 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);
|
|
if (sexp_exceptionp(s)) return s;
|
|
memcpy(sexp_string_data(s), str, len);
|
|
sexp_string_data(s)[len] = '\0';
|
|
return s;
|
|
}
|
|
|
|
sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) {
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
|
|
if (sexp_not(end))
|
|
end = sexp_make_fixnum(sexp_string_length(str));
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, 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;
|
|
}
|
|
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
sexp sexp_utf8_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end) {
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
|
|
start = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, start);
|
|
if (sexp_fixnump(end))
|
|
end = sexp_string_index_to_offset(ctx sexp_api_pass(self, n), str, end);
|
|
return sexp_substring_op(ctx sexp_api_pass(self, n), str, start, end);
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep) {
|
|
sexp res, ls;
|
|
sexp_uint_t len=0, i=0, sep_len=0;
|
|
char *p, *csep=NULL;
|
|
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls), i++)
|
|
if (! sexp_stringp(sexp_car(ls)))
|
|
return sexp_type_exception(ctx, self, SEXP_STRING, sexp_car(ls));
|
|
else
|
|
len += sexp_string_length(sexp_car(ls));
|
|
if (sexp_stringp(sep) && ((sep_len=sexp_string_length(sep)) > 0)) {
|
|
csep = sexp_string_data(sep);
|
|
len += sep_len*(i-1);
|
|
}
|
|
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;
|
|
if (sep_len && sexp_pairp(sexp_cdr(ls))) {
|
|
memcpy(p, csep, sep_len);
|
|
p += sep_len;
|
|
}
|
|
}
|
|
*p = '\0';
|
|
return res;
|
|
}
|
|
|
|
#define FNV_PRIME 16777619
|
|
#define FNV_OFFSET_BASIS 2166136261uL
|
|
|
|
#if SEXP_USE_HASH_SYMS
|
|
|
|
static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len,
|
|
sexp_uint_t acc) {
|
|
for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;}
|
|
return acc;
|
|
}
|
|
|
|
#endif
|
|
|
|
sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) {
|
|
#if SEXP_USE_HUFF_SYMS
|
|
struct sexp_huff_entry he;
|
|
sexp_uint_t space=3, newbits;
|
|
char c;
|
|
#endif
|
|
sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0;
|
|
const char *p=str;
|
|
sexp ls, tmp;
|
|
sexp_gc_var1(sym);
|
|
|
|
if (len < 0) len = strlen(str);
|
|
|
|
#if SEXP_USE_HUFF_SYMS
|
|
res = 0;
|
|
for ( ; i<len; i++, p++) {
|
|
c = *p;
|
|
if ((unsigned char)c > 127)
|
|
goto normal_intern;
|
|
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);
|
|
|
|
normal_intern:
|
|
#endif
|
|
#if SEXP_USE_HASH_SYMS
|
|
bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE);
|
|
#else
|
|
bucket = 0;
|
|
#endif
|
|
for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls))
|
|
if ((sexp_symbol_length(tmp=sexp_car(ls)) == len)
|
|
&& ! strncmp(str, sexp_symbol_data(tmp), len))
|
|
return sexp_car(ls);
|
|
|
|
/* not found, make a new symbol */
|
|
sexp_gc_preserve1(ctx, sym);
|
|
sym = sexp_c_string(ctx, str, len);
|
|
if (sexp_exceptionp(sym)) return sym;
|
|
#if ! SEXP_USE_PACKED_STRINGS
|
|
sym = sexp_string_bytes(sym);
|
|
#endif
|
|
sexp_pointer_tag(sym) = SEXP_SYMBOL;
|
|
sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym);
|
|
sexp_gc_release1(ctx);
|
|
return sym;
|
|
}
|
|
|
|
sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str) {
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str));
|
|
}
|
|
|
|
sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp ls) {
|
|
int i;
|
|
sexp x, *elts, vec = sexp_make_vector(ctx, sexp_length(ctx, ls), SEXP_VOID);
|
|
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 type_id, void *value,
|
|
sexp parent, int freep) {
|
|
sexp ptr;
|
|
if (! value) return SEXP_FALSE;
|
|
ptr = sexp_alloc_type(ctx, cpointer, type_id);
|
|
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 SEXP_USE_BIGNUMS
|
|
#include "opt/bignum.c"
|
|
#endif
|
|
|
|
#if SEXP_USE_STRING_STREAMS
|
|
|
|
#define SEXP_INIT_STRING_PORT_SIZE 128
|
|
|
|
#if SEXP_BSD
|
|
|
|
#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
|
|
#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, SEXP_ONE)
|
|
#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, SEXP_TWO)
|
|
#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, SEXP_THREE)
|
|
|
|
#define sexp_stream_ctx_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ZERO, x)
|
|
#define sexp_stream_buf_set(vec, x) sexp_vector_set((sexp)vec, SEXP_ONE, x)
|
|
#define sexp_stream_size_set(vec, x) sexp_vector_set((sexp)vec, SEXP_TWO, x)
|
|
#define sexp_stream_pos_set(vec, x) sexp_vector_set((sexp)vec, SEXP_THREE, x)
|
|
|
|
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_set(vec, sexp_make_fixnum(pos + 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_set(vec, newbuf);
|
|
sexp_stream_size_set(vec, sexp_make_fixnum(newpos*2));
|
|
}
|
|
memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n);
|
|
sexp_stream_pos_set(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_set(vec, sexp_make_fixnum(pos));
|
|
return pos;
|
|
}
|
|
|
|
sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) {
|
|
FILE *in;
|
|
sexp res;
|
|
sexp_gc_var1(cookie);
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_gc_preserve1(ctx, cookie);
|
|
cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
|
|
sexp_stream_ctx_set(cookie, ctx);
|
|
sexp_stream_buf_set(cookie, str);
|
|
sexp_stream_size_set(cookie, sexp_make_fixnum(sexp_string_length(str)));
|
|
sexp_stream_pos_set(cookie, SEXP_ZERO);
|
|
in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
|
|
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
|
|
sexp_port_cookie(res) = cookie;
|
|
sexp_port_binaryp(res) = 0;
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
|
|
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_set(cookie, ctx);
|
|
sexp_stream_buf_set(cookie, sexp_make_string(ctx, size, SEXP_VOID));
|
|
sexp_stream_size_set(cookie, size);
|
|
sexp_stream_pos_set(cookie, SEXP_ZERO);
|
|
out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
|
|
res = sexp_make_output_port(ctx, out, SEXP_FALSE);
|
|
sexp_port_cookie(res) = cookie;
|
|
sexp_port_binaryp(res) = 0;
|
|
sexp_gc_release1(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
|
sexp cookie = sexp_port_cookie(port);
|
|
fflush(sexp_port_stream(port));
|
|
return sexp_substring(ctx,
|
|
sexp_stream_buf(cookie),
|
|
SEXP_ZERO,
|
|
sexp_stream_pos(cookie));
|
|
}
|
|
|
|
#else /* SEXP_USE_STRING_STREAMS && ! SEXP_BSD */
|
|
|
|
sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) {
|
|
FILE *in;
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
if (sexp_string_length(str) == 0)
|
|
in = fopen("/dev/null", "r");
|
|
else
|
|
in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
|
|
if (in) {
|
|
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
|
|
if (sexp_string_length(str) == 0)
|
|
sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1);
|
|
sexp_port_cookie(res) = str; /* for gc preservation */
|
|
sexp_port_binaryp(res) = 0;
|
|
} else {
|
|
res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
|
|
sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
|
|
sexp_port_stream(res)
|
|
= open_memstream(&sexp_port_buf(res), &sexp_port_size(res));
|
|
sexp_port_binaryp(res) = 0;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
|
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, port);
|
|
fflush(sexp_port_stream(port));
|
|
return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port));
|
|
}
|
|
|
|
#endif
|
|
|
|
#else /* ! SEXP_USE_STRING_STREAMS */
|
|
|
|
#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)+1 >= 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, const char *str,
|
|
sexp_uint_t len, sexp p) {
|
|
int diff;
|
|
while (sexp_port_offset(p)+len >= sexp_port_size(p)) {
|
|
diff = sexp_port_size(p) - sexp_port_offset(p);
|
|
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, diff);
|
|
sexp_buffered_flush(ctx, p);
|
|
str += diff;
|
|
len -= diff;
|
|
}
|
|
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, const 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, NULL, SEXP_OPORT, p);
|
|
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_op (sexp ctx sexp_api_params(self, n), sexp str) {
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
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);
|
|
sexp_port_binaryp(res) = 0;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
|
|
sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
|
|
if (sexp_exceptionp(res)) return res;
|
|
sexp_port_buf(res) = (char*) sexp_malloc(SEXP_PORT_BUFFER_SIZE);
|
|
if (!sexp_port_buf(res)) {
|
|
res = sexp_global(ctx, SEXP_G_OOM_ERROR);
|
|
} else {
|
|
sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE;
|
|
sexp_port_offset(res) = 0;
|
|
sexp_port_cookie(res) = SEXP_NULL;
|
|
}
|
|
sexp_port_binaryp(res) = 0;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp out) {
|
|
sexp res;
|
|
sexp_gc_var2(ls, tmp);
|
|
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
|
|
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_FALSE);
|
|
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_flags(p) = SEXP_PORT_UNKNOWN_FLAGS;
|
|
sexp_port_buf(p) = NULL;
|
|
sexp_port_openp(p) = 1;
|
|
sexp_port_binaryp(p) = 1;
|
|
sexp_port_no_closep(p) = 0;
|
|
sexp_port_sourcep(p) = 0;
|
|
sexp_port_blockedp(p) = 0;
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
sexp_port_fold_casep(p) = sexp_truep(sexp_global(ctx, SEXP_G_FOLD_CASE_P));
|
|
#endif
|
|
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_port_binaryp_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
|
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
|
|
return sexp_make_boolean(sexp_port_binaryp(port));
|
|
}
|
|
|
|
sexp sexp_port_openp_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
|
sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
|
|
return sexp_make_boolean(sexp_port_openp(port));
|
|
}
|
|
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
sexp sexp_get_port_fold_case (sexp ctx sexp_api_params(self, n), sexp in) {
|
|
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
|
|
return sexp_make_boolean(sexp_port_fold_casep(in));
|
|
}
|
|
sexp sexp_set_port_fold_case (sexp ctx sexp_api_params(self, n), sexp in, sexp x) {
|
|
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
|
|
sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, x);
|
|
sexp_port_fold_casep(in) = sexp_truep(x);
|
|
return SEXP_VOID;
|
|
}
|
|
#endif
|
|
|
|
#define NUMBUF_LEN 32
|
|
|
|
sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
|
|
#if SEXP_USE_HUFF_SYMS
|
|
unsigned long res;
|
|
#endif
|
|
unsigned long len, c;
|
|
long i=0;
|
|
double f;
|
|
sexp x, *elts;
|
|
char *str=NULL, numbuf[NUMBUF_LEN];
|
|
|
|
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_one(ctx, sexp_car(obj), out);
|
|
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
|
|
sexp_write_char(ctx, ' ', out);
|
|
sexp_write_one(ctx, sexp_car(x), out);
|
|
}
|
|
if (! sexp_nullp(x)) {
|
|
sexp_write_string(ctx, " . ", out);
|
|
sexp_write_one(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_one(ctx, elts[0], out);
|
|
for (i=1; i<len; i++) {
|
|
sexp_write_char(ctx, ' ', out);
|
|
sexp_write_one(ctx, elts[i], out);
|
|
}
|
|
sexp_write_char(ctx, ')', out);
|
|
}
|
|
break;
|
|
#if ! SEXP_USE_IMMEDIATE_FLONUMS
|
|
case SEXP_FLONUM:
|
|
f = sexp_flonum_value(obj);
|
|
#if SEXP_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 = snprintf(numbuf, NUMBUF_LEN, "%.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);
|
|
x = sexp_bytecode_name(sexp_procedure_code(obj));
|
|
sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out);
|
|
sexp_write_string(ctx, ">", out);
|
|
break;
|
|
case SEXP_TYPE:
|
|
sexp_write_string(ctx, "#<type ", out);
|
|
sexp_display(ctx, sexp_type_name(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 '\a': sexp_write_string(ctx, "\\a", out); break;
|
|
case '\b': sexp_write_string(ctx, "\\b", 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:
|
|
if (str[0] < ' ' && str[0] >= 0) {
|
|
sexp_write_string(ctx, "\\x", out);
|
|
sexp_write_char(ctx, hex_digit(str[0]>>4), out);
|
|
sexp_write_char(ctx, hex_digit(str[0]&0x0F), out);
|
|
sexp_write_char(ctx, ';', out);
|
|
} else {
|
|
sexp_write_char(ctx, str[0], out);
|
|
}
|
|
}
|
|
}
|
|
sexp_write_char(ctx, '"', out);
|
|
break;
|
|
case SEXP_SYMBOL:
|
|
i = sexp_symbol_length(obj);
|
|
str = sexp_symbol_data(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 SEXP_USE_BIGNUMS
|
|
case SEXP_BIGNUM:
|
|
sexp_write_bignum(ctx, obj, out, 10);
|
|
break;
|
|
#endif
|
|
#if SEXP_USE_RATIOS
|
|
case SEXP_RATIO:
|
|
sexp_write(ctx, sexp_ratio_numerator(obj), out);
|
|
sexp_write_char(ctx, '/', out);
|
|
sexp_write(ctx, sexp_ratio_denominator(obj), out);
|
|
break;
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
case SEXP_COMPLEX:
|
|
sexp_write(ctx, sexp_complex_real(obj), out);
|
|
if (!sexp_negativep(sexp_complex_imag(obj)))
|
|
sexp_write_char(ctx, '+', out);
|
|
sexp_write(ctx, sexp_complex_imag(obj), out);
|
|
sexp_write_char(ctx, 'i', out);
|
|
break;
|
|
#endif
|
|
case SEXP_OPCODE:
|
|
sexp_write_string(ctx, "#<opcode ", out);
|
|
sexp_display(ctx, sexp_opcode_name(obj), out);
|
|
sexp_write_char(ctx, '>', out);
|
|
break;
|
|
#if SEXP_USE_BYTEVECTOR_LITERALS
|
|
case SEXP_BYTES:
|
|
sexp_write_string(ctx, "#u8(", out);
|
|
str = sexp_bytes_data(obj);
|
|
len = sexp_bytes_length(obj);
|
|
for (i=0; i<len; i++) {
|
|
if (i!=0) sexp_write_char(ctx, ' ', out);
|
|
sexp_write(ctx, sexp_make_fixnum(str[i]), out);
|
|
}
|
|
sexp_write_char(ctx, ')', out);
|
|
break;
|
|
#endif
|
|
default:
|
|
i = sexp_pointer_tag(obj);
|
|
if (i < 0 || i >= sexp_context_num_types(ctx)) {
|
|
sexp_write_string(ctx, "#<invalid type tag: ", out);
|
|
sexp_write(ctx, sexp_make_fixnum(i), out);
|
|
sexp_write_char(ctx, '>', out);
|
|
} else {
|
|
x = sexp_type_by_index(ctx, i);
|
|
if (sexp_type_print(x)) {
|
|
x = sexp_type_print(x)(ctx, NULL, 2, obj, NULL, out);
|
|
if (sexp_exceptionp(x)) return x;
|
|
} else {
|
|
sexp_write_string(ctx, "#<", out);
|
|
sexp_display(ctx, sexp_type_name(x), out);
|
|
sexp_write_char(ctx, '>', out);
|
|
}
|
|
}
|
|
break;
|
|
}
|
|
} else if (sexp_fixnump(obj)) {
|
|
snprintf(numbuf, NUMBUF_LEN, "%ld", (long)sexp_unbox_fixnum(obj));
|
|
sexp_write_string(ctx, numbuf, out);
|
|
#if SEXP_USE_IMMEDIATE_FLONUMS
|
|
} else if (sexp_flonump(obj)) {
|
|
f = sexp_flonum_value(obj);
|
|
#if SEXP_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 = snprintf(numbuf, NUMBUF_LEN, "%.8g", 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);
|
|
c = sexp_unbox_character(obj);
|
|
if (c >= 0x100) {
|
|
if (c >= 0x10000) {
|
|
sexp_write_char(ctx, hex_digit((c>>20)&0x0F), out);
|
|
sexp_write_char(ctx, hex_digit((c>>16)&0x0F), out);
|
|
}
|
|
sexp_write_char(ctx, hex_digit((c>>12)&0x0F), out);
|
|
sexp_write_char(ctx, hex_digit((c>>8)&0x0F), out);
|
|
}
|
|
sexp_write_char(ctx, hex_digit((c>>4)&0x0F), out);
|
|
sexp_write_char(ctx, hex_digit(c&0x0F), out);
|
|
}
|
|
} else if (sexp_symbolp(obj)) {
|
|
|
|
#if SEXP_USE_HUFF_SYMS
|
|
if (sexp_isymbolp(obj)) {
|
|
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);
|
|
sexp_write(ctx, sexp_make_fixnum(obj), out);
|
|
sexp_write_char(ctx, '>', out);
|
|
}
|
|
}
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) {
|
|
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
|
|
return sexp_write_one(ctx, obj, out);
|
|
}
|
|
|
|
sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out) {
|
|
sexp res=SEXP_VOID;
|
|
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, 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
|
|
res = sexp_write_one(ctx, obj, out);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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;
|
|
sexp_sint_t size=INIT_STRING_BUFFER_SIZE;
|
|
char initbuf[INIT_STRING_BUFFER_SIZE];
|
|
char *buf=initbuf, *tmp;
|
|
sexp res = SEXP_FALSE;
|
|
|
|
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 'a': c = '\a'; break;
|
|
case 'b': c = '\b'; break;
|
|
case 'n': c = '\n'; break;
|
|
case 'r': c = '\r'; break;
|
|
case 't': c = '\t'; break;
|
|
case 'x':
|
|
res = sexp_read_number(ctx, in, 16);
|
|
if (sexp_fixnump(res)) {
|
|
c = sexp_read_char(ctx, in);
|
|
if (c != ';') {
|
|
#if SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON
|
|
res = sexp_read_error(ctx, "missing ; in \\x escape", SEXP_NULL, in);
|
|
#else
|
|
sexp_push_char(ctx, c, in);
|
|
#endif
|
|
}
|
|
c = sexp_unbox_fixnum(res);
|
|
}
|
|
break;
|
|
#if SEXP_USE_ESCAPE_NEWLINE
|
|
default:
|
|
if (isspace(c)) while (isspace(c) && c!=EOF) c=sexp_read_char(ctx, in);
|
|
#endif
|
|
}
|
|
if (sexp_exceptionp(res)) break;
|
|
} else if (c == '\n') {
|
|
sexp_port_line(in)++;
|
|
} else 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*) sexp_malloc(size*2);
|
|
if (!tmp) {res = sexp_global(ctx, SEXP_G_OOM_ERROR); break;}
|
|
memcpy(tmp, buf, i);
|
|
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
|
|
buf = tmp;
|
|
size *= 2;
|
|
}
|
|
}
|
|
|
|
if (!sexp_exceptionp(res)) {
|
|
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=SEXP_VOID;
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
int foldp = sexp_port_fold_casep(in);
|
|
init = (foldp ? tolower(init) : init);
|
|
#endif
|
|
|
|
if (init != EOF)
|
|
buf[i++] = init;
|
|
|
|
for (c = sexp_read_char(ctx, in); ; c = sexp_read_char(ctx, in)) {
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
if (foldp) c = tolower(c);
|
|
#endif
|
|
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*) sexp_malloc(size*2);
|
|
if (!tmp) {res = sexp_global(ctx, SEXP_G_OOM_ERROR); break;}
|
|
memcpy(tmp, buf, i);
|
|
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
|
|
buf = tmp;
|
|
size *= 2;
|
|
}
|
|
}
|
|
|
|
if (!sexp_exceptionp(res)) {
|
|
buf[i] = '\0';
|
|
res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i));
|
|
}
|
|
if (size != INIT_STRING_BUFFER_SIZE) free(buf);
|
|
return res;
|
|
}
|
|
|
|
#if SEXP_USE_COMPLEX
|
|
sexp sexp_make_complex (sexp ctx, sexp real, sexp image) {
|
|
sexp res = sexp_alloc_type(ctx, complex, SEXP_COMPLEX);
|
|
sexp_complex_real(res) = real;
|
|
sexp_complex_imag(res) = image;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_complex_normalize (sexp cpx) {
|
|
return sexp_complexp(cpx)
|
|
&& (sexp_complex_imag(cpx) == SEXP_ZERO
|
|
|| (sexp_flonump(sexp_complex_imag(cpx))
|
|
&& sexp_flonum_value(sexp_complex_imag(cpx)) == 0.0))
|
|
? sexp_complex_real(cpx) : cpx;
|
|
}
|
|
|
|
sexp sexp_read_complex_tail (sexp ctx, sexp in, double real, int exactp) {
|
|
int c = sexp_read_char(ctx, in), c2;
|
|
sexp_gc_var1(res);
|
|
sexp_gc_preserve1(ctx, res);
|
|
if (c=='i' || c=='I') {
|
|
trailing_i:
|
|
c = sexp_read_char(ctx, in);
|
|
if ((c!=EOF) && ! is_separator(c))
|
|
res = sexp_read_error(ctx, "invalid complex numeric syntax", sexp_make_character(c), in);
|
|
else
|
|
sexp_push_char(ctx, c, in);
|
|
if (!sexp_exceptionp(res)) {
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO);
|
|
sexp_complex_imag(res) = exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real);
|
|
}
|
|
} else {
|
|
c2 = sexp_read_char(ctx, in);
|
|
if (c2=='i' || c2=='I') {
|
|
real = 1.0;
|
|
exactp = 1;
|
|
goto trailing_i;
|
|
} else {
|
|
sexp_push_char(ctx, c2, in);
|
|
}
|
|
if (c=='-') sexp_push_char(ctx, c, in);
|
|
res = sexp_read_number(ctx, in, 10);
|
|
if (sexp_complexp(res)) {
|
|
if (sexp_complex_real(res) == SEXP_ZERO)
|
|
sexp_complex_real(res) = (exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real));
|
|
else
|
|
res = sexp_read_error(ctx, "multiple real parts of complex", res, in);
|
|
} else if ((res == SEXP_ZERO)
|
|
|| (sexp_flonump(res) && sexp_flonum_value(res) == 0.0)) {
|
|
res = sexp_make_complex(ctx, (exactp ? sexp_make_fixnum(real) : sexp_make_flonum(ctx, real)), res);
|
|
} else {
|
|
res = sexp_exceptionp(res) ? res
|
|
: sexp_read_error(ctx, "missing imaginary part of complex", res, in);
|
|
}
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
return sexp_complex_normalize(res);
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_read_float_tail (sexp ctx, sexp in, double whole, int negp) {
|
|
sexp exponent=SEXP_VOID;
|
|
double val=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)
|
|
val += digit_value(c)*scale;
|
|
#if SEXP_USE_PLACEHOLDER_DIGITS
|
|
for (; c==SEXP_PLACEHOLDER_DIGIT; c=sexp_read_char(ctx, in), scale*=0.1)
|
|
val += sexp_placeholder_digit_value(10)*scale;
|
|
#endif
|
|
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);
|
|
}
|
|
val = (whole + val) * pow(10, e);
|
|
if (negp) val *= -1;
|
|
if (!(c=='e' || c=='E')) {
|
|
#if SEXP_USE_COMPLEX
|
|
if (c=='i' || c=='i' || c=='+' || c=='-') {
|
|
sexp_push_char(ctx, c, in);
|
|
return sexp_read_complex_tail(ctx, in, val, 0);
|
|
} else
|
|
#endif
|
|
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);
|
|
}
|
|
#if SEXP_USE_FLONUMS
|
|
return sexp_make_flonum(ctx, val);
|
|
#else
|
|
return sexp_make_fixnum((sexp_uint_t)val);
|
|
#endif
|
|
}
|
|
|
|
#if SEXP_USE_RATIOS
|
|
sexp sexp_make_ratio (sexp ctx, sexp num, sexp den) {
|
|
sexp res = sexp_alloc_type(ctx, ratio, SEXP_RATIO);
|
|
sexp_ratio_numerator(res) = num;
|
|
sexp_ratio_denominator(res) = den;
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
|
|
sexp tmp;
|
|
sexp_gc_var2(num, den);
|
|
num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
|
|
if (den == SEXP_ZERO)
|
|
return sexp_read_error(ctx, "zero denominator in ratio", rat, in);
|
|
else if (num == SEXP_ZERO)
|
|
return SEXP_ZERO;
|
|
sexp_gc_preserve2(ctx, num, den);
|
|
while (den != SEXP_ZERO) {
|
|
tmp = sexp_remainder(ctx, num, den);
|
|
if (sexp_exceptionp(tmp)) {
|
|
sexp_gc_release2(ctx);
|
|
return tmp;
|
|
}
|
|
num = den, den = tmp;
|
|
}
|
|
sexp_ratio_denominator(rat)
|
|
= den = sexp_quotient(ctx, sexp_ratio_denominator(rat), num);
|
|
sexp_ratio_numerator(rat)
|
|
= sexp_quotient(ctx, sexp_ratio_numerator(rat), num);
|
|
if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
|
|
sexp_negate(sexp_ratio_numerator(rat));
|
|
sexp_negate(sexp_ratio_denominator(rat));
|
|
}
|
|
sexp_gc_release2(ctx);
|
|
return (sexp_ratio_denominator(rat) == SEXP_ONE) ? sexp_ratio_numerator(rat)
|
|
: rat;
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_read_number (sexp ctx, sexp in, int base) {
|
|
sexp_sint_t val = 0, tmp = -1;
|
|
int c, digit, negativep = 0;
|
|
#if SEXP_USE_PLACEHOLDER_DIGITS
|
|
double whole = 0.0, scale = 0.1;
|
|
#endif
|
|
sexp_gc_var2(res, den);
|
|
|
|
c = sexp_read_char(ctx, in);
|
|
if (c == '-') {
|
|
negativep = 1;
|
|
c = sexp_read_char(ctx, in);
|
|
}
|
|
|
|
#if SEXP_USE_COMPLEX
|
|
if (c == 'i' || c == 'I') whole = 1.0;
|
|
#endif
|
|
|
|
for ( ; sexp_isxdigit(c); c=sexp_read_char(ctx, in)) {
|
|
digit = digit_value(c);
|
|
if ((digit < 0) || (digit >= base))
|
|
break;
|
|
tmp = val * base + digit;
|
|
#if SEXP_USE_BIGNUMS
|
|
if ((tmp < val) || (tmp > SEXP_MAX_FIXNUM)) {
|
|
sexp_push_char(ctx, c, in);
|
|
return sexp_read_bignum(ctx, in, val, (negativep ? -1 : 1), base);
|
|
}
|
|
#endif
|
|
val = tmp;
|
|
}
|
|
|
|
#if SEXP_USE_PLACEHOLDER_DIGITS
|
|
if (sexp_placeholder_digit_p(c) && tmp >= 0) {
|
|
whole = val;
|
|
for ( ; sexp_placeholder_digit_p(c); c=sexp_read_char(ctx, in))
|
|
whole = whole*10 + sexp_placeholder_digit_value(base);
|
|
if ((c=='.' || c=='e' || c=='E') && (base != 10))
|
|
return sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
|
|
if (c=='.')
|
|
for (c=sexp_read_char(ctx, in); sexp_placeholder_digit_p(c);
|
|
c=sexp_read_char(ctx, in), scale*=0.1)
|
|
whole += sexp_placeholder_digit_value(10)*scale;
|
|
if (c=='e' || c=='E') {
|
|
sexp_push_char(ctx, c, in);
|
|
return sexp_read_float_tail(ctx, in, whole, negativep);
|
|
} else if ((c!=EOF) && !is_separator(c)) {
|
|
return sexp_read_error(ctx, "invalid numeric syntax after placeholders",
|
|
sexp_make_character(c), in);
|
|
}
|
|
sexp_push_char(ctx, c, in);
|
|
return sexp_make_flonum(ctx, (negativep ? -whole : whole));
|
|
}
|
|
#endif
|
|
|
|
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, val, negativep);
|
|
} else if (c=='/') {
|
|
sexp_gc_preserve2(ctx, res, den);
|
|
den = sexp_read_number(ctx, in, base);
|
|
if (! (sexp_fixnump(den) || sexp_bignump(den)))
|
|
return (sexp_exceptionp(den)
|
|
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
|
|
#if SEXP_USE_RATIOS
|
|
res = sexp_make_ratio(ctx, sexp_make_fixnum(negativep ? -val : val), den);
|
|
res = sexp_ratio_normalize(ctx, res, in);
|
|
#else
|
|
res = sexp_make_flonum(ctx, (double)(negativep ? -val : val)
|
|
/ (double)sexp_unbox_fixnum(den));
|
|
#endif
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
#if SEXP_USE_COMPLEX
|
|
} else if (c=='i' || c=='I' || c=='+' || c=='-') {
|
|
if (base != 10)
|
|
return sexp_read_error(ctx, "found non-base 10 complex", SEXP_NULL, in);
|
|
sexp_push_char(ctx, c, in);
|
|
return sexp_read_complex_tail(ctx, in, (negativep ? -val : val), 1);
|
|
#endif
|
|
} else {
|
|
if ((c!=EOF) && ! is_separator(c))
|
|
return sexp_read_error(ctx, "invalid numeric syntax",
|
|
sexp_make_character(c), in);
|
|
else if (tmp < 0)
|
|
return sexp_read_error(ctx, "digitless numeric literal", SEXP_NULL, in);
|
|
sexp_push_char(ctx, c, in);
|
|
}
|
|
|
|
return sexp_make_fixnum(negativep ? -val : val);
|
|
}
|
|
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
static int sexp_decode_utf8_char(const unsigned char* s) {
|
|
int i = s[0], len = strlen((const char*)s);
|
|
if ((i >= 0xC0) && (i <= 0xF7) && (s[1]>>6 == 2)) {
|
|
if ((i < 0xE0) && (len == 2)) {
|
|
return ((i&0x3F)<<6) + (s[1]&0x3F);
|
|
} else if ((i < 0xF0) && (len == 3) && (s[2]>>6 == 2)) {
|
|
return ((i&0x1F)<<12) + ((s[1]&0x3F)<<6) + (s[2]&0x3F);
|
|
} else if ((len == 4) && (s[2]>>6 == 2) && (s[3]>>6 == 2)) {
|
|
return ((i&0x0F)<<16) + ((s[1]&0x3F)<<6) + ((s[2]&0x3F)<<6) + (s[3]&0x3F);
|
|
}
|
|
}
|
|
return -1;
|
|
}
|
|
#endif
|
|
|
|
#if SEXP_USE_GREEN_THREADS
|
|
int sexp_maybe_block_port (sexp ctx, sexp in, int forcep) {
|
|
sexp f;
|
|
int c;
|
|
if (sexp_port_stream(in) && sexp_port_fileno(in) >= 0) {
|
|
if (sexp_port_flags(in) == SEXP_PORT_UNKNOWN_FLAGS)
|
|
sexp_port_flags(in) = fcntl(sexp_port_fileno(in), F_GETFL);
|
|
if (sexp_port_flags(in) & O_NONBLOCK) {
|
|
errno = 0;
|
|
if (!forcep
|
|
&& (((c = sexp_read_char(ctx, in)) == EOF)
|
|
&& (errno == EAGAIN)
|
|
&& sexp_opcodep((f=sexp_global(ctx, SEXP_G_THREADS_BLOCKER))))) {
|
|
((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), in);
|
|
return 1;
|
|
} else {
|
|
if (!forcep) sexp_push_char(ctx, c, in);
|
|
sexp_port_blockedp(in) = 1;
|
|
fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in) & ~O_NONBLOCK);
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
void sexp_maybe_unblock_port (sexp ctx, sexp in) {
|
|
if (sexp_port_blockedp(in)) {
|
|
sexp_port_blockedp(in) = 0;
|
|
fcntl(sexp_port_fileno(in), F_SETFL, sexp_port_flags(in));
|
|
}
|
|
}
|
|
#endif
|
|
|
|
sexp sexp_read_raw (sexp ctx, sexp in) {
|
|
char *str;
|
|
int c1, c2, line;
|
|
sexp tmp2;
|
|
sexp_gc_var2(res, tmp);
|
|
sexp_check_block_port(ctx, in, 0);
|
|
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);
|
|
if (sexp_port_sourcep(in) && (line >= 0))
|
|
sexp_pair_source(res)
|
|
= sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line));
|
|
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 ')' started on line",
|
|
sexp_make_fixnum(line), in);
|
|
}
|
|
}
|
|
if ((line >= 0) && sexp_pairp(res)) {
|
|
sexp_pair_source(res)
|
|
= sexp_cons(ctx, sexp_port_name(in), sexp_make_fixnum(line));
|
|
for (tmp=sexp_cdr(res); sexp_pairp(tmp); tmp=sexp_cdr(tmp))
|
|
sexp_pair_source(tmp) = sexp_pair_source(res);
|
|
}
|
|
if (sexp_port_sourcep(in))
|
|
for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp))
|
|
sexp_immutablep(tmp) = 1;
|
|
break;
|
|
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
|
case '{':
|
|
res = sexp_read_symbol(ctx, in, EOF, 0);
|
|
if (!sexp_exceptionp(res)) {
|
|
for (c1=' '; isspace(c1); c1=sexp_read_char(ctx, in))
|
|
;
|
|
if (c1=='#') {
|
|
tmp = sexp_read(ctx, in);
|
|
if (sexp_symbolp(tmp) && tmp == sexp_intern(ctx, "t", 1))
|
|
tmp = SEXP_TRUE;
|
|
else if (!sexp_fixnump(tmp))
|
|
tmp = sexp_read_error(ctx, "invalid type identifier", tmp, in);
|
|
} else if (c1=='"') {
|
|
tmp = sexp_read_string(ctx, in);
|
|
} else {
|
|
tmp = sexp_read_error(ctx, "brace literal missing type identifier", sexp_make_character(c1), in);
|
|
}
|
|
if (!sexp_exceptionp(tmp)) tmp = sexp_lookup_type(ctx, res, tmp);
|
|
if (tmp && sexp_typep(tmp) && sexp_type_print(tmp) == sexp_write_simple_object) {
|
|
res = sexp_alloc_tagged(ctx, sexp_type_size_base(tmp), sexp_type_tag(tmp));
|
|
for (c1=0; ; c1++) {
|
|
tmp2 = sexp_read_raw(ctx, in);
|
|
if (sexp_exceptionp(tmp2)) {
|
|
res = tmp2;
|
|
break;
|
|
} else if (tmp2 == SEXP_CLOSE_BRACE) {
|
|
break;
|
|
} else if (c1 >= sexp_type_field_len_base(tmp)) {
|
|
res = sexp_read_error(ctx, "too many slots in object literal", res, in);
|
|
break;
|
|
} else {
|
|
sexp_slot_set(res, c1, tmp2);
|
|
}
|
|
}
|
|
} else {
|
|
res = sexp_exceptionp(tmp) ? tmp : sexp_read_error(ctx, "invalid type for brace literals", tmp, in);
|
|
}
|
|
}
|
|
break;
|
|
#endif
|
|
case '#':
|
|
switch (c1=sexp_read_char(ctx, in)) {
|
|
case 'b': case 'B':
|
|
res = sexp_read_number(ctx, in, 2); break;
|
|
case 'o': case 'O':
|
|
res = sexp_read_number(ctx, in, 8); break;
|
|
case 'd': case 'D':
|
|
res = sexp_read_number(ctx, in, 10); break;
|
|
case 'x': case 'X':
|
|
res = sexp_read_number(ctx, in, 16); break;
|
|
case 'e': case 'E':
|
|
res = sexp_read(ctx, in);
|
|
if (sexp_flonump(res))
|
|
#if SEXP_USE_RATIOS
|
|
res = sexp_double_to_ratio(ctx, sexp_flonum_value(res));
|
|
#else
|
|
res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(res)));
|
|
#endif
|
|
break;
|
|
case 'i': case 'I':
|
|
res = sexp_read(ctx, in);
|
|
if (sexp_exact_integerp(res))
|
|
res = sexp_make_flonum(ctx, sexp_unbox_fixnum(res));
|
|
#if SEXP_USE_RATIOS
|
|
else if (sexp_ratiop(res))
|
|
res = sexp_make_flonum(ctx, sexp_ratio_to_double(res));
|
|
#endif
|
|
break;
|
|
case 'f': case 'F':
|
|
case 't': case 'T':
|
|
c2 = sexp_read_char(ctx, in);
|
|
if (c2 == EOF || is_separator(c2)) {
|
|
res = (tolower(c1) == 't' ? SEXP_TRUE : SEXP_FALSE);
|
|
sexp_push_char(ctx, c2, in);
|
|
} else {
|
|
sexp_push_char(ctx, c2, in);
|
|
res = sexp_read_symbol(ctx, in, c1, 0);
|
|
if (!sexp_exceptionp(res)) {
|
|
if (strcasecmp("true", sexp_string_data(res)) == 0)
|
|
res = SEXP_TRUE;
|
|
else if (strcasecmp("false", sexp_string_data(res)) == 0)
|
|
res = SEXP_FALSE;
|
|
else
|
|
res = sexp_read_error(ctx, "invalid # syntax", res, in);
|
|
}
|
|
}
|
|
break;
|
|
#if SEXP_USE_BYTEVECTOR_LITERALS
|
|
case 'v': case 'V':
|
|
c1 = sexp_read_char(ctx, in);
|
|
if (!(c1=='u'||c1=='U')) {
|
|
res = sexp_read_error(ctx, "invalid syntax #v%c", sexp_make_character(c1), in);
|
|
break;
|
|
}
|
|
/* ... FALLTHROUGH ... */
|
|
case 'u': case 'U':
|
|
if ((c1 = sexp_read_char(ctx, in)) == '8') {
|
|
tmp = sexp_read(ctx, in);
|
|
if (!sexp_listp(ctx, tmp)) {
|
|
res = sexp_exceptionp(tmp) ? tmp
|
|
: sexp_read_error(ctx, "invalid syntax object after #u8", tmp, in);
|
|
} else {
|
|
res = sexp_make_bytes(ctx, sexp_length(ctx, tmp), SEXP_VOID);
|
|
for (c1=0; sexp_pairp(tmp); tmp=sexp_cdr(tmp), c1++) {
|
|
tmp2 = sexp_car(tmp);
|
|
if (!(sexp_fixnump(tmp2) && sexp_unbox_fixnum(tmp2) >= 0
|
|
&& sexp_unbox_fixnum(tmp2) < 0x100)) {
|
|
res = sexp_read_error(ctx, "invalid bytevector value", tmp2, in);
|
|
break;
|
|
} else {
|
|
sexp_bytes_set(res, sexp_make_fixnum(c1), tmp2);
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
tmp = sexp_list2(ctx, sexp_make_character('u'), sexp_make_character(c1));
|
|
res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in);
|
|
}
|
|
break;
|
|
#endif
|
|
/* 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 '|':
|
|
for (c2 = 1; c2 > 0 && c1 != EOF; ) {
|
|
c1 = sexp_read_char(ctx, in);
|
|
if (c1 == '#') {
|
|
while ((c1 = sexp_read_char(ctx, in)) == '#')
|
|
;
|
|
if (c1 == '|') c2++;
|
|
} else if (c1 == '|') {
|
|
while ((c1 = sexp_read_char(ctx, in)) == '|')
|
|
;
|
|
if (c1 == '#') c2--;
|
|
}
|
|
}
|
|
if (c1 == EOF)
|
|
res = sexp_read_error(ctx, "unterminated #| comment", SEXP_NULL, in);
|
|
else
|
|
goto scan_loop;
|
|
break;
|
|
case '!':
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
res = sexp_read_symbol(ctx, in, '!', 0);
|
|
if (sexp_stringp(res)
|
|
&& strcmp("!fold-case", sexp_string_data(res)) == 0) {
|
|
sexp_port_fold_casep(in) = 1;
|
|
} else if (sexp_stringp(res)
|
|
&& strcmp("!no-fold-case", sexp_string_data(res)) == 0) {
|
|
sexp_port_fold_casep(in) = 0;
|
|
} else {
|
|
#endif
|
|
while ((c1 = sexp_read_char(ctx, in)) != EOF)
|
|
if (c1 == '\n')
|
|
break;
|
|
sexp_port_line(in)++;
|
|
#if SEXP_USE_FOLD_CASE_SYMS
|
|
}
|
|
#endif
|
|
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') &&
|
|
sexp_isxdigit(str[1])
|
|
&& sexp_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');
|
|
#if SEXP_USE_UTF8_STRINGS
|
|
else if ((c1=sexp_decode_utf8_char((unsigned char*)str)) > 0)
|
|
res = sexp_make_character(c1);
|
|
#endif
|
|
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);
|
|
sexp_push_char(ctx, c1, in);
|
|
if (c1 == EOF || is_separator(c1)) {
|
|
res = SEXP_RAWDOT;
|
|
} else if (isdigit(c1)) {
|
|
res = sexp_read_float_tail(ctx, in, 0, 0);
|
|
} else {
|
|
res = sexp_read_symbol(ctx, in, '.', 1);
|
|
}
|
|
break;
|
|
case ')':
|
|
res = SEXP_CLOSE;
|
|
break;
|
|
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
|
case '}':
|
|
res = SEXP_CLOSE_BRACE;
|
|
break;
|
|
#endif
|
|
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 SEXP_USE_FLONUMS
|
|
if (sexp_flonump(res))
|
|
#if SEXP_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 SEXP_USE_BIGNUMS
|
|
if (sexp_bignump(res)) {
|
|
if ((sexp_bignum_hi(res) == 1)
|
|
&& (sexp_bignum_data(res)[0] == (SEXP_MAX_FIXNUM+1)))
|
|
res = sexp_make_fixnum(-sexp_bignum_data(res)[0]);
|
|
else
|
|
sexp_bignum_sign(res) = -sexp_bignum_sign(res);
|
|
} else
|
|
#endif
|
|
#if SEXP_USE_RATIOS
|
|
if (sexp_ratiop(res)) {
|
|
sexp_negate(sexp_ratio_numerator(res));
|
|
} else
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
if (sexp_complexp(res)) {
|
|
sexp_negate(sexp_complex_real(res));
|
|
} else
|
|
#endif
|
|
res = sexp_fx_mul(res, SEXP_NEG_ONE);
|
|
}
|
|
} else {
|
|
sexp_push_char(ctx, c2, in);
|
|
res = sexp_read_symbol(ctx, in, c1, !SEXP_USE_INFINITIES);
|
|
#if SEXP_USE_INFINITIES
|
|
if (sexp_stringp(res)) {
|
|
str = sexp_string_data(res);
|
|
if (strcasecmp(str, "+inf.0") == 0)
|
|
res = sexp_make_flonum(ctx, sexp_pos_infinity);
|
|
else if (strcasecmp(str, "-inf.0") == 0)
|
|
res = sexp_make_flonum(ctx, sexp_neg_infinity);
|
|
else if (strcasecmp(str, "+nan.0") == 0)
|
|
res = sexp_make_flonum(ctx, sexp_nan);
|
|
else
|
|
res = sexp_intern(ctx, str, sexp_string_length(res));
|
|
}
|
|
#endif
|
|
#if SEXP_USE_COMPLEX
|
|
if (res == sexp_intern(ctx, "+i", -1))
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE);
|
|
else if (res == sexp_intern(ctx, "-i", -1))
|
|
res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_NEG_ONE);
|
|
#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_maybe_unblock_port(ctx, in);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_read_op (sexp ctx sexp_api_params(self, n), sexp in) {
|
|
sexp res;
|
|
sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in);
|
|
res = sexp_read_raw(ctx, in);
|
|
if (res == SEXP_CLOSE)
|
|
res = sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in);
|
|
#if SEXP_USE_OBJECT_BRACE_LITERALS
|
|
else if (res == SEXP_CLOSE_BRACE)
|
|
res = sexp_read_error(ctx, "too many '}'s", SEXP_NULL, in);
|
|
#endif
|
|
else if (res == SEXP_RAWDOT)
|
|
res = sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) {
|
|
sexp res;
|
|
sexp_gc_var2(s, in);
|
|
sexp_gc_preserve2(ctx, s, in);
|
|
s = sexp_c_string(ctx, str, len);
|
|
in = sexp_make_input_string_port(ctx, s);
|
|
res = sexp_read(ctx, in);
|
|
sexp_gc_release2(ctx);
|
|
return res;
|
|
}
|
|
|
|
sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b) {
|
|
int base;
|
|
sexp_gc_var1(in);
|
|
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
|
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b);
|
|
if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36))
|
|
return sexp_user_exception(ctx, self, "invalid numeric base", b);
|
|
if (sexp_string_data(str)[0]=='\0'
|
|
|| (sexp_string_data(str)[1]=='\0' && !isdigit(sexp_string_data(str)[0])))
|
|
return SEXP_FALSE;
|
|
sexp_gc_preserve1(ctx, in);
|
|
in = sexp_make_input_string_port(ctx, str);
|
|
if (sexp_string_data(str)[0] == '+') {
|
|
if (isdigit(sexp_string_data(str)[1])
|
|
|| sexp_string_data(str)[1] == '.' || sexp_string_data(str)[1] == '#')
|
|
sexp_read_char(ctx, in);
|
|
}
|
|
in = ((sexp_string_data(str)[0] == '#') || base == 10 ?
|
|
sexp_read(ctx, in) : sexp_read_number(ctx, in, base));
|
|
sexp_gc_release1(ctx);
|
|
return sexp_numberp(in) ? in : SEXP_FALSE;
|
|
}
|
|
|
|
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);
|
|
str = sexp_write(ctx, obj, out);
|
|
if (! sexp_exceptionp(str))
|
|
str = sexp_get_output_string(ctx, out);
|
|
sexp_gc_release1(ctx);
|
|
return str;
|
|
}
|
|
|
|
void sexp_init (void) {
|
|
#if SEXP_USE_GLOBAL_SYMBOLS
|
|
int i;
|
|
#endif
|
|
if (! sexp_initialized_p) {
|
|
sexp_initialized_p = 1;
|
|
#if SEXP_USE_BOEHM
|
|
GC_init();
|
|
#if SEXP_USE_GLOBAL_SYMBOLS
|
|
GC_add_roots((char*)&sexp_symbol_table,
|
|
((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1);
|
|
#endif
|
|
#elif ! SEXP_USE_MALLOC
|
|
sexp_gc_init();
|
|
#endif
|
|
#if SEXP_USE_GLOBAL_SYMBOLS
|
|
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
|
sexp_symbol_table[i] = SEXP_NULL;
|
|
#endif
|
|
}
|
|
}
|
|
|