Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 22:29:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding single inheritence for record types

Browse source
This commit is contained in:
Alex Shinn 2010-09-12 23:53:07 +09:00
parent 08d065f8a2
commit 755aa0effd
9 changed files with 192 additions and 143 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
include/chibi/sexp.h
View file

@ -206,7 +206,9 @@ struct sexp_type_struct {
short size_base, size_off;
unsigned short size_scale;
short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra;
short depth;
char *name;
sexp cpl, slots;
sexp_proc2 finalize;
};
@ -841,7 +843,10 @@ SEXP_API struct sexp_struct *sexp_type_specs;
#define sexp_type_weak_len_off(x) ((x)->value.type.weak_len_off)
#define sexp_type_weak_len_scale(x) ((x)->value.type.weak_len_scale)
#define sexp_type_weak_len_extra(x) ((x)->value.type.weak_len_extra)
#define sexp_type_depth(x) ((x)->value.type.depth)
#define sexp_type_name(x) ((x)->value.type.name)
#define sexp_type_cpl(x) ((x)->value.type.cpl)
#define sexp_type_slots(x) ((x)->value.type.slots)
#define sexp_type_finalize(x) ((x)->value.type.finalize)
#define sexp_bignum_sign(x) ((x)->value.bignum.sign)
@ -1027,13 +1032,14 @@ SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags);
#endif
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots);
SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp parent, sexp slots);
SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj);
#define sexp_register_c_type(ctx, name, finalizer) \
sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \
SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \
sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, \
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \
sexp_make_fixnum(sexp_sizeof(cpointer)), \
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer)
#endif
@ -1070,8 +1076,8 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj)
#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s)
#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out)
#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p) sexp_register_type_op(ctx sexp_api_pass(NULL, 15), a, b, c, d, e, f, g, h, i, j, k, l, m, o, p)
#define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 3), a, b, c)
#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r) sexp_register_type_op(ctx sexp_api_pass(NULL, 17), a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r)
#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c)

2
lib/chibi/weak.c
View file

@ -27,7 +27,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_gc_preserve3(ctx, name, t, op);
name = sexp_c_string(ctx, "Ephemeron", -1);
t = sexp_register_simple_type(ctx, name, SEXP_TWO);
t = sexp_register_simple_type(ctx, name, SEXP_FALSE, SEXP_TWO);
sexp_ephemeron_id = sexp_type_tag(t);
sexp_type_field_len_base(t) = 0;
sexp_type_weak_base(t) = sexp_type_field_base(t);

3
lib/srfi/18/threads.c
View file

@ -550,7 +550,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_mutex_id = sexp_lookup_type(ctx, env, "mutex");
sexp_condvar_id = sexp_lookup_type(ctx, env, "condition-variable");
name = sexp_c_string(ctx, "pollfds", -1);
t = sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
t = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE,
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
SEXP_ZERO, sexp_make_fixnum(sexp_sizeof_pollfds),
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
SEXP_ZERO, SEXP_ZERO, (sexp_proc2)sexp_free_pollfds);

3
lib/srfi/27/rand.c
View file

@ -172,7 +172,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_gc_preserve2(ctx, name, op);
name = sexp_c_string(ctx, "random-source", -1);
op = sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0),
op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE,
sexp_make_fixnum(sexp_offsetof_slot0),
ONE, ONE, ZERO, ZERO,
sexp_make_fixnum(sexp_sizeof_random),
ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, ZERO, NULL);

86
lib/srfi/9.module
View file

