fix #314
This commit is contained in:
Yuichi Nishiwaki
parent
fc9ec5bd4d
commit
7a128aab3b
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue