mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-10 22:47:33 +02:00
adding support for runtime definition of new types
This commit is contained in:
parent
f9b50ba909
commit
f53e4df208
14 changed files with 267 additions and 42 deletions
2
TODO
2
TODO
|
@ -26,7 +26,7 @@
|
|||
**- only/except/rename modifiers
|
||||
**- scheme-complete.el support
|
||||
*= ffi
|
||||
**- libdl interface
|
||||
**+ libdl interface
|
||||
**- opcode generation interface
|
||||
**- stub generator
|
||||
*= cleanup
|
||||
|
|
|
@ -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
8
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:
|
||||
|
|
137
eval.c
137
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,
|
||||
|
|
2
gc.c
2
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));
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 */
|
||||
|
||||
|
|
|
@ -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
5
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))
|
||||
|
|
10
main.c
10
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) {
|
||||
|
|
15
opcodes.c
15
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
|
||||
|
|
|
@ -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
68
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; 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;
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Add table
Reference in a new issue