adding support for runtime definition of new types

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

2
TODO
View file

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

View file

@ -131,6 +131,8 @@
open-input-string open-output-string get-output-string open-input-string open-output-string get-output-string
sc-macro-transformer rsc-macro-transformer er-macro-transformer sc-macro-transformer rsc-macro-transformer er-macro-transformer
identifier? identifier=? identifier->symbol make-syntactic-closure identifier? identifier=? identifier->symbol make-syntactic-closure
register-simple-type make-constructor make-type-predicate
make-getter make-setter
))) )))
(set! *modules* (set! *modules*
(list (cons '(scheme) (make-module exports (list (cons '(scheme) (make-module exports

View file

@ -11,7 +11,8 @@ static const char* reverse_opcode_names[] =
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND",
"NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "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", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",
"LT", "LE", "EQN", "EQ", "LT", "LE", "EQN", "EQ",
"EXACT->INEXACT", "INEXACT->EXACT", "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]); sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_SLOT_REF:
case OP_SLOT_SET:
case OP_MAKE:
ip += sizeof(sexp)*2;
break;
case OP_GLOBAL_REF: case OP_GLOBAL_REF:
case OP_GLOBAL_KNOWN_REF: case OP_GLOBAL_KNOWN_REF:
case OP_TAIL_CALL: 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); sexp_gc_var1(res);
if (ctx) sexp_gc_preserve1(ctx, res); if (ctx) sexp_gc_preserve1(ctx, res);
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); 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)) { if ((! stack) || (stack == SEXP_FALSE)) {
stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK);
sexp_stack_length(stack) = INIT_STACK_SIZE; 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_name(sexp_context_bc(res)) = SEXP_FALSE;
sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; 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); if (ctx) sexp_gc_release1(ctx);
return res; return res;
} }
@ -913,9 +912,16 @@ static void generate_opcode_app (sexp ctx, sexp app) {
emit_word(ctx, (sexp_uint_t)op); emit_word(ctx, (sexp_uint_t)op);
break; break;
case OPC_TYPE_PREDICATE: case OPC_TYPE_PREDICATE:
case OPC_ACCESSOR:
case OPC_CONSTRUCTOR:
emit(ctx, sexp_opcode_code(op)); emit(ctx, sexp_opcode_code(op));
if (sexp_opcode_data(op)) if ((sexp_opcode_class(op) != OPC_CONSTRUCTOR)
emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); || 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; break;
case OPC_PARAMETER: case OPC_PARAMETER:
emit_push(ctx, sexp_opcode_data(op)); 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 _WORD0 ((sexp*)ip)[0]
#define _UWORD0 ((sexp_uint_t*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0]
#define _SWORD0 ((sexp_sint_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) \ #define sexp_raise(msg, args) \
do {sexp_context_top(ctx) = top+1; \ do {sexp_context_top(ctx) = top+1; \
@ -1537,11 +1546,29 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case OP_CHARP: case OP_CHARP:
_ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
case OP_TYPEP: case OP_TYPEP:
_ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) _ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0));
&& (sexp_make_fixnum(sexp_pointer_tag(_ARG1))
== _WORD0));
ip += sizeof(sexp); ip += sizeof(sexp);
break; 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: case OP_CAR:
if (! sexp_pairp(_ARG1)) if (! sexp_pairp(_ARG1))
sexp_raise("car: not a pair", sexp_list1(ctx, _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; 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 sexp_make_env (sexp ctx) {
sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
sexp_env_lambda(e) = NULL; sexp_env_lambda(e) = NULL;
@ -2326,7 +2433,7 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
sexp_gc_var1(thunk); sexp_gc_var1(thunk);
sexp_gc_preserve1(ctx, thunk); sexp_gc_preserve1(ctx, thunk);
ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); 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); thunk = sexp_compile(ctx2, obj);
if (sexp_exceptionp(thunk)) { if (sexp_exceptionp(thunk)) {
sexp_print_exception(ctx2, 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 sexp_allocated_bytes (sexp x) {
sexp_uint_t res, *len_ptr; sexp_uint_t res, *len_ptr;
sexp t; 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); return sexp_heap_align(1);
t = &(sexp_type_specs[sexp_pointer_tag(x)]); t = &(sexp_type_specs[sexp_pointer_tag(x)]);
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));

View file

@ -8,6 +8,9 @@
/* uncomment this to disable dynamic loading */ /* uncomment this to disable dynamic loading */
/* #define USE_DL 0 */ /* #define USE_DL 0 */
/* uncomment this to disable dynamic type definitions */
/* #define USE_TYPE_DEFS 0 */
/* uncomment this to use the Boehm conservative GC */ /* uncomment this to use the Boehm conservative GC */
/* #define USE_BOEHM 1 */ /* #define USE_BOEHM 1 */
@ -70,6 +73,14 @@
#define USE_MODULES 1 #define USE_MODULES 1
#endif #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 #ifndef USE_DL
#ifdef PLAN9 #ifdef PLAN9
#define USE_DL 0 #define USE_DL 0

View file

@ -38,7 +38,8 @@ enum opcode_classes {
OPC_CONSTRUCTOR, OPC_CONSTRUCTOR,
OPC_ACCESSOR, OPC_ACCESSOR,
OPC_PARAMETER, OPC_PARAMETER,
OPC_FOREIGN OPC_FOREIGN,
OPC_NUM_OP_CLASSES
}; };
enum opcode_names { enum opcode_names {
@ -82,6 +83,9 @@ enum opcode_names {
OP_CHARP, OP_CHARP,
OP_EOFP, OP_EOFP,
OP_TYPEP, OP_TYPEP,
OP_MAKE,
OP_SLOT_REF,
OP_SLOT_SET,
OP_CAR, OP_CAR,
OP_CDR, OP_CDR,
OP_SET_CAR, 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 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 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 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 */ #endif /* ! SEXP_EVAL_H */

View file

@ -93,11 +93,16 @@ enum sexp_types {
SEXP_LIT, SEXP_LIT,
SEXP_STACK, SEXP_STACK,
SEXP_CONTEXT, SEXP_CONTEXT,
SEXP_NUM_TYPES SEXP_NUM_CORE_TYPES
}; };
typedef unsigned long sexp_uint_t; typedef unsigned long sexp_uint_t;
typedef long sexp_sint_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 unsigned char sexp_tag_t;
typedef struct sexp_struct *sexp; typedef struct sexp_struct *sexp;
@ -200,7 +205,7 @@ struct sexp_struct {
unsigned char op_class, code, num_args, flags, unsigned char op_class, code, num_args, flags,
arg1_type, arg2_type, inverse; arg1_type, arg2_type, inverse;
char *name; char *name;
sexp data, proc; sexp data, data2, proc;
sexp_proc0 func; sexp_proc0 func;
} opcode; } opcode;
struct { 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_gc_mark(x) ((x)->gc_mark)
#define sexp_immutablep(x) ((x)->immutablep) #define sexp_immutablep(x) ((x)->immutablep)
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag])) #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_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 #if USE_IMMEDIATE_FLONUMS
union sexp_flonum_conv { 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_inverse(x) ((x)->value.opcode.inverse)
#define sexp_opcode_name(x) ((x)->value.opcode.name) #define sexp_opcode_name(x) ((x)->value.opcode.name)
#define sexp_opcode_data(x) ((x)->value.opcode.data) #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_proc(x) ((x)->value.opcode.proc)
#define sexp_opcode_func(x) ((x)->value.opcode.func) #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)) #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_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_cons(sexp ctx, sexp head, sexp tail);
SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); 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 sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
SEXP_API void sexp_init(void); 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 */ #endif /* ! SEXP_H */

