From 7a128aab3b8d5f3691ddc3737526139868d2ed46 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 7 Feb 2016 04:23:46 +0900 Subject: [PATCH] fix #314 --- contrib/20.r7rs/scheme/eval.scm | 24 ++++--- contrib/20.r7rs/scheme/r5rs.scm | 4 +- contrib/60.repl/repl.scm | 8 +-- contrib/70.main/main.scm | 2 +- extlib/benz/boot.c | 121 +++++++++++++++----------------- extlib/benz/eval.c | 27 ++++--- extlib/benz/include/picrin.h | 2 +- extlib/benz/load.c | 2 +- extlib/benz/macro.c | 3 +- 9 files changed, 98 insertions(+), 95 deletions(-) diff --git a/contrib/20.r7rs/scheme/eval.scm b/contrib/20.r7rs/scheme/eval.scm index b93764cd..7ffa7c5c 100644 --- a/contrib/20.r7rs/scheme/eval.scm +++ b/contrib/20.r7rs/scheme/eval.scm @@ -1,15 +1,19 @@ (define-library (scheme eval) (import (picrin base)) - (define environment - (let ((counter 0)) - (lambda specs - (let ((library-name `(picrin @@my-environment ,(string->symbol (number->string counter))))) - (set! counter (+ counter 1)) - (eval - `(define-library ,library-name - ,@(map (lambda (spec) `(import ,spec)) specs)) - (library-environment (find-library '(scheme base)))) - (library-environment (find-library library-name)))))) + (define counter 0) + + (define-syntax (inc! n) + #`(set! #,n (+ #,n 1))) + + (define (number->symbol n) + (string->symbol (number->string n))) + + (define (environment specs) + (let ((library-name `(picrin @@my-environment ,(number->symbol counter)))) + (inc! counter) + (let ((lib (make-library library-name))) + (eval `(import ,@specs) lib) + lib))) (export environment eval)) diff --git a/contrib/20.r7rs/scheme/r5rs.scm b/contrib/20.r7rs/scheme/r5rs.scm index 9e2c3b78..7d557027 100644 --- a/contrib/20.r7rs/scheme/r5rs.scm +++ b/contrib/20.r7rs/scheme/r5rs.scm @@ -28,12 +28,12 @@ (define (null-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - (library-environment (find-library '(scheme null))))) + (find-library '(scheme null)))) (define (scheme-report-environment n) (if (not (= n 5)) (error "unsupported environment version" n) - (library-environment (find-library '(scheme r5rs))))) + (find-library '(scheme r5rs)))) (export * + - / < <= = > >= abs acos and diff --git a/contrib/60.repl/repl.scm b/contrib/60.repl/repl.scm index 2c8bad42..e0b72d81 100644 --- a/contrib/60.repl/repl.scm +++ b/contrib/60.repl/repl.scm @@ -19,10 +19,7 @@ (define (add-history str) #f)))) - (define user-env (library-environment (find-library '(picrin user)))) - (define (init-env) - (current-library (find-library '(picrin user))) (eval '(import (scheme base) (scheme load) @@ -35,8 +32,7 @@ (scheme lazy) (scheme time) (picrin macro)) - user-env) - (current-library (find-library '(picrin repl)))) + (find-library '(picrin user)))) (define (repl) (init-env) @@ -67,7 +63,7 @@ (lambda (port) (let next ((expr (read port))) (unless (eof-object? expr) - (write (eval expr user-env)) + (write (eval expr (find-library '(picrin user)))) (newline) (set! str "") (next (read port)))))))))) diff --git a/contrib/70.main/main.scm b/contrib/70.main/main.scm index 35ecd522..f0e48e9c 100644 --- a/contrib/70.main/main.scm +++ b/contrib/70.main/main.scm @@ -41,7 +41,7 @@ (lambda (in) (let loop ((expr (read in))) (unless (eof-object? expr) - (eval expr (library-environment (find-library '(picrin user)))) + (eval expr (find-library '(picrin user))) (loop (read in))))))) (define (main) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index cf2e6652..a134987a 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -546,12 +546,8 @@ my $src = <<'EOL'; (lambda (form _) (let ((name (cadr form)) (body (cddr form))) - (let ((old-library (current-library)) - (new-library (or (find-library name) (make-library name)))) - (let ((env (library-environment new-library))) - (current-library new-library) - (for-each (lambda (expr) (eval expr env)) body) - (current-library old-library)))))) + (let ((new-library (or (find-library name) (make-library name)))) + (for-each (lambda (expr) (eval expr new-library)) body))))) (define-macro cond-expand (lambda (form _) @@ -953,64 +949,61 @@ const char pic_boot[][80] = { "ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma", "cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n", "\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l", -"et ((name (cadr form))\n (body (cddr form)))\n (let ((old-library (c", -"urrent-library))\n (new-library (or (find-library name) (make-library ", -"name))))\n (let ((env (library-environment new-library)))\n (curre", -"nt-library new-library)\n (for-each (lambda (expr) (eval expr env)) body", -")\n (current-library old-library))))))\n\n(define-macro cond-expand\n (lam", -"bda (form _)\n (letrec\n ((test (lambda (form)\n (or\n ", -" (eq? form 'else)\n (and (symbol? form)\n ", -" (memq form (features)))\n (and (pair? form)\n ", -" (case (car form)\n ((library) (find-librar", -"y (cadr form)))\n ((not) (not (test (cadr form))))\n ", -" ((and) (let loop ((form (cdr form)))\n ", -" (or (null? form)\n (and (test (car", -" form)) (loop (cdr form))))))\n ((or) (let loop ((form (c", -"dr form)))\n (and (pair? form)\n ", -" (or (test (car form)) (loop (cdr form))))))\n ", -" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (nul", -"l? clauses)\n #undefined\n (if (test (caar clauses))\n ", -" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))", -"))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda ", -"(x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", -" (string->symbol\n (string-append\n (symbol-", -">string prefix)\n (symbol->string symbol))))))\n (letrec\n ", -" ((extract\n (lambda (spec)\n (case (car spec)\n ", -" ((only rename prefix except)\n (extract (cadr spec)))\n ", -" (else\n (or (find-library spec) (error \"library not ", -"found\" spec))))))\n (collect\n (lambda (spec)\n (", -"case (car spec)\n ((only)\n (let ((alist (collect (", -"cadr spec))))\n (map (lambda (var) (assq var alist)) (cddr spec", -"))))\n ((rename)\n (let ((alist (collect (cadr spec", -")))\n (renames (map (lambda (x) `((car x) . (cadr x))) (cdd", -"r spec))))\n (map (lambda (s) (or (assq (car s) renames) s)) al", -"ist)))\n ((prefix)\n (let ((alist (collect (cadr sp", -"ec))))\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (", -"cdr s))) alist)))\n ((except)\n (let ((alist (colle", -"ct (cadr spec))))\n (let loop ((alist alist))\n ", -" (if (null? alist)\n '()\n (if ", -"(memq (caar alist) (cddr spec))\n (loop (cdr alist))\n", -" (cons (car alist) (loop (cdr alist))))))))\n ", -" (else\n (let ((lib (or (find-library spec) (error \"librar", -"y not found\" spec))))\n (map (lambda (x) (cons x x)) (library-e", -"xports lib))))))))\n (letrec\n ((import\n (lambda (", -"spec)\n (let ((lib (extract spec))\n (alist ", -"(collect spec)))\n (for-each\n (lambda (slot)", -"\n (library-import lib (cdr slot) (car slot)))\n ", -" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro exp", -"ort\n (lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", -" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", -" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", -" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ", -" (error \"malformed export\")))))\n (export\n (lambda (spec)\n", -" (let ((slot (collect spec)))\n (library-export (car sl", -"ot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda", -" quote set! if begin define-macro\n let let* letrec letrec*\n let-va", -"lues let*-values define-values\n quasiquote unquote unquote-splicing\n ", -" and or\n cond case else =>\n do when unless\n parameterize\n", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiqu", -"ote syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-erro", -"r)\n\n\n", +"et ((name (cadr form))\n (body (cddr form)))\n (let ((new-library (o", +"r (find-library name) (make-library name))))\n (for-each (lambda (expr) (e", +"val expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (form _)\n ", +" (letrec\n ((test (lambda (form)\n (or\n ", +"(eq? form 'else)\n (and (symbol? form)\n (m", +"emq form (features)))\n (and (pair? form)\n ", +" (case (car form)\n ((library) (find-library (cadr form))", +")\n ((not) (not (test (cadr form))))\n ", +" ((and) (let loop ((form (cdr form)))\n (or ", +"(null? form)\n (and (test (car form)) (loop ", +"(cdr form))))))\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n ", +" (or (test (car form)) (loop (cdr form))))))\n (else", +" #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", +" #undefined\n (if (test (caar clauses))\n `(,th", +"e-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-ma", +"cro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr ", +"(cdr x)))))\n (prefix\n (lambda (prefix symbol)\n (s", +"tring->symbol\n (string-append\n (symbol->string prefix", +")\n (symbol->string symbol))))))\n (letrec\n ((extract\n", +" (lambda (spec)\n (case (car spec)\n ((only", +" rename prefix except)\n (extract (cadr spec)))\n (", +"else\n (or (find-library spec) (error \"library not found\" spec)))", +")))\n (collect\n (lambda (spec)\n (case (car spec", +")\n ((only)\n (let ((alist (collect (cadr spec))))\n", +" (map (lambda (var) (assq var alist)) (cddr spec))))\n ", +" ((rename)\n (let ((alist (collect (cadr spec)))\n ", +" (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", +" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ", +" ((prefix)\n (let ((alist (collect (cadr spec))))\n ", +" (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist", +")))\n ((except)\n (let ((alist (collect (cadr spec)", +")))\n (let loop ((alist alist))\n (if (null?", +" alist)\n '()\n (if (memq (caar al", +"ist) (cddr spec))\n (loop (cdr alist))\n ", +" (cons (car alist) (loop (cdr alist))))))))\n (else\n", +" (let ((lib (or (find-library spec) (error \"library not found\" s", +"pec))))\n (map (lambda (x) (cons x x)) (library-exports lib))))", +"))))\n (letrec\n ((import\n (lambda (spec)\n ", +" (let ((lib (extract spec))\n (alist (collect spec)", +"))\n (for-each\n (lambda (slot)\n ", +" (library-import lib (cdr slot) (car slot)))\n alist))", +")))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (lambda ", +"(form _)\n (letrec\n ((collect\n (lambda (spec)\n (con", +"d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an", +"d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l", +"ist-ref spec 1) . ,(list-ref spec 2)))\n (else\n (error \"", +"malformed export\")))))\n (export\n (lambda (spec)\n (", +"let ((slot (collect spec)))\n (library-export (car slot) (cdr slot)", +")))))\n (for-each export (cdr form)))))\n\n(export define lambda quote set! if", +" begin define-macro\n let let* letrec letrec*\n let-values let*-valu", +"es define-values\n quasiquote unquote unquote-splicing\n and or\n ", +" cond case else =>\n do when unless\n parameterize\n define", +"-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax-unq", +"uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index c00d13d3..892f58ea 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -828,7 +828,7 @@ pic_codegen(pic_state *pic, pic_value obj) #define SAVE(pic, ai, obj) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, obj) -static struct pic_proc * +struct pic_proc * pic_compile(pic_state *pic, pic_value obj) { struct pic_irep *irep; @@ -887,25 +887,34 @@ pic_compile(pic_state *pic, pic_value obj) } pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_env *env) +pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) { - struct pic_proc *proc; + pic_value r; - proc = pic_compile(pic, pic_expand(pic, program, env)); + pic_try { + pic->prev_lib = pic->lib; + pic->lib = lib; - return pic_apply0(pic, proc); + r = pic_apply0(pic, pic_compile(pic, pic_expand(pic, program, lib->env))); + } + pic_catch { + pic->lib = pic->prev_lib; + pic_raise(pic, pic->err); + } + + return r; } static pic_value pic_eval_eval(pic_state *pic) { - pic_value program, env; + pic_value program, lib; - pic_get_args(pic, "oo", &program, &env); + pic_get_args(pic, "oo", &program, &lib); - pic_assert_type(pic, env, env); + pic_assert_type(pic, lib, lib); - return pic_eval(pic, program, pic_env_ptr(env)); + return pic_eval(pic, program, pic_lib_ptr(lib)); } void diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index 5659da65..cef5dbcf 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -193,7 +193,7 @@ pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v pic_value pic_apply_list(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, int, pic_value *); pic_value pic_apply_trampoline_list(pic_state *, struct pic_proc *, pic_value); -pic_value pic_eval(pic_state *, pic_value, struct pic_env *); +pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); diff --git a/extlib/benz/load.c b/extlib/benz/load.c index 32e6f152..e07b70d3 100644 --- a/extlib/benz/load.c +++ b/extlib/benz/load.c @@ -11,7 +11,7 @@ pic_load(pic_state *pic, struct pic_port *port) size_t ai = pic_gc_arena_preserve(pic); while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib->env); + pic_eval(pic, form, pic->lib); pic_gc_arena_restore(pic, ai); } diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 10420d58..70de7872 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -261,6 +261,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def static pic_value expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) { + struct pic_proc *pic_compile(pic_state *, pic_value); pic_id *id; pic_value val; pic_sym *uid; @@ -270,7 +271,7 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) uid = pic_add_identifier(pic, id, env); } - val = pic_eval(pic, pic_list_ref(pic, expr, 2), env); + val = pic_apply0(pic, pic_compile(pic, pic_expand(pic, pic_list_ref(pic, expr, 2), env))); if (! pic_proc_p(val)) { pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id)); }