diff --git a/Makefile b/Makefile index f9d7e3aa..3aa63400 100644 --- a/Makefile +++ b/Makefile @@ -112,7 +112,7 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -%.c: %.stub chibi-scheme$(EXE) $(GENSTUBS) +%.c: %.stub $(GENSTUBS) LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) $(GENSTUBS) $< lib/%$(SO): lib/%.c $(INCLUDES) diff --git a/eval.c b/eval.c index 3674419f..a46389bd 100644 --- a/eval.c +++ b/eval.c @@ -36,56 +36,83 @@ static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { /********************** environment utilities ***************************/ -sexp sexp_env_cell (sexp e, sexp key) { +static sexp sexp_env_cell_loc (sexp env, sexp key, sexp *varenv) { sexp ls; do { - for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (sexp_caar(ls) == key) + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == key) { + if (varenv) *varenv = env; return sexp_car(ls); - e = sexp_env_parent(e); - } while (e); + } + env = sexp_env_parent(env); + } while (env); return NULL; } -static sexp sexp_env_cell_create (sexp ctx, sexp e, sexp key, sexp value) { +sexp sexp_env_cell (sexp env, sexp key) { + return sexp_env_cell_loc(env, key, NULL); +} + +static sexp sexp_env_cell_create_loc (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { sexp_gc_var1(cell); - cell = sexp_env_cell(e, key); + cell = sexp_env_cell_loc(env, key, varenv); if (! cell) { sexp_gc_preserve1(ctx, cell); cell = sexp_cons(ctx, key, value); - while (sexp_env_parent(e)) - e = sexp_env_parent(e); - sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e)); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + sexp_env_bindings(env) = sexp_cons(ctx, cell, sexp_env_bindings(env)); + if (varenv) *varenv = env; sexp_gc_release1(ctx); } return cell; } -sexp sexp_env_global_ref (sexp e, sexp key, sexp dflt) { +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, sexp value) { + return sexp_env_cell_create_loc(ctx, env, key, value, NULL); +} + +sexp sexp_env_global_ref (sexp env, sexp key, sexp dflt) { sexp cell; - while (sexp_env_parent(e)) - e = sexp_env_parent(e); - cell = sexp_env_cell(e, key); + while (sexp_env_parent(env)) + env = sexp_env_parent(env); + cell = sexp_env_cell(env, key); return (cell ? sexp_cdr(cell) : dflt); } -void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) { - sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell = sexp_assq(ctx, key, sexp_env_bindings(env)), res=SEXP_VOID; sexp_gc_var1(tmp); - if (sexp_immutablep(e)) { - fprintf(stderr, "ERROR: immutable environment\n"); + if (sexp_immutablep(env)) { + res = sexp_type_exception(ctx, "immutable binding", key); } else { sexp_gc_preserve1(ctx, tmp); - if (sexp_truep(cell)) - sexp_cdr(cell) = value; - else { + if (sexp_truep(cell)) { + if (sexp_immutablep(cell)) + res = sexp_type_exception(ctx, "immutable binding", key); + else + sexp_cdr(cell) = value; + } else { tmp = sexp_cons(ctx, key, value); - sexp_push(ctx, sexp_env_bindings(e), tmp); + sexp_push(ctx, sexp_env_bindings(env), tmp); } sexp_gc_release1(ctx); } + return res; +} + +sexp sexp_env_exports (sexp ctx, sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_caar(ls)); + sexp_gc_release1(ctx); + return res; } sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { @@ -430,11 +457,11 @@ static sexp analyze_seq (sexp ctx, sexp ls) { return res; } -static sexp analyze_var_ref (sexp ctx, sexp x) { +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { sexp env = sexp_context_env(ctx), res; sexp_gc_var1(cell); sexp_gc_preserve1(ctx, cell); - cell = sexp_env_cell(env, x); + cell = sexp_env_cell_loc(env, x, varenv); if (! cell) { if (sexp_synclop(x)) { if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx))) @@ -442,7 +469,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF); + cell = sexp_env_cell_create_loc(ctx, env, x, SEXP_UNDEF, varenv); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) res = sexp_compile_error(ctx, "invalid use of syntax as value", x); @@ -453,14 +480,14 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { } static sexp analyze_set (sexp ctx, sexp x) { - sexp res; + sexp res, varenv; sexp_gc_var2(ref, value); sexp_gc_preserve2(ctx, ref, value); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { res = sexp_compile_error(ctx, "bad set! syntax", x); } else { - ref = analyze_var_ref(ctx, sexp_cadr(x)); + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); 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)); @@ -468,6 +495,9 @@ static sexp analyze_set (sexp ctx, sexp x) { res = ref; else if (sexp_exceptionp(value)) res = value; + else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); else res = sexp_make_set(ctx, ref, value); } @@ -511,7 +541,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, - sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value)); + sexp_make_set(ctx2, analyze_var_ref(ctx2, name, NULL), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { @@ -546,7 +576,7 @@ static sexp analyze_if (sexp ctx, sexp x) { } static sexp analyze_define (sexp ctx, sexp x) { - sexp name, res; + sexp name, res, varenv; sexp_gc_var4(ref, value, tmp, env); sexp_gc_preserve4(ctx, ref, value, tmp, env); env = sexp_context_env(ctx); @@ -574,11 +604,13 @@ static sexp analyze_define (sexp ctx, sexp x) { value = analyze_lambda(ctx, tmp); } else value = analyze(ctx, sexp_caddr(x)); - ref = analyze_var_ref(ctx, name); + ref = analyze_var_ref(ctx, name, &varenv); if (sexp_exceptionp(ref)) res = ref; else if (sexp_exceptionp(value)) res = value; + else if (varenv && sexp_immutablep(varenv)) + res = sexp_compile_error(ctx, "immutable binding", name); else res = sexp_make_set(ctx, ref, value); } @@ -736,15 +768,13 @@ static sexp analyze (sexp ctx, sexp object) { res = sexp_compile_error(ctx, "invalid operand in application", x); } } else if (sexp_idp(x)) { - res = analyze_var_ref(ctx, x); + res = analyze_var_ref(ctx, x, NULL); } else if (sexp_synclop(x)) { tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); sexp_context_env(tmp) = sexp_synclo_env(x); sexp_context_fv(tmp) = sexp_append2(tmp, sexp_synclo_free_vars(x), sexp_context_fv(tmp)); - if (sexp_pairp(sexp_synclo_free_vars(x))) - sexp_debug(ctx, "free vars: ", sexp_context_fv(tmp)); x = sexp_synclo_expr(x); res = analyze(tmp, x); } else { @@ -2535,13 +2565,21 @@ sexp sexp_make_standard_env (sexp ctx, sexp version) { return env; } -sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) { +sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls, sexp immutp) { sexp oldname, newname, value, out; if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { - for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + if (sexp_truep(immutp)) { + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_immutablep(value) = 1; + sexp_env_bindings(value) = sexp_env_bindings(from); + } else { + for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls)); + } } else { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (sexp_pairp(sexp_car(ls))) { diff --git a/include/chibi/config.h b/include/chibi/config.h index 028ea0ec..cec2b00c 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -52,6 +52,9 @@ /* and are thus thread-safe and independant. */ /* #define SEXP_USE_GLOBAL_HEAP 1 */ +/* uncomment this to make type definitions common to all contexts */ +/* #define SEXP_USE_GLOBAL_TYPES 1 */ + /* uncomment this to make the symbol table common to all contexts */ /* Will still be restricted to all contexts sharing the same */ /* heap, of course. */ @@ -194,6 +197,10 @@ #endif #endif +#ifndef SEXP_USE_GLOBAL_TYPES +#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS) +#endif + #ifndef SEXP_USE_GLOBAL_SYMBOLS #if SEXP_USE_BOEHM || SEXP_USE_MALLOC #define SEXP_USE_GLOBAL_SYMBOLS 1 diff --git a/include/chibi/eval.h b/include/chibi/eval.h index a2afa062..23428d21 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -137,8 +137,8 @@ SEXP_API sexp sexp_find_module_file (sexp ctx, char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env); SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp); SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); -SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); -SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8283d601..03a2e631 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -644,6 +644,12 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) #endif +#if SEXP_USE_GLOBAL_TYPES +#define sexp_context_types(ctx) sexp_type_specs +#else +#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES)) +#endif + #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) #define sexp_type_tag(x) ((x)->value.type.tag) @@ -683,6 +689,9 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); enum sexp_context_globals { #if ! SEXP_USE_GLOBAL_SYMBOLS SEXP_G_SYMBOLS, +#endif +#if ! SEXP_USE_GLOBAL_TYPES + SEXP_G_TYPES, #endif SEXP_G_OOM_ERROR, /* out of memory exception object */ SEXP_G_OOS_ERROR, /* out of stack exception object */ diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module index 17c8ac2d..5b76daf8 100644 --- a/lib/chibi/loop.module +++ b/lib/chibi/loop.module @@ -4,6 +4,6 @@ listing listing-reverse appending appending-reverse summing multiplying in-string in-string-reverse in-vector in-vector-reverse) - (import (scheme)) + (import-immutable (scheme)) (include "loop/loop.scm")) diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module index 9aac5dbc..47b0e7d4 100644 --- a/lib/chibi/macroexpand.module +++ b/lib/chibi/macroexpand.module @@ -1,6 +1,6 @@ (define-module (chibi macroexpand) - (import (scheme)) + (import-immutable (scheme)) (import (chibi ast)) (export macroexpand) (include "macroexpand.scm")) diff --git a/lib/chibi/match.module b/lib/chibi/match.module index afce8975..1366176a 100644 --- a/lib/chibi/match.module +++ b/lib/chibi/match.module @@ -1,6 +1,6 @@ (define-module (chibi match) (export match match-lambda match-lambda* match-let match-letrec match-let*) - (import (scheme)) + (import-immutable (scheme)) (include "match/match.scm")) diff --git a/lib/chibi/net.module b/lib/chibi/net.module index d17c1791..14f3801f 100644 --- a/lib/chibi/net.module +++ b/lib/chibi/net.module @@ -1,9 +1,9 @@ (define-module (chibi net) - (export sockaddr? addressinfo? get-address-info socket connect with-net-io + (export sockaddr? address-info? get-address-info socket connect with-net-io address-info-family address-info-socket-type address-info-protocol address-info-address address-info-address-length address-info-next) - (import (scheme)) + (import-immutable (scheme)) (import (chibi posix)) (include-shared "net") (include "net.scm")) diff --git a/lib/chibi/pathname.module b/lib/chibi/pathname.module index 2fb46eef..765ee189 100644 --- a/lib/chibi/pathname.module +++ b/lib/chibi/pathname.module @@ -3,5 +3,5 @@ (export path-strip-directory path-directory path-extension-pos path-extension path-strip-extension path-replace-extension path-absolute? path-relative? path-normalize make-path) - (import (scheme)) + (import-immutable (scheme)) (include "pathname.scm")) diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module index 7a05181a..aba6b7ff 100644 --- a/lib/chibi/posix.module +++ b/lib/chibi/posix.module @@ -1,12 +1,12 @@ (define-module (chibi posix) - (export open-input-fd open-output-fd - delete-file link-file symbolic-link rename-file + (export open-input-fd open-output-fd pipe + delete-file link-file symbolic-link-file rename-file directory-files create-directory delete-directory current-seconds exit ) - (import (scheme)) + (import-immutable (scheme)) (include-shared "posix") (include "posix.scm")) diff --git a/lib/chibi/posix.scm b/lib/chibi/posix.scm index e2c6d56f..ed5fa780 100644 --- a/lib/chibi/posix.scm +++ b/lib/chibi/posix.scm @@ -1,7 +1,10 @@ -(define (directory-files path) - (let ((dir (opendir path))) - (let lp ((res '())) +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (let lp ((res knil)) (let ((file (readdir dir))) - (if file (lp (cons (dirent-name file) res)) res))))) + (if file (lp (kons (dirent-name file) res)) res))))) + +(define (directory-files dir) + (directory-fold dir cons '())) diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub index b986952d..7c1a6c9f 100644 --- a/lib/chibi/posix.stub +++ b/lib/chibi/posix.stub @@ -10,29 +10,29 @@ (define-c-struct dirent (string d_name dirent-name)) -(define-c input-port (open-input-fd fdopen) (int (value "r"))) -(define-c output-port (open-output-fd fdopen) (int (value "w"))) +(define-c input-port (open-input-fd "fdopen") (int (value "r" string))) +(define-c output-port (open-output-fd "fdopen") (int (value "w" string))) -(define-c errno (delete-file unlink) (string)) -(define-c errno (link-file link) (string string)) -(define-c errno (symbolic-link-file symlink) (string string)) -(define-c errno (rename-file rename) (string string)) +(define-c errno (delete-file "unlink") (string)) +(define-c errno (link-file "link") (string string)) +(define-c errno (symbolic-link-file "symlink") (string string)) +(define-c errno (rename-file "rename") (string string)) -;; (define-c string (current-directory getcwd) ()) -(define-c errno (create-directory mkdir) (string int)) -(define-c errno (delete-directory rmdir) (string)) +;;(define-c string (current-directory "getcwd") ((value (array char)) int)) +(define-c errno (create-directory "mkdir") (string int)) +(define-c errno (delete-directory "rmdir") (string)) (define-c (free DIR) opendir (string)) (define-c dirent readdir (DIR)) -(define-c int (duplicate-fd dup) (int)) +(define-c int (duplicate-fd "dup") (int)) (define-c pid_t fork ()) ;; (define-c pid_t wait ((result pointer int))) (define-c void exit (int)) -;;(define-c int (execute execvp) (string (array string null))) +(define-c int (execute execvp) (string (array string null))) -;;(define-c errno pipe ((result (array int 2)))) +(define-c errno pipe ((result (array int 2)))) -(define-c time_t (current-seconds time) ((value NULL))) +(define-c time_t (current-seconds "time") ((value NULL))) diff --git a/lib/chibi/uri.module b/lib/chibi/uri.module index 825ccd45..2456dd9f 100644 --- a/lib/chibi/uri.module +++ b/lib/chibi/uri.module @@ -5,6 +5,6 @@ uri-with-scheme uri-with-user uri-with-host uri-with-path uri-with-query uri-with-fragment uri-encode uri-decode uri-query->alist uri-alist->query) - (import (scheme) - (srfi 9)) + (import-immutable (scheme) + (srfi 9)) (include "uri.scm")) diff --git a/lib/config.scm b/lib/config.scm index 0e26ab90..51435a3a 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -2,15 +2,16 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; modules -(define *modules* '()) (define *this-module* '()) (define (make-module exports env meta) (vector exports env meta)) -(define (module-exports mod) (vector-ref mod 0)) (define (module-env mod) (vector-ref mod 1)) (define (module-meta-data mod) (vector-ref mod 2)) (define (module-env-set! mod env) (vector-set! mod 1 env)) +(define (module-exports mod) + (or (vector-ref mod 0) (env-exports (module-env mod)))) + (define (module-name->strings ls res) (if (null? ls) res @@ -55,13 +56,22 @@ ((not (and (pair? x) (list? x))) (error "invalid module syntax" x)) ((and (pair? (cdr x)) (pair? (cadr x))) - (if (memq (car x) '(only except renams)) + (if (memq (car x) '(only except rename)) (let* ((mod-name+imports (resolve-import (cadr x))) - (imp-ids (cdr mod-name+imports))) + (imp-ids (cdr mod-name+imports)) + (imp-ids (if (and (not imp-ids) (not (eq? 'only (car x)))) + (begin + (set-cdr! mod-name+imports + (module-exports + (find-module (car mod-name+imports)))) + (cdr mod-name+imports)) + imp-ids))) (cons (car mod-name+imports) (case (car x) ((only) - (id-filter (lambda (i) (memq i (cddr x))) imp-ids)) + (if (not imp-ids) + (cddr x) + (id-filter (lambda (i) (memq i (cddr x))) imp-ids))) ((except) (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids)) ((rename) @@ -78,7 +88,7 @@ (if (pair? i) (cdr i) i))) (cdr mod-name+imports))))) ((find-module x) - => (lambda (mod) (cons x (module-exports mod)))) + => (lambda (mod) (cons x #f))) (else (error "couldn't find import" x)))) @@ -88,12 +98,13 @@ (for-each (lambda (x) (case (and (pair? x) (car x)) - ((import) + ((import import-immutable) (for-each - (lambda (x) - (let* ((mod2-name+imports (resolve-import x)) + (lambda (m) + (let* ((mod2-name+imports (resolve-import m)) (mod2 (load-module (car mod2-name+imports)))) - (%env-copy! env (module-env mod2) (cdr mod2-name+imports)))) + (%env-copy! env (module-env mod2) (cdr mod2-name+imports) + (eq? (car x) 'import-immutable)))) (cdr x))) ((include include-shared) (for-each @@ -142,58 +153,15 @@ `(set! *this-module* (cons ',expr *this-module*)))))))) (define-config-primitive import) +(define-config-primitive import-immutable) (define-config-primitive export) (define-config-primitive include) (define-config-primitive include-shared) (define-config-primitive body) -(let ((exports - '(define set! let let* letrec lambda if cond case delay - and or begin do quote quasiquote - define-syntax let-syntax letrec-syntax syntax-rules eqv? eq? equal? - not boolean? number? complex? real? rational? integer? exact? inexact? - = < > <= >= zero? positive? negative? odd? even? max min + * - / abs - quotient remainder modulo gcd lcm numerator denominator floor ceiling - truncate round exp log sin cos tan asin acos atan sqrt - expt real-part imag-part magnitude angle - exact->inexact inexact->exact number->string string->number pair? cons - car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr - cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr - caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - null? list? list length append reverse reverse! - list-tail list-ref memq memv - member assq assv assoc symbol? symbol->string string->symbol char? - char=? char? char<=? char>=? char-ci=? char-ci? - char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? - char-upper-case? char-lower-case? char->integer integer->char - char-upcase char-downcase string? make-string string string-length - string-ref string-set! string=? string-ci=? string? - string<=? string>=? string-ci? string-ci<=? string-ci>=? - substring string-append string->list list->string string-copy - string-fill! vector? make-vector vector vector-length vector-ref - vector-set! vector->list list->vector vector-fill! procedure? apply - map for-each force call-with-current-continuation values - call-with-values interaction-environment scheme-report-environment - null-environment call-with-input-file call-with-output-file - input-port? output-port? current-input-port current-output-port - with-input-from-file with-output-to-file open-input-file - open-output-file close-input-port close-output-port read read-char - peek-char eof-object? char-ready? write display newline write-char - load eval - *current-input-port* *current-output-port* *current-error-port* - error current-error-port file-exists? string-concatenate - open-input-string open-output-string get-output-string - sc-macro-transformer rsc-macro-transformer er-macro-transformer - identifier? identifier=? identifier->symbol make-syntactic-closure - syntax-quote - register-simple-type make-constructor make-type-predicate - make-getter make-setter - ))) - (set! *modules* - (list (cons '(scheme) (make-module exports - (interaction-environment) - (list (cons 'export exports)))) - (cons '(srfi 0) (make-module (list 'cond-expand) - (interaction-environment) - (list (list 'export 'cond-expand))))))) +(define *modules* + (list (cons '(scheme) (make-module #f (interaction-environment) '())) + (cons '(srfi 0) (make-module (list 'cond-expand) + (interaction-environment) + (list (list 'export 'cond-expand)))))) diff --git a/lib/init.scm b/lib/init.scm index 67659303..24aa8b34 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -766,7 +766,8 @@ (vector-ref (eval '(load-module ',(car mod+imps)) *config-env*) 1) - ',(cdr mod+imps)) + ',(cdr mod+imps) + #f) res)) (error "couldn't find module" (car ls)))))))))) diff --git a/lib/srfi/1.module b/lib/srfi/1.module index 3d3da044..8d341b6b 100644 --- a/lib/srfi/1.module +++ b/lib/srfi/1.module @@ -18,7 +18,7 @@ lset<= lset= lset-adjoin lset-union lset-union! lset-intersection lset-intersection! lset-difference lset-difference! lset-xor lset-xor! lset-diff+intersection lset-diff+intersection!) - (import (scheme)) + (import-immutable (scheme)) (include "1/predicates.scm" "1/selectors.scm" "1/search.scm" diff --git a/lib/srfi/11.module b/lib/srfi/11.module index 386443a2..f3c91df8 100644 --- a/lib/srfi/11.module +++ b/lib/srfi/11.module @@ -1,7 +1,7 @@ (define-module (srfi 11) (export let-values let*-values) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax let*-values (syntax-rules () diff --git a/lib/srfi/16.module b/lib/srfi/16.module index 61837146..f931a376 100644 --- a/lib/srfi/16.module +++ b/lib/srfi/16.module @@ -1,7 +1,7 @@ (define-module (srfi 16) (export case-lambda) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax %case (syntax-rules () diff --git a/lib/srfi/2.module b/lib/srfi/2.module index b7addf06..4ceb8b6b 100644 --- a/lib/srfi/2.module +++ b/lib/srfi/2.module @@ -1,7 +1,7 @@ (define-module (srfi 2) (export and-let*) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax and-let* (syntax-rules () diff --git a/lib/srfi/26.module b/lib/srfi/26.module index 9ed9aeee..f97ab783 100644 --- a/lib/srfi/26.module +++ b/lib/srfi/26.module @@ -1,7 +1,7 @@ (define-module (srfi 26) (export cut cute) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax %cut (syntax-rules (<> <...>) diff --git a/lib/srfi/27.module b/lib/srfi/27.module index 198d444e..5c451629 100644 --- a/lib/srfi/27.module +++ b/lib/srfi/27.module @@ -5,7 +5,7 @@ random-source-state-ref random-source-state-set! random-source-randomize! random-source-pseudo-randomize! random-source-make-integers random-source-make-reals) - (import (scheme)) + (import-immutable (scheme)) (include-shared "27/rand") (include "27/constructors.scm")) diff --git a/lib/srfi/33.module b/lib/srfi/33.module index 81fa0a80..7eb86c1e 100644 --- a/lib/srfi/33.module +++ b/lib/srfi/33.module @@ -12,6 +12,6 @@ first-set-bit extract-bit-field test-bit-field? clear-bit-field replace-bit-field copy-bit-field) - (import (scheme)) + (import-immutable (scheme)) (include-shared "33/bit") (include "33/bitwise.scm")) diff --git a/lib/srfi/6.module b/lib/srfi/6.module index bbabf209..e589b6ff 100644 --- a/lib/srfi/6.module +++ b/lib/srfi/6.module @@ -1,5 +1,5 @@ (define-module (srfi 6) (export open-input-string open-output-string get-output-string) - (import (scheme))) + (import-immutable (scheme))) diff --git a/lib/srfi/69.module b/lib/srfi/69.module index fd28ecaa..037b6393 100644 --- a/lib/srfi/69.module +++ b/lib/srfi/69.module @@ -10,8 +10,8 @@ hash-table-walk hash-table-fold hash-table->alist hash-table-copy hash-table-merge! hash string-hash string-ci-hash hash-by-identity) - (import (scheme)) - (import (srfi 9)) + (import-immutable (scheme) + (srfi 9)) (include-shared "69/hash") (include "69/type.scm" "69/interface.scm")) diff --git a/lib/srfi/8.module b/lib/srfi/8.module index ebe02df7..64a3e6e2 100644 --- a/lib/srfi/8.module +++ b/lib/srfi/8.module @@ -1,7 +1,7 @@ (define-module (srfi 8) (export receive) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax receive (syntax-rules () diff --git a/lib/srfi/9.module b/lib/srfi/9.module index aca550a4..0516b201 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -1,7 +1,7 @@ (define-module (srfi 9) (export define-record-type) - (import (scheme)) + (import-immutable (scheme)) (body (define-syntax define-record-type (er-macro-transformer diff --git a/opcodes.c b/opcodes.c index c65ef3d5..470c694a 100644 --- a/opcodes.c +++ b/opcodes.c @@ -92,7 +92,7 @@ _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), _FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), _FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), -_FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), +_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), _FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), @@ -144,6 +144,7 @@ _FN2OPTP(SEXP_PROCEDURE, SEXP_OPORT, "disasm", (sexp)"*current-error-port*", sex #endif _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), #if SEXP_USE_MODULES +_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports), _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op), _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op), _FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory), diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 3202e0eb..ae7c8201 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1,8 +1,181 @@ #! chibi-scheme -s +;; Simple C FFI. "genstubs.scm file.stub" will read in the C function +;; FFI definitions from file.stub and output the appropriate C +;; wrappers into file.c. You can then compile that file with: +;; +;; cc -fPIC -shared file.c -lchibi-scheme +;; +;; (or using whatever flags are appropriate to generate shared libs on +;; your platform) and then the generated .so file can be loaded +;; directly with load, or portably using (include-shared "file") in a +;; module definition (note that include-shared uses no suffix). + +;; The goal of this interface is to make access to C types and +;; functions easy, without requiring the user to write any C code. +;; That means the stubber needs to be intelligent about various C +;; calling conventions and idioms, such as return values passed in +;; actual parameters. Writing C by hand is still possible, and +;; several of the core modules provide C interfaces directly without +;; using the stubber. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Struct Interface +;; +;; (define-c-struct struct-name +;; [predicate: predicate-name] +;; [constructor: constructor-name] +;; [finalizer: c_finalizer_name] +;; (type c_field_name getter-name setter-name) ...) +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Function Interface +;; +;; (define-c return-type name-spec (arg-type ...)) +;; +;; where name-space is either a symbol name, or a list of +;; (scheme-name c_name). If just a symbol, the C name is taken +;; to be the same with -'s replaced by _'s. +;; +;; arg-type is a type suitable for input validation and conversion. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Types +;; +;; Types +;; +;; Basic Types +;; void +;; boolean +;; char +;; +;; Integer Types: +;; short int long +;; unsigned-short unsigned-int unsigned-long size_t pid_t +;; time_t (in seconds, but using the chibi epoch of 2010/01/01) +;; errno (as a return type returns #f on error) +;; +;; Float Types: +;; float double long-double +;; +;; String Types: +;; string (a null-terminated char*) +;; +;; Port Types: +;; input-port output-port +;; +;; Struct Types: +;; +;; Struct types are by default just referred to by the bare +;; struct-name from define-c-struct, and it is assumed you want a +;; pointer to that type. To refer to the full struct, use the struct +;; modifier, as in (struct struct-name). + +;; Type modifiers +;; +;; Any type may also be written as a list of modifiers followed by the +;; type itself. The supported modifiers are: +;; +;; const: prepends the "const" C type modifier +;; * as a return or result parameter, makes non-immediates immutable +;; +;; free: it's Scheme's responsibility to "free" this resource +;; * as a return or result parameter, registers the freep flag +;; this causes the type finalizer to be run when GCed +;; +;; maybe-null: this pointer type may be NULL +;; * as a result parameter, NULL is translated to #f +;; normally this would just return a wrapped NULL pointer +;; * as an input parameter, #f is translated to NULL +;; normally this would be a type error +;; +;; pointer: create a pointer to this type +;; * as a return parameter, wraps the result in a vanilla cpointer +;; * as a result parameter, boxes then unboxes the value +;; +;; struct: treat this struct type as a struct, not a pointer +;; * as an input parameter, dereferences the pointer +;; * as a type field, indicates a nested struct +;; +;; link: add a gc link +;; * as a field getter, link to the parent object, so the +;; parent won't be GCed so long as we have a reference +;; to the child. this behavior is automatic for nested +;; structs. +;; +;; result: return a result in this parameter +;; * if there are multiple results (including the return type), +;; they are all returned in a list +;; * if there are any result parameters, a return type +;; of errno returns #f on failure, and as eliminated +;; from the list of results otherwise +;; +;; (value ): specify a fixed value +;; * as an input parameter, this parameter is not provided +;; in the Scheme API but always passed as +;; +;; (default ): specify a default value +;; * as the final input parameter, makes the Scheme parameter +;; optional, defaulting to +;; +;; (array []) an array type +;; * length must be specified for return and result parameters +;; * if specified, length can be any of +;; ** an integer, for a fixed size +;; ** the symbol null, indicating a NULL-terminated array + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define types '()) (define funcs '()) +(define (make-type type free? const? null? ptr? struct? link? result? array value default? i) + (vector type free? const? null? ptr? struct? link? result? array value default? i)) + +(define (with-parsed-type type proc . o) + (cond + ((vector? type) + (apply proc (vector->list type))) + (else + (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) + (ptr? #f) (struct? #f) (link? #f) (result? #f) (array #f) + (value #f) (default? #f)) + (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) + (case (and (pair? type) (car type)) + ((free) (lp (next) #t const? null-ptr? ptr? struct? link? result? array value default?)) + ((const) (lp (next) free? #t null-ptr? ptr? struct? link? result? array value default?)) + ((maybe-null) (lp (next) free? const? #t ptr? struct? link? result? array value default?)) + ((pointer) (lp (next) free? const? null-ptr? #t struct? link? result? array value default?)) + ((struct) (lp (next) free? const? null-ptr? ptr? #t link? result? array value default?)) + ((link) (lp (next) free? const? null-ptr? ptr? struct? #t result? array value default?)) + ((result) (lp (next) free? const? null-ptr? ptr? struct? link? #t array value default?)) + ((array) (lp (cadr type) free? const? null-ptr? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?)) + ((value) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) default?)) + ((default) (lp (cddr type) free? const? null-ptr? ptr? struct? link? result? array (cadr type) #t)) + (else (proc type free? const? null-ptr? ptr? struct? link? result? array value default? (and (pair? o) (car o))))))))) + +(define (parse-type type . o) + (with-parsed-type type make-type (and (pair? o) (car o)))) +(define (maybe-parse-type type) + (if (vector? type) type (parse-type type))) + +(define (type-base type) (vector-ref (maybe-parse-type type) 0)) +(define (type-free type) (vector-ref (maybe-parse-type type) 1)) +(define (type-const type) (vector-ref (maybe-parse-type type) 2)) +(define (type-null? type) (vector-ref (maybe-parse-type type) 3)) +(define (type-pointer? type) (vector-ref (maybe-parse-type type) 4)) +(define (type-struct? type) (vector-ref (maybe-parse-type type) 5)) +(define (type-link? type) (vector-ref (maybe-parse-type type) 6)) +(define (type-result? type) (vector-ref (maybe-parse-type type) 7)) +(define (type-array type) (vector-ref (maybe-parse-type type) 8)) +(define (type-value type) (vector-ref (maybe-parse-type type) 9)) +(define (type-default? type) (vector-ref (maybe-parse-type type) 10)) +(define (type-index type) (vector-ref (maybe-parse-type type) 11)) + (define (cat . args) (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) @@ -125,27 +298,10 @@ funcs)) #f))) -(define (with-parsed-type type proc) - (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 (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? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((eq? type 'void) (cat "((" val "), SEXP_VOID)")) @@ -174,9 +330,9 @@ (define (scheme->c-converter type val) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond - ((eq? 'sexp type) + ((eq? type 'sexp) (cat val)) ((eq? type 'time_t) (cat "sexp_uint_value(sexp_unshift_epoch(" val "))")) @@ -200,7 +356,7 @@ (define (type-predicate type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((int-type? type) "sexp_exact_integerp") ((float-type? type) "sexp_flonump") @@ -210,7 +366,7 @@ (define (type-name type) (with-parsed-type type - (lambda (type free? const? null-ptr? pointer? struct? link? result?) + (lambda (type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((int-type? type) "integer") ((float-type? type) "flonum") @@ -219,19 +375,19 @@ (define (type-c-name type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (let ((struct? (assq base-type types))) (string-append (if const? "const " "") (if struct? "struct " "") (string-replace (symbol->string base-type) #\- #\space) (if struct? "*" "") - (if pointer? "*" "")))))) + (if ptr? "*" "")))))) (define (check-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat (type-predicate type) "(" arg ")")) @@ -252,7 +408,7 @@ (define (validate-type arg type) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type)) (cat @@ -289,6 +445,109 @@ (lp (cdr ls) (cons (car ls) res))) (reverse res)))) +(define (with-parsed-func func proc) + (let* ((ret-type (parse-type (cadr func))) + (scheme-name (if (pair? (caddr func)) (caaddr func) (caddr func))) + (c-name (if (pair? (caddr func)) + (cadr (caddr func)) + (mangle scheme-name)))) + (let lp ((ls (cadddr func)) + (i 0) + (results '()) + (c-args '()) + (s-args '())) + (cond + ((null? ls) + (proc scheme-name c-name ret-type + (reverse results) (reverse c-args) (reverse s-args))) + (else + (let ((type (parse-type (car ls) i))) + (cond + ((type-result? type) + (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) + ((type-value type) + (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) + (else + (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) + ))))))) + +(define (write-parameters args) + (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) + +(define (write-locals func) + (with-parsed-func func + (lambda (scheme-name c-name ret-type results c-args scheme-args) + (cat " sexp res;\n")))) + +(define (write-validators args) + (for-each + (lambda (a) + (validate-type (string-append "arg" (number->string (type-index arg))) a)) + args)) + +(define (write-temporaries func) + #f) + +(define (write-call ret-type c-name c-args) + (cat (if (eq? 'errno (type-base ret-type)) " err = " " res = ")) + (c->scheme-converter + ret-type + (lambda () + (cat c-name "(") + (for-each + (lambda (arg) + (if (> (type-index arg) 0) (cat ", ")) + (cond + ((type-result? arg) + (cat (if (or (type-pointer? result) (type-array result)) "" "&") + "tmp")) + ((type-value arg) + => (lambda (x) (write x))) + (else + (scheme->c-converter arg (string-append "arg" (type-index arg)))))) + c-args) + (cat ");\n")))) + +(define (write-result result) + (if (type-array (car result)) + (cat " sexp_gc_preserve1(ctx, res);\n" + " res = SEXP_NULL;\n" + " for (i=" (type-array (car result)) "-1; i>=0; i--) {\n" + " sexp_push(ctx, res, SEXP_VOID);\n" + " sexp_car(res) = " + (lambda () (c->scheme-converter (car result) "tmp[i]")) ";\n" + " }\n" + " sexp_gc_release1(ctx);\n") + (c->scheme-converter (car result) "tmp"))) + +(define (write-results ret-type results) + (if (eq? 'errno (type-base ret-type)) + (cat " if (err) {\n" + " res = SEXP_FALSE;\n" + " } else {\n")) + (if (null? results) + (cat " res = SEXP_TRUE;\n") + (for-each write-result results)) + (if (eq? 'errno (type-base ret-type)) + (cat " }\n"))) + +(define (write-cleanup func) + #f) + +(define (write-func func) + (with-parsed-func func + (lambda (scheme-name c-name ret-type results c-args scheme-args) + (cat "static sexp " scheme-name + "(sexp ctx" (write-parameters scheme-args) ") {\n" + (write-locals func) + (write-validators scheme-args) + (write-temporaries func) + (write-call ret-type c-name c-args) + (write-result ret-type results) + (write-cleanup func) + " return res;\n" + "}\n\n")))) + (define (write-func func) (let ((ret-type (cadr func)) (result (get-func-result func)) @@ -298,9 +557,19 @@ (cond ((pair? ls) (cat ", sexp arg" i) (lp (cdr ls) (+ i 1))))) - (cat ") {\n sexp res;\n") + (cat ") {\n " + (if (and result (type-array result)) "sexp_gc_var1(res)" "sexp res") + ";\n") (if (eq? 'errno ret-type) (cat " int err;\n")) - (if result (cat " " (type-c-name result) " tmp;\n")) + (if (type-array result) (cat " int i;\n")) + (if result + (cat " " (type-c-name result) (if (type-pointer? result) "*" "") + " tmp" + (if (type-array result) + (with-output-to-string + (lambda () (cat "[" (type-array result) "]"))) + "") + ";\n")) (let lp ((ls args) (i 0)) (cond ((pair? ls) (validate-type (string-append "arg" (number->string i)) (car ls)) @@ -314,7 +583,11 @@ (cond ((pair? ls) (cat (cond ((eq? (car ls) result) - "&tmp") + (lambda () (cat (if (or (type-pointer? result) + (type-array result)) + "" + "&") + "tmp"))) ((and (pair? (car ls)) (memq 'value (car ls))) => (lambda (x) (write (cadr x)) "")) (else @@ -328,9 +601,22 @@ (cat ";\n") (if (eq? 'errno ret-type) (if result - (cat " res = (err ? SEXP_FALSE : " - (lambda () (c->scheme-converter result "tmp")) - ");\n") + (if (type-array result) + (cat " if (err) {\n" + " res = SEXP_FALSE;\n" + " } else {\n" + " sexp_gc_preserve1(ctx, res);\n" + " res = SEXP_NULL;\n" + " for (i=" (type-array result) "-1; i>=0; i--) {\n" + " sexp_push(ctx, res, SEXP_VOID);\n" + " sexp_car(res) = " + (lambda () (c->scheme-converter result "tmp[i]")) ";\n" + " }\n" + " sexp_gc_release1(ctx);\n" + " }\n") + (cat " res = (err ? SEXP_FALSE : " + (lambda () (c->scheme-converter result "tmp")) + ");\n")) (cat " res = sexp_make_boolean(! err);\n"))) (cat " return res;\n" "}\n\n"))) @@ -345,7 +631,7 @@ (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" " " (type-id-name name) " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, " @@ -364,12 +650,12 @@ (define (type-getter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_get_" (x->string (get-base-type (cadr field))))) + "_get_" (x->string (type-base (cadr field))))) (define (write-type-getter type name field) (with-parsed-type (car field) - (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat "static sexp " (type-getter-name type name field) " (sexp ctx, sexp x) {\n" (lambda () (validate-type "x" name)) @@ -387,12 +673,12 @@ (define (type-setter-name type name field) (string-append "sexp_" (x->string (type-name name)) - "_set_" (x->string (get-base-type (car field))))) + "_set_" (x->string (type-base (car field))))) (define (write-type-setter type name field) (with-parsed-type (car field) - (lambda (field-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (field-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cat "static sexp " (type-setter-name type name field) " (sexp ctx, sexp x, sexp v) {\n" (lambda () (validate-type "x" name)) @@ -413,7 +699,7 @@ (type (cdr type))) (with-parsed-type type - (lambda (base-type free? const? null-ptr? pointer? struct? link? result?) + (lambda (base-type free? const? null-ptr? ptr? struct? link? result? array value default? i) (cond ((memq 'finalizer: base-type) => (lambda (x)