Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-10 22:47:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding support for runtime definition of new types

Browse source
This commit is contained in:
Alex Shinn 2009-11-10 21:50:59 +09:00
parent f9b50ba909
commit f53e4df208
14 changed files with 267 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
TODO
View file

@ -26,7 +26,7 @@
**- only/except/rename modifiers
**- scheme-complete.el support
*= ffi
**- libdl interface
**+ libdl interface
**- opcode generation interface
**- stub generator
*= cleanup

2
config.scm
View file

@ -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

8
debug.c
View file

@ -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:

137
eval.c
View file

@ -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,

2
gc.c
View file

@ -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));

11
include/chibi/config.h
View file

@ -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

14
include/chibi/eval.h
View file

@ -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 */

26
include/chibi/sexp.h
View file

@ -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 */

5
init.scm
View file

@ -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))

10
main.c
View file

@ -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) {

15
opcodes.c
View file

@ -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

7
opt/bignum.c
View file

@ -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);
}

68
sexp.c
View file

@ -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; i++)
memcpy(&(new[i]), &(sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
tmp = sexp_type_specs;
sexp_type_specs = new;
if (sexp_type_array_size > sexp_num_types) free(tmp);
sexp_type_array_size = len;
}
type = &(sexp_type_specs[sexp_num_types]);
sexp_pointer_tag(type) = SEXP_TYPE;
sexp_type_tag(type) = sexp_num_types++;
sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
sexp_type_field_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;

2
tests/r5rs-tests.scm
View file

@ -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))