@ -2,89 +2,5 @@
(define-module (srfi 9)
(export define-record-type)
(import-immutable (scheme))
(body
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name (cadr expr))
(name-str (symbol->string (identifier->symbol name)))
(make (caaddr expr))
(make-fields (cdaddr expr))
(pred (cadddr expr))
(fields (cddddr expr))
(num-fields (length fields))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let))
(_register (rename 'register-simple-type)))
(define (index-of field ls)
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,num-fields))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred))
,name))
;; fields
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string
(identifier->symbol (cadar ls)))
,name
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string
(identifier->symbol (caddar ls)))
,name
,i))
res)
res)))))
;; constructor
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string (identifier->symbol make))
,name))
,@set-defs)
(,_lambda ,make-fields
(,_let ((res (%make)))
,@sets
res))))
(else
(let ((field (assq (car ls) fields)))
(cond
((not field)
(error "unknown record field in constructor" (car ls)))
((pair? (cddr field))
(lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets)
set-defs))
(else
(let* ((setter-name
(string-append "%" name-str "-"
(symbol->string (car ls)) "-set!"))
(setter (rename (string->symbol setter-name)))
(i (index-of (car ls) fields)))
(lp (cdr ls)
(cons (list setter 'res (car ls)) sets)
(cons (list setter
(list (rename 'make-setter)
setter-name
name
(index-of (car ls) fields)))
set-defs)))))))))))))))))
(include "9.scm"))

87
lib/srfi/9.scm Normal file
View file

