mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 14:07:34 +02:00
adding parent links to cpointers to prevent freeing shared structures
This commit is contained in:
Alex Shinn
parent
6bd1bd3687
commit
5d2f5912ce
7 changed files with 112 additions and 97 deletions
8
Makefile
8
Makefile
|
|
@ -52,8 +52,10 @@ endif
|
|||
|
||||
all: chibi-scheme$(EXE) libs
|
||||
|
||||
libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
|
||||
lib/chibi/net$(SO) lib/chibi/posix$(SO)
|
||||
COMPILED_LIBS := lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
|
||||
lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO)
|
||||
|
||||
libs: $(COMPILED_LIBS)
|
||||
|
||||
ifeq ($(USE_BOEHM),1)
|
||||
GCLDFLAGS := -lgc
|
||||
|
|
@ -106,7 +108,7 @@ clean:
|
|||
find lib -name \*.$(SO) -exec rm -f '{}' \;
|
||||
|
||||
cleaner: clean
|
||||
rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a
|
||||
rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a
|
||||
rm -rf *.dSYM
|
||||
|
||||
test-basic: chibi-scheme$(EXE)
|
||||
|
|
|
|||
31
eval.c
31
eval.c
|
|
@ -16,7 +16,6 @@ static int scheme_initialized_p = 0;
|
|||
#define sexp_disasm(...)
|
||||
#endif
|
||||
|
||||
static sexp analyze (sexp ctx, sexp x);
|
||||
static void generate (sexp ctx, sexp x);
|
||||
static sexp sexp_make_null_env (sexp ctx, sexp version);
|
||||
static sexp sexp_make_standard_env (sexp ctx, sexp version);
|
||||
|
|
@ -354,7 +353,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
|
|||
kar = sexp_strip_synclos(ctx, sexp_car(x));
|
||||
kdr = sexp_strip_synclos(ctx, sexp_cdr(x));
|
||||
res = sexp_cons(ctx, kar, kdr);
|
||||
sexp_immutablep(res) = sexp_immutablep(x);
|
||||
sexp_immutablep(res) = 1;
|
||||
} else {
|
||||
res = x;
|
||||
}
|
||||
|
|
@ -388,7 +387,7 @@ static sexp analyze_app (sexp ctx, sexp x) {
|
|||
sexp_gc_preserve2(ctx, res, tmp);
|
||||
for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
|
||||
sexp_push(ctx, res, SEXP_FALSE);
|
||||
tmp = analyze(ctx, sexp_car(x));
|
||||
tmp = sexp_analyze(ctx, sexp_car(x));
|
||||
if (sexp_exceptionp(tmp)) {
|
||||
res = tmp;
|
||||
break;
|
||||
|
|
@ -406,7 +405,7 @@ static sexp analyze_seq (sexp ctx, sexp ls) {
|
|||
if (sexp_nullp(ls))
|
||||
res = SEXP_VOID;
|
||||
else if (sexp_nullp(sexp_cdr(ls)))
|
||||
res = analyze(ctx, sexp_car(ls));
|
||||
res = sexp_analyze(ctx, sexp_car(ls));
|
||||
else {
|
||||
res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
|
||||
tmp = analyze_app(ctx, ls);
|
||||
|
|
@ -451,7 +450,7 @@ static sexp analyze_set (sexp ctx, sexp x) {
|
|||
ref = analyze_var_ref(ctx, sexp_cadr(x));
|
||||
if (sexp_lambdap(sexp_ref_loc(ref)))
|
||||
sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
|
||||
value = analyze(ctx, sexp_caddr(x));
|
||||
value = sexp_analyze(ctx, sexp_caddr(x));
|
||||
if (sexp_exceptionp(ref))
|
||||
res = ref;
|
||||
else if (sexp_exceptionp(value))
|
||||
|
|
@ -495,7 +494,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
|
|||
value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp));
|
||||
} else {
|
||||
name = sexp_cadr(tmp);
|
||||
value = analyze(ctx2, sexp_caddr(tmp));
|
||||
value = sexp_analyze(ctx2, sexp_caddr(tmp));
|
||||
}
|
||||
if (sexp_exceptionp(value)) sexp_return(res, value);
|
||||
sexp_push(ctx2, defs,
|
||||
|
|
@ -522,10 +521,10 @@ static sexp analyze_if (sexp ctx, sexp x) {
|
|||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
||||
res = sexp_compile_error(ctx, "bad if syntax", x);
|
||||
} else {
|
||||
test = analyze(ctx, sexp_cadr(x));
|
||||
pass = analyze(ctx, sexp_caddr(x));
|
||||
test = sexp_analyze(ctx, sexp_cadr(x));
|
||||
pass = sexp_analyze(ctx, sexp_caddr(x));
|
||||
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
|
||||
fail = analyze(ctx, fail_expr);
|
||||
fail = sexp_analyze(ctx, fail_expr);
|
||||
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
|
||||
sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
|
||||
}
|
||||
|
|
@ -559,7 +558,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
|
||||
value = analyze_lambda(ctx, tmp);
|
||||
} else
|
||||
value = analyze(ctx, sexp_caddr(x));
|
||||
value = sexp_analyze(ctx, sexp_caddr(x));
|
||||
ref = analyze_var_ref(ctx, name);
|
||||
if (sexp_exceptionp(ref))
|
||||
res = ref;
|
||||
|
|
@ -644,7 +643,7 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
|
|||
return res;
|
||||
}
|
||||
|
||||
static sexp analyze (sexp ctx, sexp object) {
|
||||
sexp sexp_analyze (sexp ctx, sexp object) {
|
||||
sexp op;
|
||||
sexp_gc_var4(res, tmp, x, cell);
|
||||
sexp_gc_preserve4(ctx, res, tmp, x, cell);
|
||||
|
|
@ -731,7 +730,7 @@ static sexp analyze (sexp ctx, sexp object) {
|
|||
sexp_synclo_free_vars(x),
|
||||
sexp_context_fv(tmp));
|
||||
x = sexp_synclo_expr(x);
|
||||
res = analyze(tmp, x);
|
||||
res = sexp_analyze(tmp, x);
|
||||
} else {
|
||||
res = x;
|
||||
}
|
||||
|
|
@ -2274,7 +2273,7 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args,
|
|||
#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))
|
||||
if (! sexp_fixnump(type))
|
||||
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),
|
||||
|
|
@ -2285,7 +2284,7 @@ sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) {
|
|||
|
||||
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))
|
||||
if (! sexp_fixnump(type))
|
||||
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),
|
||||
|
|
@ -2296,7 +2295,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) {
|
|||
}
|
||||
|
||||
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))
|
||||
if (! sexp_fixnump(type))
|
||||
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);
|
||||
|
|
@ -2435,7 +2434,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
sexp sexp_compile (sexp ctx, sexp x) {
|
||||
sexp_gc_var3(ast, vec, res);
|
||||
sexp_gc_preserve3(ctx, ast, vec, res);
|
||||
ast = analyze(ctx, x);
|
||||
ast = sexp_analyze(ctx, x);
|
||||
if (sexp_exceptionp(ast)) {
|
||||
res = ast;
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -122,6 +122,7 @@ enum sexp_opcode_names {
|
|||
SEXP_API void sexp_scheme_init (void);
|
||||
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env);
|
||||
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
|
||||
SEXP_API sexp sexp_analyze (sexp context, sexp x);
|
||||
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
|
||||
SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
|
||||
SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
|
||||
|
|
|
|||
|
|
@ -149,8 +149,9 @@ struct sexp_gc_var_t {
|
|||
|
||||
struct sexp_struct {
|
||||
sexp_tag_t tag;
|
||||
char immutablep;
|
||||
char gc_mark;
|
||||
unsigned int immutablep:1;
|
||||
unsigned int freep:1;
|
||||
union {
|
||||
/* basic types */
|
||||
double flonum;
|
||||
|
|
@ -195,8 +196,9 @@ struct sexp_struct {
|
|||
sexp_uint_t data[];
|
||||
} bignum;
|
||||
struct {
|
||||
sexp_uint_t freep, length;
|
||||
sexp_uint_t length;
|
||||
void *value;
|
||||
sexp parent;
|
||||
char body[];
|
||||
} cpointer;
|
||||
/* runtime types */
|
||||
|
|
@ -368,9 +370,11 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
|||
#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG)
|
||||
#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
|
||||
|
||||
#define sexp_pointer_tag(x) ((x)->tag)
|
||||
#define sexp_gc_mark(x) ((x)->gc_mark)
|
||||
#define sexp_immutablep(x) ((x)->immutablep)
|
||||
#define sexp_pointer_tag(x) ((x)->tag)
|
||||
#define sexp_gc_mark(x) ((x)->gc_mark)
|
||||
#define sexp_flags(x) ((x)->flags)
|
||||
#define sexp_immutablep(x) ((x)->immutablep)
|
||||
#define sexp_freep(x) ((x)->freep)
|
||||
|
||||
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag]))
|
||||
#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x)))
|
||||
|
|
@ -524,9 +528,10 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
|
|||
#define sexp_exception_procedure(p) ((p)->value.exception.procedure)
|
||||
#define sexp_exception_source(p) ((p)->value.exception.source)
|
||||
|
||||
#define sexp_cpointer_freep(p) ((p)->value.cpointer.freep)
|
||||
#define sexp_cpointer_freep(p) (sexp_freep(p))
|
||||
#define sexp_cpointer_length(p) ((p)->value.cpointer.length)
|
||||
#define sexp_cpointer_body(p) ((p)->value.cpointer.body)
|
||||
#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent)
|
||||
#define sexp_cpointer_value(p) ((p)->value.cpointer.value)
|
||||
#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p))
|
||||
|
||||
|
|
@ -753,7 +758,7 @@ SEXP_API sexp sexp_intern(sexp ctx, char *str);
|
|||
SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str);
|
||||
SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
|
||||
SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls);
|
||||
SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, int freep);
|
||||
SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep);
|
||||
SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out);
|
||||
SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out);
|
||||
SEXP_API sexp sexp_flush_output(sexp ctx, sexp out);
|
||||
|
|
|
|||
|
|
@ -9,12 +9,12 @@
|
|||
(define-c-struct addrinfo
|
||||
finalizer: freeaddrinfo
|
||||
predicate: address-info?
|
||||
(int ai_family address-info-family)
|
||||
(int ai_socktype address-info-socket-type)
|
||||
(int ai_protocol address-info-protocol)
|
||||
(sockaddr ai_addr address-info-address)
|
||||
(size_t ai_addrlen address-info-address-length)
|
||||
(addrinfo ai_next address-info-next))
|
||||
(int ai_family address-info-family)
|
||||
(int ai_socktype address-info-socket-type)
|
||||
(int ai_protocol address-info-protocol)
|
||||
((link sockaddr) ai_addr address-info-address)
|
||||
(size_t ai_addrlen address-info-address-length)
|
||||
((link addrinfo) ai_next address-info-next))
|
||||
|
||||
(define-c errno (get-address-info getaddrinfo)
|
||||
(string string (maybe-null addrinfo) (result free addrinfo)))
|
||||
|
|
|
|||
13
sexp.c
13
sexp.c
|
|
@ -80,7 +80,7 @@ static struct sexp_struct _sexp_type_specs[] = {
|
|||
_DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), sizeof(sexp), "vector", NULL),
|
||||
_DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum", NULL),
|
||||
_DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), sizeof(sexp), "bignum", NULL),
|
||||
_DEF_TYPE(SEXP_CPOINTER, 0, 0, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
|
||||
_DEF_TYPE(SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, "cpointer", NULL),
|
||||
_DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port", SEXP_FINALIZE_PORT),
|
||||
_DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port", SEXP_FINALIZE_PORT),
|
||||
_DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception", NULL),
|
||||
|
|
@ -711,12 +711,13 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) {
|
|||
return vec;
|
||||
}
|
||||
|
||||
sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, int freep) {
|
||||
sexp sexp_make_cpointer (sexp ctx, sexp_uint_t typeid, void *value, sexp parent, int freep) {
|
||||
sexp ptr;
|
||||
if (! value) return SEXP_FALSE;
|
||||
ptr = sexp_alloc_type(ctx, cpointer, typeid);
|
||||
sexp_freep(ptr) = freep;
|
||||
sexp_cpointer_value(ptr) = value;
|
||||
sexp_cpointer_freep(ptr) = freep;
|
||||
sexp_cpointer_parent(ptr) = parent;
|
||||
sexp_cpointer_length(ptr) = 0;
|
||||
return ptr;
|
||||
}
|
||||
|
|
@ -1158,7 +1159,11 @@ sexp sexp_read_string(sexp ctx, sexp in) {
|
|||
for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) {
|
||||
if (c == '\\') {
|
||||
c = sexp_read_char(ctx, in);
|
||||
switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;}
|
||||
switch (c) {
|
||||
case 'n': c = '\n'; break;
|
||||
case 'r': c = '\r'; break;
|
||||
case 't': c = '\t'; break;
|
||||
}
|
||||
}
|
||||
if (c == EOF) {
|
||||
res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in);
|
||||
|
|
|
|||
|
|
@ -125,34 +125,27 @@
|
|||
funcs))
|
||||
#f)))
|
||||
|
||||
(define (delq x ls)
|
||||
(cond ((not (pair? ls)) ls)
|
||||
((eq? x (car ls)) (cdr ls))
|
||||
(else (cons (car ls) (delq x (cdr ls))))))
|
||||
|
||||
(define (without-mod x ls)
|
||||
(let ((res (delq x ls)))
|
||||
(if (and (pair? res) (null? (cdr res)))
|
||||
(car res)
|
||||
res)))
|
||||
|
||||
(define (with-parsed-type type proc)
|
||||
(let* ((free? (and (pair? type) (memq 'free type)))
|
||||
(type (if free? (without-mod 'free type) type))
|
||||
(const? (and (pair? type) (memq 'const type)))
|
||||
(type (if const? (without-mod 'const type) type))
|
||||
(null-ptr? (and (pair? type) (memq 'maybe-null type)))
|
||||
(type (if null-ptr? (without-mod 'maybe-null type) type))
|
||||
(pointer? (and (pair? type) (memq 'pointer type)))
|
||||
(type (if pointer? (without-mod 'pointer type) type))
|
||||
(result? (and (pair? type) (memq 'result type)))
|
||||
(type (if result? (without-mod 'result type) type)))
|
||||
(proc type free? const? null-ptr? pointer? result?)))
|
||||
(let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
|
||||
(pointer? #f) (struct? #f) (link? #f) (result? #f))
|
||||
(define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
|
||||
(case (and (pair? type) (car type))
|
||||
((free) (lp (next) #t const? null-ptr? pointer? struct? link? result?))
|
||||
((const) (lp (next) free? #t null-ptr? pointer? struct? link? result?))
|
||||
((maybe-null) (lp (next) free? const? #t pointer? struct? link? result?))
|
||||
((pointer) (lp (next) free? const? null-ptr? #t struct? link? result?))
|
||||
((struct) (lp (next) free? const? null-ptr? pointer? #t link? result?))
|
||||
((link) (lp (next) free? const? null-ptr? pointer? struct? #t result?))
|
||||
((result) (lp (next) free? const? null-ptr? pointer? struct? link? #t))
|
||||
(else (proc type free? const? null-ptr? pointer? struct? link? result?)))))
|
||||
|
||||
(define (c->scheme-converter type val)
|
||||
(define (get-base-type type)
|
||||
(with-parsed-type type (lambda (x . args) x)))
|
||||
|
||||
(define (c->scheme-converter type val . o)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (type free? const? null-ptr? pointer? result?)
|
||||
(lambda (type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((memq type '(sexp errno))
|
||||
(cat val))
|
||||
|
|
@ -171,14 +164,15 @@
|
|||
(cond
|
||||
(ctype
|
||||
(cat "sexp_make_cpointer(ctx, " (type-id-name type) ", "
|
||||
val ", " (if free? 1 0) ")"))
|
||||
val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
|
||||
(if free? 1 0) ")"))
|
||||
(else
|
||||
(error "unknown type" type)))))))))
|
||||
|
||||
(define (scheme->c-converter type val)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (type free? const? null-ptr? pointer? result?)
|
||||
(lambda (type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((eq? 'sexp type)
|
||||
(cat val))
|
||||
|
|
@ -204,7 +198,7 @@
|
|||
(define (type-predicate type)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (type free? const? null-ptr? pointer? result?)
|
||||
(lambda (type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((int-type? type) "sexp_exact_integerp")
|
||||
((float-type? type) "sexp_flonump")
|
||||
|
|
@ -214,7 +208,7 @@
|
|||
(define (type-name type)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (type free? const? null-ptr? pointer? result?)
|
||||
(lambda (type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((int-type? type) "integer")
|
||||
((float-type? type) "flonum")
|
||||
|
|
@ -223,7 +217,7 @@
|
|||
(define (type-c-name type)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (base-type free? const? null-ptr? pointer? result?)
|
||||
(lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(let ((struct? (assq base-type types)))
|
||||
(string-append
|
||||
(if const? "const " "")
|
||||
|
|
@ -235,7 +229,7 @@
|
|||
(define (check-type arg type)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (base-type free? const? null-ptr? pointer? result?)
|
||||
(lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
|
||||
(cat (type-predicate type) "(" arg ")"))
|
||||
|
|
@ -256,7 +250,7 @@
|
|||
(define (validate-type arg type)
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (base-type free? const? null-ptr? pointer? result?)
|
||||
(lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
|
||||
(cat
|
||||
|
|
@ -349,7 +343,7 @@
|
|||
(type (cdr type)))
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (base-type free? const? null-ptr? pointer? result?)
|
||||
(lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
|
||||
" " (type-id-name name)
|
||||
" = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, "
|
||||
|
|
@ -368,46 +362,56 @@
|
|||
|
||||
(define (type-getter-name type name field)
|
||||
(string-append "sexp_" (x->string (type-name name))
|
||||
"_get_" (x->string (cadr field))))
|
||||
"_get_" (x->string (get-base-type (cadr field)))))
|
||||
|
||||
(define (write-type-getter type name field)
|
||||
(cat "static sexp " (type-getter-name type name field)
|
||||
" (sexp ctx, sexp x) {\n"
|
||||
(lambda () (validate-type "x" name))
|
||||
" return "
|
||||
(lambda () (c->scheme-converter
|
||||
(car field)
|
||||
(string-append "((struct " (mangle name) "*)"
|
||||
"sexp_cpointer_value(x))->"
|
||||
(x->string (cadr field)))))
|
||||
";\n"
|
||||
"}\n\n"))
|
||||
(with-parsed-type
|
||||
(car field)
|
||||
(lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cat "static sexp " (type-getter-name type name field)
|
||||
" (sexp ctx, sexp x) {\n"
|
||||
(lambda () (validate-type "x" name))
|
||||
" return "
|
||||
(lambda ()
|
||||
(c->scheme-converter
|
||||
field-type
|
||||
(string-append "((struct " (mangle name) "*)"
|
||||
"sexp_cpointer_value(x))"
|
||||
(if struct? "." "->")
|
||||
(x->string (cadr field)))
|
||||
(and (or struct? link?) "x")))
|
||||
";\n"
|
||||
"}\n\n"))))
|
||||
|
||||
(define (type-setter-name type name field)
|
||||
(string-append "sexp_" (x->string (type-name name))
|
||||
"_set_" (x->string (car field))))
|
||||
"_set_" (x->string (get-base-type (car field)))))
|
||||
|
||||
(define (write-type-setter type name field)
|
||||
(cat "static sexp " (type-setter-name type name field)
|
||||
" (sexp ctx, sexp x, sexp v) {\n"
|
||||
(lambda () (validate-type "x" name))
|
||||
(lambda () (validate-type "v" (car field)))
|
||||
" "
|
||||
(lambda () (c->scheme-converter
|
||||
(car field)
|
||||
(string-append "((struct " (mangle name) "*)"
|
||||
"sexp_cpointer_value(x))->"
|
||||
(x->string (cadr field)))))
|
||||
" = v;\n"
|
||||
" return SEXP_VOID;"
|
||||
"}\n\n"))
|
||||
(with-parsed-type
|
||||
(car field)
|
||||
(lambda (field-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cat "static sexp " (type-setter-name type name field)
|
||||
" (sexp ctx, sexp x, sexp v) {\n"
|
||||
(lambda () (validate-type "x" name))
|
||||
(lambda () (validate-type "v" (car field)))
|
||||
" "
|
||||
(lambda () (c->scheme-converter
|
||||
field-type
|
||||
(string-append "((struct " (mangle name) "*)"
|
||||
"sexp_cpointer_value(x))"
|
||||
(if struct? "." "->")
|
||||
(x->string (cadr field)))))
|
||||
" = v;\n"
|
||||
" return SEXP_VOID;"
|
||||
"}\n\n"))))
|
||||
|
||||
(define (write-type-funcs type)
|
||||
(let ((name (car type))
|
||||
(type (cdr type)))
|
||||
(with-parsed-type
|
||||
type
|
||||
(lambda (base-type free? const? null-ptr? pointer? result?)
|
||||
(lambda (base-type free? const? null-ptr? pointer? struct? link? result?)
|
||||
(cond
|
||||
((memq 'finalizer: base-type)
|
||||
=> (lambda (x)
|
||||
|
|
@ -456,8 +460,7 @@
|
|||
(cons (list (type-setter-name type name field)
|
||||
(car field) (cadddr field)
|
||||
(list name (car field)))
|
||||
funcs))
|
||||
)))))
|
||||
funcs)))))))
|
||||
base-type)))))
|
||||
|
||||
(define (write-init)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue