mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
adding import-immutable to minimize heap usage
This commit is contained in:
Alex Shinn
parent
c895db6c48
commit
ffdce3639b
29 changed files with 491 additions and 178 deletions
2
Makefile
2
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)
|
||||
|
|
|
|||
104
eval.c
104
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))
|
||||
if (sexp_truep(cell)) {
|
||||
if (sexp_immutablep(cell))
|
||||
res = sexp_type_exception(ctx, "immutable binding", key);
|
||||
else
|
||||
sexp_cdr(cell) = value;
|
||||
else {
|
||||
} 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)) {
|
||||
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))) {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
(define-module (chibi macroexpand)
|
||||
(import (scheme))
|
||||
(import-immutable (scheme))
|
||||
(import (chibi ast))
|
||||
(export macroexpand)
|
||||
(include "macroexpand.scm"))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 '()))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(import-immutable (scheme)
|
||||
(srfi 9))
|
||||
(include "uri.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>=? char-ci=? 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>=? string-ci<? 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))))
|
||||
(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)))))))
|
||||
(list (list 'export 'cond-expand))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(define-module (srfi 16)
|
||||
(export case-lambda)
|
||||
(import (scheme))
|
||||
(import-immutable (scheme))
|
||||
(body
|
||||
(define-syntax %case
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(define-module (srfi 2)
|
||||
(export and-let*)
|
||||
(import (scheme))
|
||||
(import-immutable (scheme))
|
||||
(body
|
||||
(define-syntax and-let*
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(define-module (srfi 26)
|
||||
(export cut cute)
|
||||
(import (scheme))
|
||||
(import-immutable (scheme))
|
||||
(body
|
||||
(define-syntax %cut
|
||||
(syntax-rules (<> <...>)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(define-module (srfi 6)
|
||||
(export open-input-string open-output-string get-output-string)
|
||||
(import (scheme)))
|
||||
(import-immutable (scheme)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(define-module (srfi 8)
|
||||
(export receive)
|
||||
(import (scheme))
|
||||
(import-immutable (scheme))
|
||||
(body
|
||||
(define-syntax receive
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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),
|
||||
|
|
|
|||
|
|
@ -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 <expr>): specify a fixed value
|
||||
;; * as an input parameter, this parameter is not provided
|
||||
;; in the Scheme API but always passed as <expr>
|
||||
;;
|
||||
;; (default <expr>): specify a default value
|
||||
;; * as the final input parameter, makes the Scheme parameter
|
||||
;; optional, defaulting to <expr>
|
||||
;;
|
||||
;; (array <type> [<length>]) 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
|
||||
(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")
|
||||
");\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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue