diff --git a/TODO b/TODO index 790de726..8caf9b8e 100644 --- a/TODO +++ b/TODO @@ -26,7 +26,7 @@ **- only/except/rename modifiers **- scheme-complete.el support *= ffi -**- libdl interface +**+ libdl interface **- opcode generation interface **- stub generator *= cleanup diff --git a/config.scm b/config.scm index 8bd17f2f..ebf744db 100644 --- a/config.scm +++ b/config.scm @@ -131,6 +131,8 @@ open-input-string open-output-string get-output-string sc-macro-transformer rsc-macro-transformer er-macro-transformer identifier? identifier=? identifier->symbol make-syntactic-closure + register-simple-type make-constructor make-type-predicate + make-getter make-setter ))) (set! *modules* (list (cons '(scheme) (make-module exports diff --git a/debug.c b/debug.c index 74c4774e..31a351df 100644 --- a/debug.c +++ b/debug.c @@ -11,7 +11,8 @@ static const char* reverse_opcode_names[] = "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", - "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", + "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", @@ -47,6 +48,11 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; + case OP_SLOT_REF: + case OP_SLOT_SET: + case OP_MAKE: + ip += sizeof(sexp)*2; + break; case OP_GLOBAL_REF: case OP_GLOBAL_KNOWN_REF: case OP_TAIL_CALL: diff --git a/eval.c b/eval.c index 95fa12c8..6bb2c927 100644 --- a/eval.c +++ b/eval.c @@ -286,6 +286,14 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); + 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 ((! stack) || (stack == SEXP_FALSE)) { stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; @@ -300,15 +308,6 @@ sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; - 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_top(res) = 0; - sexp_context_tailp(res) = 1; - sexp_context_tracep(res) = 0; if (ctx) sexp_gc_release1(ctx); return res; } @@ -913,9 +912,16 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit_word(ctx, (sexp_uint_t)op); break; case OPC_TYPE_PREDICATE: + case OPC_ACCESSOR: + case OPC_CONSTRUCTOR: emit(ctx, sexp_opcode_code(op)); - if (sexp_opcode_data(op)) - emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); + if ((sexp_opcode_class(op) != OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == OP_MAKE) { + if (sexp_opcode_data(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); + if (sexp_opcode_data2(op)) + emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + } break; case OPC_PARAMETER: emit_push(ctx, sexp_opcode_data(op)); @@ -1181,6 +1187,9 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _WORD0 ((sexp*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] +#define _WORD1 ((sexp*)ip)[1] +#define _UWORD1 ((sexp_uint_t*)ip)[1] +#define _SWORD1 ((sexp_sint_t*)ip)[1] #define sexp_raise(msg, args) \ do {sexp_context_top(ctx) = top+1; \ @@ -1537,11 +1546,29 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case OP_TYPEP: - _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) - && (sexp_make_fixnum(sexp_pointer_tag(_ARG1)) - == _WORD0)); + _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0)); ip += sizeof(sexp); break; + case OP_MAKE: + _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0)); + ip += sizeof(sexp)*2; + break; + case OP_SLOT_REF: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); + ip += sizeof(sexp)*2; + break; + case OP_SLOT_SET: + if (! sexp_check_tag(_ARG1, _UWORD0)) + sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); + sexp_slot_set(_ARG1, _UWORD1, _ARG2); + _ARG2 = SEXP_VOID; + ip += sizeof(sexp)*2; + top--; + break; case OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); @@ -2196,6 +2223,86 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) { return res; } + +sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc0 func) { + sexp res; + if (! sexp_stringp(name)) + res = sexp_type_exception(ctx, "make-opcode: not a string", name); + else if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= OPC_NUM_OP_CLASSES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= OP_NUM_OPCODES)) + res = sexp_type_exception(ctx, "make-opcode: bad opcode", code); + else if (! sexp_fixnump(num_args)) + res = sexp_type_exception(ctx, "make-opcode: bad num_args", num_args); + else if (! sexp_fixnump(flags)) + res = sexp_type_exception(ctx, "make-opcode: bad flags", flags); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = sexp_unbox_fixnum(arg1t); + sexp_opcode_arg2_type(res) = sexp_unbox_fixnum(arg2t); + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) + = strndup(sexp_string_data(name), sexp_string_length(name)+1); + } + return res; +} + +#if USE_TYPE_DEFS + +sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-type-predicate: bad type", type); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_TYPE_PREDICATE), + sexp_make_fixnum(OP_TYPEP), sexp_make_fixnum(1), + sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), type, + NULL, NULL); +} + +sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) { + sexp_uint_t type_size; + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-constructor: bad type", type); + type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)])); + return sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_CONSTRUCTOR), + sexp_make_fixnum(OP_MAKE), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(0), sexp_make_fixnum(0), type, + sexp_make_fixnum(type_size), NULL); +} + +sexp sexp_make_accessor (sexp ctx, sexp name, sexp type, sexp index, sexp code) { + if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < SEXP_NUM_CORE_TYPES)) + return sexp_type_exception(ctx, "make-accessor: bad type", type); + if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) + return sexp_type_exception(ctx, "make-accessor: bad index", index); + return + sexp_make_opcode(ctx, name, sexp_make_fixnum(OPC_ACCESSOR), code, + sexp_make_fixnum(sexp_unbox_fixnum(code)==OP_SLOT_REF?1:2), + sexp_make_fixnum(0), type, sexp_make_fixnum(0), + sexp_make_fixnum(0), type, index, NULL); +} + +sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_REF)); +} +sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index) { + return sexp_make_accessor(ctx, name, type, index, sexp_make_fixnum(OP_SLOT_SET)); +} + +#endif + sexp sexp_make_env (sexp ctx) { sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_lambda(e) = NULL; @@ -2326,7 +2433,7 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp_gc_var1(thunk); sexp_gc_preserve1(ctx, thunk); ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); - sexp_context_parent(ctx2) = ctx; + /* sexp_context_parent(ctx2) = ctx; */ thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx2, thunk, diff --git a/gc.c b/gc.c index e9d5577e..f62a02c4 100644 --- a/gc.c +++ b/gc.c @@ -45,7 +45,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) { sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t res, *len_ptr; sexp t; - if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types)) return sexp_heap_align(1); t = &(sexp_type_specs[sexp_pointer_tag(x)]); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); diff --git a/include/chibi/config.h b/include/chibi/config.h index 7436a2c0..e539ebf3 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -8,6 +8,9 @@ /* uncomment this to disable dynamic loading */ /* #define USE_DL 0 */ +/* uncomment this to disable dynamic type definitions */ +/* #define USE_TYPE_DEFS 0 */ + /* uncomment this to use the Boehm conservative GC */ /* #define USE_BOEHM 1 */ @@ -70,6 +73,14 @@ #define USE_MODULES 1 #endif +#ifndef USE_TYPE_DEFS +#define USE_TYPE_DEFS 1 +#endif + +#ifndef SEXP_MAXIMUM_TYPES +#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1) +#endif + #ifndef USE_DL #ifdef PLAN9 #define USE_DL 0 diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 2bdd81ff..f069437a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -38,7 +38,8 @@ enum opcode_classes { OPC_CONSTRUCTOR, OPC_ACCESSOR, OPC_PARAMETER, - OPC_FOREIGN + OPC_FOREIGN, + OPC_NUM_OP_CLASSES }; enum opcode_names { @@ -82,6 +83,9 @@ enum opcode_names { OP_CHARP, OP_EOFP, OP_TYPEP, + OP_MAKE, + OP_SLOT_REF, + OP_SLOT_SET, OP_CAR, OP_CDR, OP_SET_CAR, @@ -130,6 +134,14 @@ SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); +SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0); + +#if USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type); +SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index); +#endif #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 001217a5..723e05a0 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -93,11 +93,16 @@ enum sexp_types { SEXP_LIT, SEXP_STACK, SEXP_CONTEXT, - SEXP_NUM_TYPES + SEXP_NUM_CORE_TYPES }; typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; +/* #if SEXP_64_BIT */ +/* typedef unsigned int sexp_tag_t; */ +/* #else */ +/* typedef unsigned short sexp_tag_t; */ +/* #endif */ typedef unsigned char sexp_tag_t; typedef struct sexp_struct *sexp; @@ -200,7 +205,7 @@ struct sexp_struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; char *name; - sexp data, proc; + sexp data, data2, proc; sexp_proc0 func; } opcode; struct { @@ -347,10 +352,14 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_gc_mark(x) ((x)->gc_mark) #define sexp_immutablep(x) ((x)->immutablep) -#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) -#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) +#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) +#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x))) +#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)]))) -#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) +#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) #if USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { @@ -495,6 +504,7 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) #define sexp_opcode_name(x) ((x)->value.opcode.name) #define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_data2(x) ((x)->value.opcode.data2) #define sexp_opcode_proc(x) ((x)->value.opcode.proc) #define sexp_opcode_func(x) ((x)->value.opcode.func) @@ -634,6 +644,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) +SEXP_API struct sexp_struct *sexp_type_specs; SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); @@ -674,5 +685,10 @@ SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); SEXP_API void sexp_init(void); +#if USE_TYPE_DEFS +SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); +SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); +#endif + #endif /* ! SEXP_H */ diff --git a/init.scm b/init.scm index 4e971d9f..14173846 100644 --- a/init.scm +++ b/init.scm @@ -431,7 +431,10 @@ (define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) -(define (digit-char n) (integer->char (+ n (char->integer #\0)))) +(define (digit-char n) + (if (<= n 9) + (integer->char (+ n (char->integer #\0))) + (integer->char (+ (- n 10) (char->integer #\A))))) (define (digit-value ch) (if (char-numeric? ch) (- (char->integer ch) (char->integer #\0)) diff --git a/main.c b/main.c index f6b448a2..961791c7 100644 --- a/main.c +++ b/main.c @@ -74,6 +74,7 @@ sexp sexp_init_environments (sexp ctx) { sexp_gc_var1(confenv); env = sexp_context_env(ctx); res = sexp_load_module_file(ctx, sexp_init_file, env); +#if USE_MODULES if (! sexp_exceptionp(res)) { res = SEXP_UNDEF; sexp_gc_preserve1(ctx, confenv); @@ -84,13 +85,14 @@ sexp sexp_init_environments (sexp ctx) { sexp_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv); sexp_gc_release1(ctx); } +#endif return res; } void repl (sexp ctx) { - sexp tmp, res, env, in, out, err; - sexp_gc_var1(obj); - sexp_gc_preserve1(ctx, obj); + sexp in, out, err; + sexp_gc_var4(obj, tmp, res, env); + sexp_gc_preserve4(ctx, obj, tmp, res, env); env = sexp_context_env(ctx); sexp_context_tracep(ctx) = 1; in = sexp_eval_string(ctx, "(current-input-port)", env); @@ -118,7 +120,7 @@ void repl (sexp ctx) { } } } - sexp_gc_release1(ctx); + sexp_gc_release4(ctx); } void run_main (int argc, char **argv) { diff --git a/opcodes.c b/opcodes.c index 55c859bd..191d6811 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,7 +1,7 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ - .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, f}}} + .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} #define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p) #define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) #define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) @@ -107,6 +107,9 @@ _PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), _PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), _PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), #if USE_MATH _FN1(0, "exp", 0, sexp_exp), _FN1(0, "log", 0, sexp_log), @@ -123,9 +126,13 @@ _FN1(0, "floor", 0, sexp_floor), _FN1(0, "ceiling", 0, sexp_ceiling), _FN2(0, 0, "expt", 0, sexp_expt), #endif -_FN0("open-output-string", 0, sexp_make_output_string_port), -_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), -_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#if USE_TYPE_DEFS +_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate), +_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter), +_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter), +#endif #if USE_DEBUG _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif diff --git a/opt/bignum.c b/opt/bignum.c index 4ffafa1e..ed75b6bd 100644 --- a/opt/bignum.c +++ b/opt/bignum.c @@ -466,12 +466,11 @@ enum sexp_number_combs { SEXP_NUM_BIG_BIG }; -static int sexp_number_types[SEXP_NUM_TYPES] = - {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, }; +static int sexp_number_types[] = + {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0}; static int sexp_number_type (sexp a) { - return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)] + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&1111] : sexp_fixnump(a); } diff --git a/sexp.c b/sexp.c index 946a1319..2f4388cb 100644 --- a/sexp.c +++ b/sexp.c @@ -62,7 +62,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \ {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}} -static struct sexp_struct sexp_type_specs[] = { +static struct sexp_struct _sexp_type_specs[] = { _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"), _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"), _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"), @@ -84,7 +84,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), _DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), _DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), - _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), + _DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), _DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), _DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional"), _DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), @@ -94,9 +94,67 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack"), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; - #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 flb, sexp flo, sexp fls, + sexp sb, sexp so, sexp sc) { + 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) 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_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) = strndup(sexp_string_data(name), sexp_string_length(name)+1); + 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, sexp_make_fixnum(0), sexp_make_fixnum(0), + sexp_make_fixnum(type_size), sexp_make_fixnum(0), + sexp_make_fixnum(0)); +} + +#else +#define sexp_num_types SEXP_NUM_CORE_TYPES +#endif + #if ! USE_BOEHM #if ! USE_MALLOC @@ -877,8 +935,8 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { i = sexp_pointer_tag(obj); sexp_write_string(ctx, "#<", out); sexp_write_string(ctx, - (i < SEXP_NUM_TYPES) - ? sexp_type_name(&(sexp_type_specs[i])) : "invalid", + (i < sexp_num_types) + ? sexp_type_name_by_index(i) : "invalid", out); sexp_write_char(ctx, '>', out); break; diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 9e06318d..7b881b9d 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -229,6 +229,8 @@ (test "100" (number->string 256 16)) +(test "FF" (number->string 255 16)) + (test "177" (number->string 127 8)) (test "101" (number->string 5 2))