mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
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.
This commit is contained in:
Alex Shinn
parent
55aeef42e7
commit
b7fd7ab7f5
5 changed files with 74 additions and 64 deletions
45
eval.c
45
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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
59
lib/meta.scm
59
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"))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue