diff --git a/eval.c b/eval.c index 52a30dec..87fc7e91 100644 --- a/eval.c +++ b/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), diff --git a/init.scm b/init.scm index eb78c704..027dac98 100644 --- a/init.scm +++ b/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 diff --git a/syntax-rules.scm b/syntax-rules.scm index 687b5384..2433718e 100644 --- a/syntax-rules.scm +++ b/syntax-rules.scm @@ -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)