diff --git a/Makefile b/Makefile index 437d4355..47f9ff6c 100644 --- a/Makefile +++ b/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) diff --git a/eval.c b/eval.c index 372f0ef7..49fd8a31 100644 --- a/eval.c +++ b/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 { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 0e9dbdf2..1326333e 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -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); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8d850472..575eeaad 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -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); diff --git a/lib/chibi/net.stub b/lib/chibi/net.stub index 86f89457..8e595f8f 100644 --- a/lib/chibi/net.stub +++ b/lib/chibi/net.stub @@ -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))) diff --git a/sexp.c b/sexp.c index c73a2776..47b7fb2c 100644 --- a/sexp.c +++ b/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); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index e5d5ea66..779b8afd 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -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)