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

adding flatten-dot and update-free-vars

Browse source
This commit is contained in:
Alex Shinn 2011-07-04 22:04:40 +09:00
parent 90ae6f49b8
commit 60c304cbb8
3 changed files with 12 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
lib/chibi/ast.c
View file

@ -303,6 +303,10 @@ static sexp sexp_error_string (sexp ctx sexp_api_params(self, n), sexp x) {
return sexp_c_string(ctx, strerror(err), -1);
}
static sexp sexp_update_free_vars (sexp ctx sexp_api_params(self, n), sexp x) {
return sexp_free_vars(ctx, x, SEXP_NULL);
}
#define sexp_define_type(ctx, name, tag) \
sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag));
@ -409,5 +413,6 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op);
sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains);
sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE);
sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars);
return SEXP_VOID;
}

3
lib/chibi/ast.module
View file

@ -32,7 +32,8 @@
port-line port-line-set!
type-name type-cpl type-parent type-slots
object-size integer->immediate gc
string-contains integer->error-string)
string-contains integer->error-string
flatten-dot update-free-vars!)
(import (scheme))
(include-shared "ast")
(include "ast.scm"))

9
lib/chibi/ast.scm
View file

@ -50,10 +50,6 @@
(lp2 (cdr ls2) found?))
(else
(lp2 (cdr ls2) found?)))))))))
(define (flatten-dot x)
(cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
((null? x) x)
(else (list x))))
(define (extend-env lam env)
(cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
(let lp ((x ast) (env '()))
@ -66,6 +62,11 @@
((pair? x) (for-each (lambda (x) (lp x env)) x))))
renames)
(define (flatten-dot x)
(cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
((null? x) x)
(else (list x))))
(define (get-rename id lam renames)
(let ((ls (assq lam renames)))
(if (not ls)