mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
let-syntax and letrec-syntax
This commit is contained in:
Alex Shinn
parent
7130f38e76
commit
4736dcaa6d
3 changed files with 53 additions and 24 deletions
60
eval.c
60
eval.c
|
|
@ -427,6 +427,8 @@ static sexp analyze_define (sexp x, sexp context) {
|
|||
|
||||
static sexp analyze_define_syntax (sexp x, sexp context) {
|
||||
sexp name = sexp_cadr(x), cell, proc;
|
||||
if (sexp_env_parent(sexp_context_env(context)))
|
||||
return sexp_compile_error("non-top-level define-syntax", sexp_list1(x));
|
||||
proc = eval_in_context(sexp_caddr(x), context);
|
||||
analyze_check_exception(proc);
|
||||
cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF);
|
||||
|
|
@ -434,6 +436,36 @@ static sexp analyze_define_syntax (sexp x, sexp context) {
|
|||
return SEXP_UNDEF;
|
||||
}
|
||||
|
||||
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
|
||||
sexp proc;
|
||||
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
|
||||
proc = eval_in_context(sexp_cadar(ls), eval_ctx);
|
||||
analyze_check_exception(proc);
|
||||
sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)),
|
||||
sexp_cons(sexp_caar(ls),
|
||||
sexp_make_macro(proc, sexp_context_env(eval_ctx))));
|
||||
}
|
||||
return SEXP_UNDEF;
|
||||
}
|
||||
|
||||
static sexp analyze_let_syntax (sexp x, sexp context) {
|
||||
sexp env, ctx, tmp;
|
||||
env = sexp_alloc_type(env, SEXP_ENV);
|
||||
sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context));
|
||||
sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context));
|
||||
ctx = sexp_child_context(context, sexp_context_lambda(context));
|
||||
sexp_context_env(ctx) = env;
|
||||
tmp = analyze_bind_syntax(sexp_cadr(x), ctx, context);
|
||||
analyze_check_exception(tmp);
|
||||
return analyze_seq(sexp_cddr(x), ctx);
|
||||
}
|
||||
|
||||
static sexp analyze_letrec_syntax (sexp x, sexp context) {
|
||||
sexp tmp = analyze_bind_syntax(sexp_cadr(x), context, context);
|
||||
analyze_check_exception(tmp);
|
||||
return analyze_seq(sexp_cddr(x), context);
|
||||
}
|
||||
|
||||
static sexp analyze (sexp x, sexp context) {
|
||||
sexp op, cell, res;
|
||||
loop:
|
||||
|
|
@ -451,29 +483,25 @@ static sexp analyze (sexp x, sexp context) {
|
|||
if (sexp_corep(op)) {
|
||||
switch (sexp_core_code(op)) {
|
||||
case CORE_DEFINE:
|
||||
res = analyze_define(x, context);
|
||||
break;
|
||||
res = analyze_define(x, context); break;
|
||||
case CORE_SET:
|
||||
res = analyze_set(x, context);
|
||||
break;
|
||||
res = analyze_set(x, context); break;
|
||||
case CORE_LAMBDA:
|
||||
res = analyze_lambda(x, context);
|
||||
break;
|
||||
res = analyze_lambda(x, context); break;
|
||||
case CORE_IF:
|
||||
res = analyze_if(x, context);
|
||||
break;
|
||||
res = analyze_if(x, context); break;
|
||||
case CORE_BEGIN:
|
||||
res = analyze_seq(x, context);
|
||||
break;
|
||||
res = analyze_seq(x, context); break;
|
||||
case CORE_QUOTE:
|
||||
res = sexp_make_lit(sexp_cadr(x));
|
||||
break;
|
||||
res = sexp_make_lit(sexp_cadr(x)); break;
|
||||
case CORE_DEFINE_SYNTAX:
|
||||
res = analyze_define_syntax(x, context);
|
||||
break;
|
||||
res = analyze_define_syntax(x, context); break;
|
||||
case CORE_LET_SYNTAX:
|
||||
res = analyze_let_syntax(x, context); break;
|
||||
case CORE_LETREC_SYNTAX:
|
||||
res = analyze_letrec_syntax(x, context); break;
|
||||
default:
|
||||
res = sexp_compile_error("unknown core form", sexp_list1(op));
|
||||
break;
|
||||
res = sexp_compile_error("unknown core form", sexp_list1(op)); break;
|
||||
}
|
||||
} else if (sexp_macrop(op)) {
|
||||
x = apply(sexp_macro_proc(op),
|
||||
|
|
|
|||
2
init.scm
2
init.scm
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
;; let-syntax letrec-syntax syntax-rules
|
||||
;; syntax-rules
|
||||
;; number->string string->number
|
||||
;; symbol->string string->symbol
|
||||
;; with-input-from-file with-output-to-file
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
((ellipse? p)
|
||||
(cond
|
||||
((not (null? (cddr p)))
|
||||
(error "non-trailing ellipse" p))
|
||||
(error "non-trailing ellipse"))
|
||||
((symbol? (car p))
|
||||
(list _and (list _list? v)
|
||||
(list _let (list (list (car p) v))
|
||||
|
|
@ -130,7 +130,7 @@
|
|||
=> (lambda (cell)
|
||||
(if (<= (cdr cell) dim)
|
||||
t
|
||||
(error "too few ...'s for" t tmpl))))
|
||||
(error "too few ...'s"))))
|
||||
(else
|
||||
(list _rename (list _quote t)))))
|
||||
((pair? t)
|
||||
|
|
@ -139,7 +139,7 @@
|
|||
(ell-dim (+ dim depth))
|
||||
(ell-vars (free-vars (car t) vars ell-dim)))
|
||||
(if (null? ell-vars)
|
||||
(error "too many ...'s" tmpl t)
|
||||
(error "too many ...'s")
|
||||
(let* ((once (lp (car t) ell-dim))
|
||||
(nest (if (and (null? (cdr ell-vars))
|
||||
(symbol? once)
|
||||
|
|
@ -164,10 +164,11 @@
|
|||
(list _lambda (list _expr _rename _compare)
|
||||
(cons
|
||||
_or
|
||||
(map
|
||||
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
|
||||
forms)
|
||||
(error "no expansion for" _expr))))))))
|
||||
(append
|
||||
(map
|
||||
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
|
||||
forms)
|
||||
(list (list 'else) (list 'error "no expansion"))))))))))
|
||||
|
||||
;; Local Variables:
|
||||
;; eval: (put '_lambda 'scheme-indent-function 1)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue