From b7fd7ab7f5d0b5566cd38202cd98613c6e7d96df Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 Nov 2011 21:09:03 +0900 Subject: [PATCH] Removing old *meta-env* hack - `import' is now copied from (meta) and runs directly without eval. Syntax may now also be bound with (define-syntax macro1 macro2), and likewise with let-syntax. --- eval.c | 45 ++++++++++++++++++++--------------- lib/chibi/repl.scm | 6 ++--- lib/chibi/repl.sld | 2 +- lib/init-7.scm | 26 -------------------- lib/meta.scm | 59 +++++++++++++++++++++++++++++++++++----------- 5 files changed, 74 insertions(+), 64 deletions(-) diff --git a/eval.c b/eval.c index 89d52fa7..1739e8bb 100644 --- a/eval.c +++ b/eval.c @@ -746,29 +746,33 @@ static sexp analyze_define (sexp ctx, sexp x) { static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp res = SEXP_VOID, name; - sexp_gc_var2(proc, mac); - sexp_gc_preserve2(eval_ctx, proc, mac); + sexp_gc_var1(mac); + sexp_gc_preserve1(eval_ctx, mac); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) && sexp_nullp(sexp_cddar(ls)))) { res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); } else { - proc = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); - if (sexp_procedurep(proc)) { - name = sexp_caar(ls); - if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) - name = sexp_synclo_expr(name); - mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); - sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls)); - sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); - } else { - res = (sexp_exceptionp(proc) ? proc - : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + if (sexp_idp(sexp_cadar(ls))) + mac = sexp_env_ref(sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE); + else + mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(mac)) { + mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(bind_ctx)); + } else if (!(sexp_macrop(mac)||sexp_corep(mac))) { + res = (sexp_exceptionp(mac) ? mac + : sexp_compile_error(eval_ctx, "non-procedure macro", mac)); break; } + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls))) + sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); } } - sexp_gc_release2(eval_ctx); + sexp_gc_release1(eval_ctx); return res; } @@ -1953,9 +1957,8 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); /* load and bind config env */ #if SEXP_USE_MODULES - if (! sexp_exceptionp(tmp)) { - sym = sexp_intern(ctx, "*meta-env*", -1); - if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) { + if (!sexp_exceptionp(tmp)) { + if (!sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) { tmp = sexp_make_env(ctx); if (! sexp_exceptionp(tmp)) { sexp_global(ctx, SEXP_G_META_ENV) = tmp; @@ -1963,10 +1966,14 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { op = sexp_load_module_file(ctx, sexp_meta_file, tmp); if (sexp_exceptionp(op)) sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); - sexp_env_define(ctx, tmp, sym, tmp); } } - sexp_env_define(ctx, e, sym, tmp); + if (!sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "repl-import", -1); + tmp = sexp_env_ref(tmp, sym, SEXP_VOID); + sym = sexp_intern(ctx, "import", -1); + sexp_env_define(ctx, e, sym, tmp); + } } #endif sexp_gc_release3(ctx); diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm index 40b80025..669c4811 100644 --- a/lib/chibi/repl.scm +++ b/lib/chibi/repl.scm @@ -77,9 +77,7 @@ (module (cond ((memq 'module: o) => cadr) (else #f))) (env (if module (module-env - (if (module? module) - module - (eval `(load-module ',module) *meta-env*))) + (if (module? module) module (load-module module))) (interaction-environment))) (history-file (cond ((memq 'history-file: o) => cadr) @@ -95,7 +93,7 @@ (raw? (cond ((memq 'raw?: o) => cadr) (else (member (get-environment-variable "TERM") '("emacs" "dumb")))))) - (let lp ((module module) (env env) (meta-env *meta-env*)) + (let lp ((module module) (env env) (meta-env (load-module '(meta)))) (let* ((prompt (string-append (if module (write-to-string module) "") "> ")) (line diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld index a0f24e87..8a983350 100644 --- a/lib/chibi/repl.sld +++ b/lib/chibi/repl.sld @@ -1,7 +1,7 @@ (define-library (chibi repl) (export repl) - (import (scheme) + (import (scheme) (only (meta) load-module) (chibi ast) (chibi io) (chibi process) (chibi term edit-line) (srfi 18) (srfi 38) (srfi 98)) (include "repl.scm")) diff --git a/lib/init-7.scm b/lib/init-7.scm index 8c9dcf02..b95ada8c 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -846,32 +846,6 @@ ((guard (var (test . handler) ...) body ...) (guard (var (test . handler) ... (else (raise var))) body ...)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; modules - -(define *meta-env* #f) - -(define-syntax import - (er-macro-transformer - (lambda (expr rename compare) - (let lp ((ls (cdr expr)) (res '())) - (cond - ((null? ls) - (cons 'begin (reverse res))) - (else - (let ((mod+imps (eval `(resolve-import ',(car ls)) *meta-env*))) - (if (pair? mod+imps) - (lp (cdr ls) - (cons `(%import - #f - (vector-ref - (eval '(load-module ',(car mod+imps)) *meta-env*) - 1) - ',(cdr mod+imps) - #f) - res)) - (error "couldn't find module" (car ls)))))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SRFI-0 diff --git a/lib/meta.scm b/lib/meta.scm index 5daaa596..c274a5a2 100644 --- a/lib/meta.scm +++ b/lib/meta.scm @@ -31,10 +31,12 @@ (define (module-name-prefix name) (string-concatenate (reverse (cdr (cdr (module-name->strings name '())))))) -(define (load-module-definition name) - (let* ((file (module-name->file name)) - (path (find-module-file file))) - (if path (load path *meta-env*)))) +(define load-module-definition + (let ((meta-env (current-environment))) + (lambda (name) + (let* ((file (module-name->file name)) + (path (find-module-file file))) + (if path (load path meta-env)))))) (define (find-module name) (cond @@ -154,8 +156,11 @@ (er-macro-transformer (lambda (expr rename compare) (let ((name (cadr expr)) - (body (cddr expr))) - `(let ((tmp *this-module*)) + (body (cddr expr)) + (tmp (rename 'tmp)) + (this-module (rename '*this-module*)) + (modules (rename '*modules*))) + `(let ((,tmp ,this-module)) (define (rewrite-export x) (if (pair? x) (if (and (= 3 (length x)) @@ -163,17 +168,17 @@ (cons (caddr x) (cadr x)) (error "invalid module export" x)) x)) - (set! *this-module* '()) + (set! ,this-module '()) ,@body - (set! *this-module* (reverse *this-module*)) + (set! ,this-module (reverse ,this-module)) (let ((exports - (cond ((assq 'export *this-module*) + (cond ((assq 'export ,this-module) => (lambda (x) (map rewrite-export (cdr x)))) (else '())))) - (set! *modules* - (cons (cons ',name (make-module exports #f *this-module*)) - *modules*))) - (set! *this-module* tmp)))))) + (set! ,modules + (cons (cons ',name (make-module exports #f ,this-module)) + ,modules))) + (set! ,this-module ,tmp)))))) (define-syntax define-library define-library-transformer) (define-syntax module define-library-transformer) @@ -184,8 +189,10 @@ `(define-syntax ,(cadr expr) (er-macro-transformer (lambda (expr rename compare) - `(set! *this-module* (cons ',expr *this-module*)))))))) + (let ((this-module (rename '*this-module*))) + `(set! ,this-module (cons ',expr ,this-module))))))))) +(define-syntax orig-begin begin) (define-config-primitive import) (define-config-primitive import-immutable) (define-config-primitive export) @@ -195,6 +202,30 @@ (define-config-primitive body) (define-config-primitive begin) +;; The `import' binding used by (scheme) and (scheme base), etc. +(define-syntax repl-import + (er-macro-transformer + (let ((meta-env (current-environment))) + (lambda (expr rename compare) + (let lp ((ls (cdr expr)) (res '())) + (cond + ((null? ls) + (cons (rename 'orig-begin) (reverse res))) + (else + (let ((mod+imps (resolve-import (car ls)))) + (cond + ((pair? mod+imps) + (lp (cdr ls) + (cons `(,(rename '%import) + #f + (,(rename 'module-env) + (,(rename 'load-module) ',(car mod+imps))) + ',(cdr mod+imps) + #f) + res))) + (else + (error "couldn't find module" (car ls)))))))))))) + (define *modules* (list (cons '(scheme) (make-module #f (interaction-environment) '((include "init.scm"))))