View file

@ -431,7 +431,10 @@
(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) (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) (define (digit-value ch)
(if (char-numeric? ch) (if (char-numeric? ch)
(- (char->integer ch) (char->integer #\0)) (- (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); sexp_gc_var1(confenv);
env = sexp_context_env(ctx); env = sexp_context_env(ctx);
res = sexp_load_module_file(ctx, sexp_init_file, env); res = sexp_load_module_file(ctx, sexp_init_file, env);
#if USE_MODULES
if (! sexp_exceptionp(res)) { if (! sexp_exceptionp(res)) {
res = SEXP_UNDEF; res = SEXP_UNDEF;
sexp_gc_preserve1(ctx, confenv); 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_env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv);
sexp_gc_release1(ctx); sexp_gc_release1(ctx);
} }
#endif
return res; return res;
} }
void repl (sexp ctx) { void repl (sexp ctx) {
sexp tmp, res, env, in, out, err; sexp in, out, err;
sexp_gc_var1(obj); sexp_gc_var4(obj, tmp, res, env);
sexp_gc_preserve1(ctx, obj); sexp_gc_preserve4(ctx, obj, tmp, res, env);
env = sexp_context_env(ctx); env = sexp_context_env(ctx);
sexp_context_tracep(ctx) = 1; sexp_context_tracep(ctx) = 1;
in = sexp_eval_string(ctx, "(current-input-port)", env); 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) { void run_main (int argc, char **argv) {

View file

@ -1,7 +1,7 @@
#define _OP(c,o,n,m,t,u,i,s,d,f) \ #define _OP(c,o,n,m,t,u,i,s,d,f) \
{.tag=SEXP_OPCODE, \ {.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 _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 _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) #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-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), _PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE),
_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), _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 #if USE_MATH
_FN1(0, "exp", 0, sexp_exp), _FN1(0, "exp", 0, sexp_exp),
_FN1(0, "log", 0, sexp_log), _FN1(0, "log", 0, sexp_log),
@ -123,9 +126,13 @@ _FN1(0, "floor", 0, sexp_floor),
_FN1(0, "ceiling", 0, sexp_ceiling), _FN1(0, "ceiling", 0, sexp_ceiling),
_FN2(0, 0, "expt", 0, sexp_expt), _FN2(0, 0, "expt", 0, sexp_expt),
#endif #endif
_FN0("open-output-string", 0, sexp_make_output_string_port), #if USE_TYPE_DEFS
_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), _FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type),
_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), _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 #if USE_DEBUG
_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm),
#endif #endif

View file

@ -466,12 +466,11 @@ enum sexp_number_combs {
SEXP_NUM_BIG_BIG SEXP_NUM_BIG_BIG
}; };
static int sexp_number_types[SEXP_NUM_TYPES] = static int sexp_number_types[] =
{0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, {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, 0, };
static int sexp_number_type (sexp a) { 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); : 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) \ #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}}} {.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_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_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"),
_DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"), _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_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_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_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_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_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"), _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_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"), _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"),
}; };
#undef _DEF_TYPE #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_BOEHM
#if ! USE_MALLOC #if ! USE_MALLOC
@ -877,8 +935,8 @@ void sexp_write (sexp ctx, sexp obj, sexp out) {
i = sexp_pointer_tag(obj); i = sexp_pointer_tag(obj);
sexp_write_string(ctx, "#<", out); sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx, sexp_write_string(ctx,
(i < SEXP_NUM_TYPES) (i < sexp_num_types)
? sexp_type_name(&(sexp_type_specs[i])) : "invalid", ? sexp_type_name_by_index(i) : "invalid",
out); out);
sexp_write_char(ctx, '>', out); sexp_write_char(ctx, '>', out);
break; break;

View file

@ -229,6 +229,8 @@
(test "100" (number->string 256 16)) (test "100" (number->string 256 16))
(test "FF" (number->string 255 16))
(test "177" (number->string 127 8)) (test "177" (number->string 127 8))
(test "101" (number->string 5 2)) (test "101" (number->string 5 2))