@ -0,0 +1,87 @@
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr)))
(parent (and (pair? (cadr expr)) (cadadr expr)))
(name-str (symbol->string (identifier->symbol name)))
(make (caaddr expr))
(make-fields (cdaddr expr))
(pred (cadddr expr))
(fields (cddddr expr))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let))
(_register (rename 'register-simple-type)))
(define (index-of field ls)
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
(write `(name: ,name parent: ,parent)) (newline)
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,parent ',fields))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred))
,name))
;; fields
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string
(identifier->symbol (cadar ls)))
,name
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string
(identifier->symbol (caddar ls)))
,name
,i))
res)
res)))))
;; constructor
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string (identifier->symbol make))
,name))
,@set-defs)
(,_lambda ,make-fields
(,_let ((res (%make)))
,@sets
res))))
(else
(let ((field (assq (car ls) fields)))
(cond
((not field)
(error "unknown record field in constructor" (car ls)))
((pair? (cddr field))
(lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets)
set-defs))
(else
(let* ((setter-name
(string-append "%" name-str "-"
(symbol->string (car ls)) "-set!"))
(setter (rename (string->symbol setter-name)))
(i (index-of (car ls) fields)))
(lp (cdr ls)
(cons (list setter 'res (car ls)) sets)
(cons (list setter
(list (rename 'make-setter)
setter-name
name
(index-of (car ls) fields)))
set-defs))))))))))
(display "done\n"))))))

2
opcodes.c
View file

@ -154,7 +154,7 @@ _FN2(_I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string-ref", 0, sexp_stri
_FN3(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "string-set!", 0, sexp_string_utf8_index_set),
#endif
#if SEXP_USE_TYPE_DEFS
_FN2(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "register-simple-type", 0, sexp_register_simple_type_op),
_FN3(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_TYPE), SEXP_NULL, "register-simple-type", 0, sexp_register_simple_type_op),
_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op),
_FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op),
_FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op),

96
sexp.c
View file

@ -77,42 +77,42 @@ sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port) {
#endif
static struct sexp_type_struct _sexp_type_specs[] = {
{SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", NULL},
{SEXP_TYPE, 0, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, "type", NULL},
{SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", NULL},
{SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", NULL},
{SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", NULL},
{SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", NULL},
{SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, "pair", NULL},
{SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, "symbol", NULL},
{SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, "byte-vector", NULL},
{SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "object", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_TYPE, sexp_offsetof(type, cpl), 2, 2, 0, 0, sexp_sizeof(type), 0, 0, 0, 0, 0, 0, 0, 0, "type", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "integer", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_NUMBER, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "number", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "char", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "boolean", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_PAIR, sexp_offsetof(pair, car), 2, 3, 0, 0, sexp_sizeof(pair), 0, 0, 0, 0, 0, 0, 0, 0, "pair", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_SYMBOL, 0, 0, 0, 0, 0, sexp_sizeof(symbol)+1, sexp_offsetof(symbol, length), 1, 0, 0, 0, 0, 0, 0, "symbol", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_BYTES, 0, 0, 0, 0, 0, sexp_sizeof(bytes)+1, sexp_offsetof(bytes, length), 1, 0, 0, 0, 0, 0, 0, "byte-vector", SEXP_FALSE, SEXP_FALSE, NULL},
#if SEXP_USE_PACKED_STRINGS
{SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, "string", NULL},
{SEXP_STRING, 0, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, 0, 0, 0, 0, 0, 0, "string", SEXP_FALSE, SEXP_FALSE, NULL},
#else
{SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, "string", NULL},
{SEXP_STRING, sexp_offsetof(string, bytes), 1, 1, 0, 0, sexp_sizeof(string), 0, 0, 0, 0, 0, 0, 0, 0, "string", SEXP_FALSE, SEXP_FALSE, NULL},
#endif
{SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, "vector", NULL},
{SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, "real", NULL},
{SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, "bignum", NULL},
{SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, "cpointer", NULL},
{SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FINALIZE_PORT},
{SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FINALIZE_PORT},
{SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, "exception", NULL},
{SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, "procedure", NULL},
{SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, "macro", NULL},
{SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", NULL},
{SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, "environment", NULL},
{SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, "bytecode", NULL},
{SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, "core-form", NULL},
{SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, "opcode", NULL},
{SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, "lambda", NULL},
{SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, "conditional", NULL},
{SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, "reference", NULL},
{SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, "set!", NULL},
{SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, "sequence", NULL},
{SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, "literal", NULL},
{SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, "stack", NULL},
{SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, "context", NULL},
{SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "vector", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, 0, 0, 0, 0, 0, 0, "real", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp_uint_t), 0, 0, 0, 0, 0, 0, "bignum", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "input-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT},
{SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, "output-port", SEXP_FALSE, SEXP_FALSE, SEXP_FINALIZE_PORT},
{SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, "exception", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, "procedure", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_MACRO, sexp_offsetof(macro, proc), 2, 2, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, "macro", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 3, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, "syntactic-closure", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_ENV, sexp_offsetof(env, parent), 3, 3, 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, "environment", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, 0, 0, 0, 0, 0, 0, "bytecode", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, 0, 0, 0, 0, 0, 0, "core-form", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_OPCODE, sexp_offsetof(opcode, data), 7, 7, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, "opcode", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, "lambda", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, "conditional", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, "reference", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, 0, 0, 0, 0, 0, 0, "set!", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, "sequence", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, "literal", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, NULL},
{SEXP_CONTEXT, sexp_offsetof(context, bc), 12, 12, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, NULL},
};
#if SEXP_USE_GLOBAL_TYPES
@ -129,6 +129,7 @@ static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES;
#endif
sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp parent, sexp slots,
sexp fb, sexp felb, sexp flb, sexp flo, sexp fls,
sexp sb, sexp so, sexp sc, sexp w, sexp wb, sexp wo,
sexp ws, sexp we, sexp_proc2 f) {
@ -137,9 +138,10 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
#else
sexp *v1, *v2;
#endif
sexp res, type;
sexp_gc_var2(res, type);
sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
type_array_size=sexp_context_type_array_size(ctx);
sexp_gc_preserve2(ctx, res, type);
if (num_types >= SEXP_MAXIMUM_TYPES) {
res = sexp_user_exception(ctx, self, "register-type: exceeded maximum type limit", name);
} else if (! sexp_stringp(name)) {
@ -186,6 +188,21 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp_type_weak_len_extra(type) = sexp_unbox_fixnum(we);
sexp_type_name(type) = strdup(sexp_string_data(name));
sexp_type_finalize(type) = f;
if (sexp_typep(parent)) {
len = sexp_vectorp(sexp_type_cpl(parent)) ? sexp_vector_length(sexp_type_cpl(parent)) : 1;
sexp_type_cpl(type) = sexp_make_vector(ctx, sexp_make_fixnum(len+1), SEXP_VOID);
if (sexp_vectorp(sexp_type_cpl(parent)))
memcpy(sexp_vector_data(sexp_type_cpl(type)),
sexp_vector_data(sexp_type_cpl(parent)),
len * sizeof(sexp));
else
sexp_vector_data(sexp_type_cpl(type))[len-1] = parent;
} else {
len = 0;
sexp_type_cpl(type) = sexp_make_vector(ctx, SEXP_ONE, SEXP_VOID);
}
sexp_vector_data(sexp_type_cpl(type))[len] = type;
sexp_type_depth(type) = len;
res = type;
#if SEXP_USE_GLOBAL_TYPES
sexp_num_types = num_types + 1;
@ -193,14 +210,17 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1);
#endif
}
sexp_gc_release2(ctx);
return res;
}
sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp slots) {
short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots);
sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp parent, sexp slots) {
sexp num_slots = sexp_length(ctx, slots);
short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(num_slots);
return
sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0),
slots, slots, SEXP_ZERO, SEXP_ZERO,
sexp_register_type(ctx, name, parent, slots,
sexp_make_fixnum(sexp_offsetof_slot0),
num_slots, num_slots, SEXP_ZERO, SEXP_ZERO,
sexp_make_fixnum(type_size), SEXP_ZERO, SEXP_ZERO,
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO,
NULL);

36
vm.c
View file

@ -492,6 +492,21 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) {
goto call_error_handler;}} \
while (0)
static int sexp_check_type(sexp ctx, sexp a, sexp b) {
int d;
sexp t, v;
if (! sexp_pointerp(a))
return 0;
if (sexp_isa(a, b))
return 1;
t = sexp_object_type(ctx, a);
v = sexp_type_cpl(t);
d = sexp_type_depth(b);
return sexp_vectorp(v)
&& (d < sexp_vector_length(v))
&& sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
}
#if SEXP_USE_DEBUG_VM
#include "opt/opcode_names.h"
#endif
@ -907,10 +922,17 @@ sexp sexp_vm (sexp ctx, sexp proc) {
_ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
case SEXP_OP_CHARP:
_ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
case SEXP_OP_ISA:
tmp1 = _ARG1, tmp2 = _ARG2;
if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2);
top--;
goto do_check_type;
case SEXP_OP_TYPEP:
_ALIGN_IP();
_ARG1 = sexp_make_boolean(sexp_check_tag(_ARG1, _UWORD0));
tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0);
ip += sizeof(sexp);
do_check_type:
_ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2));
break;
case SEXP_OP_MAKE:
_ALIGN_IP();
@ -919,14 +941,14 @@ sexp sexp_vm (sexp ctx, sexp proc) {
break;
case SEXP_OP_SLOT_REF:
_ALIGN_IP();
if (! sexp_check_tag(_ARG1, _UWORD0))
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
_ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
ip += sizeof(sexp)*2;
break;
case SEXP_OP_SLOT_SET:
_ALIGN_IP();
if (! sexp_check_tag(_ARG1, _UWORD0))
if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
else if (sexp_immutablep(_ARG1))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
@ -935,14 +957,10 @@ sexp sexp_vm (sexp ctx, sexp proc) {
ip += sizeof(sexp)*2;
top--;
break;
case SEXP_OP_ISA:
_ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2));
top--;
break;
case SEXP_OP_SLOTN_REF:
if (! sexp_typep(_ARG1))
sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
else if (! sexp_isa(_ARG2, _ARG1))
else if (! sexp_check_type(ctx, _ARG2, _ARG1))
sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2));
else if (! sexp_fixnump(_ARG3))
sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3));
@ -952,7 +970,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
case SEXP_OP_SLOTN_SET:
if (! sexp_typep(_ARG1))
sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
else if (! sexp_isa(_ARG2, _ARG1))
else if (! sexp_check_type(ctx, _ARG2, _ARG1))
sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2));
else if (sexp_immutablep(_ARG2))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2));