conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fix #314

This commit is contained in:
Yuichi Nishiwaki 2016-02-07 04:23:46 +09:00
parent fc9ec5bd4d
commit 7a128aab3b
9 changed files with 98 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
contrib/20.r7rs/scheme/eval.scm
View File

@ -1,15 +1,19 @@
(define-library (scheme eval) (define-library (scheme eval)
(import (picrin base)) (import (picrin base))
(define environment (define counter 0)
(let ((counter 0))
(lambda specs (define-syntax (inc! n)
(let ((library-name `(picrin @@my-environment ,(string->symbol (number->string counter))))) #`(set! #,n (+ #,n 1)))
(set! counter (+ counter 1))
(eval (define (number->symbol n)
`(define-library ,library-name (string->symbol (number->string n)))
,@(map (lambda (spec) `(import ,spec)) specs))
(library-environment (find-library '(scheme base)))) (define (environment specs)
(library-environment (find-library library-name)))))) (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)) (export environment eval))

4
contrib/20.r7rs/scheme/r5rs.scm
View File

@ -28,12 +28,12 @@
(define (null-environment n) (define (null-environment n)
(if (not (= n 5)) (if (not (= n 5))
(error "unsupported environment version" n) (error "unsupported environment version" n)
(library-environment (find-library '(scheme null))))) (find-library '(scheme null))))
(define (scheme-report-environment n) (define (scheme-report-environment n)
(if (not (= n 5)) (if (not (= n 5))
(error "unsupported environment version" n) (error "unsupported environment version" n)
(library-environment (find-library '(scheme r5rs))))) (find-library '(scheme r5rs))))
(export * + - / < <= = > >= (export * + - / < <= = > >=
abs acos and abs acos and

8
contrib/60.repl/repl.scm
View File

@ -19,10 +19,7 @@
(define (add-history str) (define (add-history str)
#f)))) #f))))
(define user-env (library-environment (find-library '(picrin user))))
(define (init-env) (define (init-env)
(current-library (find-library '(picrin user)))
(eval (eval
'(import (scheme base) '(import (scheme base)
(scheme load) (scheme load)
@ -35,8 +32,7 @@
(scheme lazy) (scheme lazy)
(scheme time) (scheme time)
(picrin macro)) (picrin macro))
user-env) (find-library '(picrin user))))
(current-library (find-library '(picrin repl))))
(define (repl) (define (repl)
(init-env) (init-env)
@ -67,7 +63,7 @@
(lambda (port) (lambda (port)
(let next ((expr (read port))) (let next ((expr (read port)))
(unless (eof-object? expr) (unless (eof-object? expr)
(write (eval expr user-env)) (write (eval expr (find-library '(picrin user))))
(newline) (newline)
(set! str "") (set! str "")
(next (read port)))))))))) (next (read port))))))))))

2
contrib/70.main/main.scm
View File

@ -41,7 +41,7 @@
(lambda (in) (lambda (in)
(let loop ((expr (read in))) (let loop ((expr (read in)))
(unless (eof-object? expr) (unless (eof-object? expr)
(eval expr (library-environment (find-library '(picrin user)))) (eval expr (find-library '(picrin user)))
(loop (read in))))))) (loop (read in)))))))
(define (main) (define (main)

121
extlib/benz/boot.c
View File

@ -546,12 +546,8 @@ my $src = <<'EOL';
(lambda (form _) (lambda (form _)
(let ((name (cadr form)) (let ((name (cadr form))
(body (cddr form))) (body (cddr form)))
(let ((old-library (current-library)) (let ((new-library (or (find-library name) (make-library name))))
(new-library (or (find-library name) (make-library name)))) (for-each (lambda (expr) (eval expr new-library)) body)))))
(let ((env (library-environment new-library)))
(current-library new-library)
(for-each (lambda (expr) (eval expr env)) body)
(current-library old-library))))))
(define-macro cond-expand (define-macro cond-expand
(lambda (form _) (lambda (form _)
@ -953,64 +949,61 @@ const char pic_boot[][80] = {
"ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma", "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", "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", "\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", "et ((name (cadr form))\n (body (cddr form)))\n (let ((new-library (o",
"urrent-library))\n (new-library (or (find-library name) (make-library ", "r (find-library name) (make-library name))))\n (for-each (lambda (expr) (e",
"name))))\n (let ((env (library-environment new-library)))\n (curre", "val expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (form _)\n ",
"nt-library new-library)\n (for-each (lambda (expr) (eval expr env)) body", " (letrec\n ((test (lambda (form)\n (or\n ",
")\n (current-library old-library))))))\n\n(define-macro cond-expand\n (lam", "(eq? form 'else)\n (and (symbol? form)\n (m",
"bda (form _)\n (letrec\n ((test (lambda (form)\n (or\n ", "emq form (features)))\n (and (pair? form)\n ",
" (eq? form 'else)\n (and (symbol? form)\n ", " (case (car form)\n ((library) (find-library (cadr form))",
" (memq form (features)))\n (and (pair? form)\n ", ")\n ((not) (not (test (cadr form))))\n ",
" (case (car form)\n ((library) (find-librar", " ((and) (let loop ((form (cdr form)))\n (or ",
"y (cadr form)))\n ((not) (not (test (cadr form))))\n ", "(null? form)\n (and (test (car form)) (loop ",
" ((and) (let loop ((form (cdr form)))\n ", "(cdr form))))))\n ((or) (let loop ((form (cdr form)))\n ",
" (or (null? form)\n (and (test (car", " (and (pair? form)\n ",
" form)) (loop (cdr form))))))\n ((or) (let loop ((form (c", " (or (test (car form)) (loop (cdr form))))))\n (else",
"dr form)))\n (and (pair? form)\n ", " #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ",
" (or (test (car form)) (loop (cdr form))))))\n ", " #undefined\n (if (test (caar clauses))\n `(,th",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (nul", "e-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-ma",
"l? clauses)\n #undefined\n (if (test (caar clauses))\n ", "cro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr ",
" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))", "(cdr x)))))\n (prefix\n (lambda (prefix symbol)\n (s",
"))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda ", "tring->symbol\n (string-append\n (symbol->string prefix",
"(x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", ")\n (symbol->string symbol))))))\n (letrec\n ((extract\n",
" (string->symbol\n (string-append\n (symbol-", " (lambda (spec)\n (case (car spec)\n ((only",
">string prefix)\n (symbol->string symbol))))))\n (letrec\n ", " rename prefix except)\n (extract (cadr spec)))\n (",
" ((extract\n (lambda (spec)\n (case (car spec)\n ", "else\n (or (find-library spec) (error \"library not found\" spec)))",
" ((only rename prefix except)\n (extract (cadr spec)))\n ", ")))\n (collect\n (lambda (spec)\n (case (car spec",
" (else\n (or (find-library spec) (error \"library not ", ")\n ((only)\n (let ((alist (collect (cadr spec))))\n",
"found\" spec))))))\n (collect\n (lambda (spec)\n (", " (map (lambda (var) (assq var alist)) (cddr spec))))\n ",
"case (car spec)\n ((only)\n (let ((alist (collect (", " ((rename)\n (let ((alist (collect (cadr spec)))\n ",
"cadr spec))))\n (map (lambda (var) (assq var alist)) (cddr spec", " (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ",
"))))\n ((rename)\n (let ((alist (collect (cadr spec", " (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ",
")))\n (renames (map (lambda (x) `((car x) . (cadr x))) (cdd", " ((prefix)\n (let ((alist (collect (cadr spec))))\n ",
"r spec))))\n (map (lambda (s) (or (assq (car s) renames) s)) al", " (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist",
"ist)))\n ((prefix)\n (let ((alist (collect (cadr sp", ")))\n ((except)\n (let ((alist (collect (cadr spec)",
"ec))))\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (", ")))\n (let loop ((alist alist))\n (if (null?",
"cdr s))) alist)))\n ((except)\n (let ((alist (colle", " alist)\n '()\n (if (memq (caar al",
"ct (cadr spec))))\n (let loop ((alist alist))\n ", "ist) (cddr spec))\n (loop (cdr alist))\n ",
" (if (null? alist)\n '()\n (if ", " (cons (car alist) (loop (cdr alist))))))))\n (else\n",
"(memq (caar alist) (cddr spec))\n (loop (cdr alist))\n", " (let ((lib (or (find-library spec) (error \"library not found\" s",
" (cons (car alist) (loop (cdr alist))))))))\n ", "pec))))\n (map (lambda (x) (cons x x)) (library-exports lib))))",
" (else\n (let ((lib (or (find-library spec) (error \"librar", "))))\n (letrec\n ((import\n (lambda (spec)\n ",
"y not found\" spec))))\n (map (lambda (x) (cons x x)) (library-e", " (let ((lib (extract spec))\n (alist (collect spec)",
"xports lib))))))))\n (letrec\n ((import\n (lambda (", "))\n (for-each\n (lambda (slot)\n ",
"spec)\n (let ((lib (extract spec))\n (alist ", " (library-import lib (cdr slot) (car slot)))\n alist))",
"(collect spec)))\n (for-each\n (lambda (slot)", ")))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (lambda ",
"\n (library-import lib (cdr slot) (car slot)))\n ", "(form _)\n (letrec\n ((collect\n (lambda (spec)\n (con",
" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro exp", "d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an",
"ort\n (lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", "d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l",
" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", "ist-ref spec 1) . ,(list-ref spec 2)))\n (else\n (error \"",
" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", "malformed export\")))))\n (export\n (lambda (spec)\n (",
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ", "let ((slot (collect spec)))\n (library-export (car slot) (cdr slot)",
" (error \"malformed export\")))))\n (export\n (lambda (spec)\n", ")))))\n (for-each export (cdr form)))))\n\n(export define lambda quote set! if",
" (let ((slot (collect spec)))\n (library-export (car sl", " begin define-macro\n let let* letrec letrec*\n let-values let*-valu",
"ot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda", "es define-values\n quasiquote unquote unquote-splicing\n and or\n ",
" quote set! if begin define-macro\n let let* letrec letrec*\n let-va", " cond case else =>\n do when unless\n parameterize\n define",
"lues let*-values define-values\n quasiquote unquote unquote-splicing\n ", "-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax-unq",
" and or\n cond case else =>\n do when unless\n parameterize\n", "uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\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",
"", "",
"" ""
}; };

27
extlib/benz/eval.c
View File

@ -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) #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) pic_compile(pic_state *pic, pic_value obj)
{ {
struct pic_irep *irep; struct pic_irep *irep;
@ -887,25 +887,34 @@ pic_compile(pic_state *pic, pic_value obj)
} }
pic_value 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 static pic_value
pic_eval_eval(pic_state *pic) 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 void

2
extlib/benz/include/picrin.h
View File

@ -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_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(pic_state *, struct pic_proc *, int, pic_value *);
pic_value pic_apply_trampoline_list(pic_state *, struct pic_proc *, 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 *); struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);

2
extlib/benz/load.c
View File

@ -11,7 +11,7 @@ pic_load(pic_state *pic, struct pic_port *port)
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
while (! pic_eof_p(form = pic_read(pic, port))) { 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); pic_gc_arena_restore(pic, ai);
} }

3
extlib/benz/macro.c
View File

@ -261,6 +261,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def
static pic_value static pic_value
expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) 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_id *id;
pic_value val; pic_value val;
pic_sym *uid; 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); 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)) { if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id)); pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id));
} }