From 449800c11785866bf15516c9266d644aff3f7d93 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 31 Mar 2017 14:39:01 +0900 Subject: [PATCH] add pic->dyn_env --- lib/boot.c | 178 +++++++++++++++++++++---------------------- lib/cont.c | 37 ++++----- lib/error.c | 171 +++++++++++++++++------------------------ lib/ext/load.c | 1 - lib/gc.c | 3 + lib/include/picrin.h | 14 ++-- lib/object.h | 5 +- lib/state.c | 7 +- lib/state.h | 2 + lib/var.c | 78 ++++++++----------- piclib/boot.scm | 8 +- 11 files changed, 230 insertions(+), 274 deletions(-) diff --git a/lib/boot.c b/lib/boot.c index d08b545c..5ed90dc3 100644 --- a/lib/boot.c +++ b/lib/boot.c @@ -122,95 +122,95 @@ static const char boot_rom[][80] = { "entifier=? (the '=>) (make-identifier (cadr clause) env))) `(,(car (cdr (cdr cla", "use))) ,the-key) `(,the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (d", "efine-macro parameterize (lambda (form env) (let ((formal (car (cdr form))) (bod", -"y (cdr (cdr form)))) (if (null? formal) `(,the-begin ,@body) (let ((bind (car fo", -"rmal))) `(,(the 'dynamic-bind) ,(car bind) ,(cadr bind) (,the-lambda () (,(the '", -"parameterize) ,(cdr formal) ,@body)))))))) (define-macro syntax-quote (lambda (f", -"orm env) (let ((renames '())) (letrec ((rename (lambda (var) (let ((x (assq var ", -"renames))) (if x (cadr x) (begin (set! renames `((,var ,(make-identifier var env", -") (,(the 'make-identifier) ',var ',env)) unquote renames)) (rename var)))))) (wa", -"lk (lambda (f form) (cond ((identifier? form) (f form)) ((pair? form) `(,(the 'c", -"ons) (walk f (car form)) (walk f (cdr form)))) ((vector? form) `(,(the 'list->ve", -"ctor) (walk f (vector->list form)))) (else `(,(the 'quote) ,form)))))) (let ((fo", -"rm (walk rename (cadr form)))) `(,(the 'let) ,(map cdr renames) ,form)))))) (def", -"ine-macro syntax-quasiquote (lambda (form env) (let ((renames '())) (letrec ((re", -"name (lambda (var) (let ((x (assq var renames))) (if x (cadr x) (begin (set! ren", -"ames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) u", -"nquote renames)) (rename var))))))) (define (syntax-quasiquote? form) (and (pair", -"? form) (identifier? (car form)) (identifier=? (the 'syntax-quasiquote) (make-id", -"entifier (car form) env)))) (define (syntax-unquote? form) (and (pair? form) (id", -"entifier? (car form)) (identifier=? (the 'syntax-unquote) (make-identifier (car ", -"form) env)))) (define (syntax-unquote-splicing? form) (and (pair? form) (pair? (", -"car form)) (identifier? (caar form)) (identifier=? (the 'syntax-unquote-splicing", -") (make-identifier (caar form) env)))) (define (qq depth expr) (cond ((syntax-un", -"quote? expr) (if (= depth 1) (car (cdr expr)) (list (the 'list) (list (the 'quot", -"e) (the 'syntax-unquote)) (qq (- depth 1) (car (cdr expr)))))) ((syntax-unquote-", -"splicing? expr) (if (= depth 1) (list (the 'append) (car (cdr (car expr))) (qq d", -"epth (cdr expr))) (list (the 'cons) (list (the 'list) (list (the 'quote) (the 's", -"yntax-unquote-splicing)) (qq (- depth 1) (car (cdr (car expr))))) (qq depth (cdr", -" expr))))) ((syntax-quasiquote? expr) (list (the 'list) (list (the 'quote) (the ", -"'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pair? expr) (list (the 'cons", -") (qq depth (car expr)) (qq depth (cdr expr)))) ((vector? expr) (list (the 'list", -"->vector) (qq depth (vector->list expr)))) ((identifier? expr) (rename expr)) (e", -"lse (list (the 'quote) expr)))) (let ((body (qq 1 (cadr form)))) `(,(the 'let) ,", -"(map cdr renames) ,body)))))) (define (transformer f) (lambda (form env) (let ((", -"ephemeron1 (make-ephemeron)) (ephemeron2 (make-ephemeron))) (letrec ((wrap (lamb", -"da (var1) (let ((var2 (ephemeron1 var1))) (if var2 (cdr var2) (let ((var2 (make-", -"identifier var1 env))) (ephemeron1 var1 var2) (ephemeron2 var2 var1) var2))))) (", -"unwrap (lambda (var2) (let ((var1 (ephemeron2 var2))) (if var1 (cdr var1) var2))", -")) (walk (lambda (f form) (cond ((identifier? form) (f form)) ((pair? form) (con", -"s (walk f (car form)) (walk f (cdr form)))) ((vector? form) (list->vector (walk ", -"f (vector->list form)))) (else form))))) (let ((form (cdr form))) (walk unwrap (", -"apply f (walk wrap form)))))))) (define-macro define-syntax (lambda (form env) (", -"let ((formal (car (cdr form))) (body (cdr (cdr form)))) (if (pair? formal) `(,(t", -"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) `(,the-defi", -"ne-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) (define-macro le", -"trec-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr f", -"orm)))) `(let () ,@(map (lambda (x) `(,(the 'define-syntax) ,(car x) ,(cadr x)))", -" formal) ,@body)))) (define-macro let-syntax (lambda (form env) `(,(the 'letrec-", -"syntax) ,@(cdr form)))) (define (mangle name) (when (null? name) (error \"library", -" name should be a list of at least one symbols\" name)) (define (->string n) (con", -"d ((symbol? n) (let ((str (symbol->string n))) (string-for-each (lambda (c) (whe", -"n (or (char=? c #\\.) (char=? c #\\/)) (error \"elements of library name may not co", -"ntain '.' or '/'\" n))) str) str)) ((and (number? n) (exact? n)) (number->string ", -"n)) (else (error \"symbol or integer is required\" n)))) (define (join strs delim)", -" (let loop ((res (car strs)) (strs (cdr strs))) (if (null? strs) res (loop (stri", -"ng-append res delim (car strs)) (cdr strs))))) (join (map ->string name) \".\")) (", -"define-macro define-library (lambda (form _) (let ((lib (mangle (cadr form))) (b", -"ody (cddr form))) (or (find-library lib) (make-library lib)) (for-each (lambda (", -"expr) (eval expr lib)) body)))) (define-macro cond-expand (lambda (form _) (letr", -"ec ((test (lambda (form) (or (eq? form 'else) (and (symbol? form) (memq form (fe", -"atures))) (and (pair? form) (case (car form) ((library) (find-library (mangle (c", -"adr form)))) ((not) (not (test (cadr form)))) ((and) (let loop ((form (cdr form)", -")) (or (null? form) (and (test (car form)) (loop (cdr form)))))) ((or) (let loop", -" ((form (cdr form))) (and (pair? form) (or (test (car form)) (loop (cdr form))))", -")) (else #f))))))) (let loop ((clauses (cdr form))) (if (null? clauses) #undefin", -"ed (if (test (caar clauses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses))", -")))))) (define-macro import (lambda (form _) (let ((caddr (lambda (x) (car (cdr ", -"(cdr x))))) (prefix (lambda (prefix symbol) (string->symbol (string-append (symb", -"ol->string prefix) (symbol->string symbol))))) (getlib (lambda (name) (let ((lib", -" (mangle name))) (if (find-library lib) lib (error \"library not found\" name)))))", -") (letrec ((extract (lambda (spec) (case (car spec) ((only rename prefix except)", -" (extract (cadr spec))) (else (getlib spec))))) (collect (lambda (spec) (case (c", -"ar spec) ((only) (let ((alist (collect (cadr spec)))) (map (lambda (var) (assq v", -"ar alist)) (cddr spec)))) ((rename) (let ((alist (collect (cadr spec))) (renames", -" (map (lambda (x) `((car x) cadr x)) (cddr spec)))) (map (lambda (s) (or (assq (", -"car s) renames) s)) alist))) ((prefix) (let ((alist (collect (cadr spec)))) (map", -" (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist))) ((except) (l", -"et ((alist (collect (cadr spec)))) (let loop ((alist alist)) (if (null? alist) '", -"() (if (memq (caar alist) (cddr spec)) (loop (cdr alist)) (cons (car alist) (loo", -"p (cdr alist)))))))) (else (map (lambda (x) (cons x x)) (library-exports (getlib", -" spec)))))))) (letrec ((import (lambda (spec) (let ((lib (extract spec)) (alist ", -"(collect spec))) (for-each (lambda (slot) (library-import lib (cdr slot) (car sl", -"ot))) alist))))) (for-each import (cdr form))))))) (define-macro export (lambda ", -"(form _) (letrec ((collect (lambda (spec) (cond ((symbol? spec) `(,spec unquote ", -"spec)) ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) `(,(list", -"-ref spec 1) unquote (list-ref spec 2))) (else (error \"malformed export\"))))) (e", -"xport (lambda (spec) (let ((slot (collect spec))) (library-export (car slot) (cd", -"r slot)))))) (for-each export (cdr form))))) (export define lambda quote set! if", -" begin define-macro let let* letrec letrec* let-values let*-values define-values", -" quasiquote unquote unquote-splicing and or cond case else => do when unless par", -"ameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote syntax-unq", -"uote-splicing let-syntax letrec-syntax syntax-error) ", +"y (cdr (cdr form)))) `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (la", +"mbda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))", +") (define-macro syntax-quote (lambda (form env) (let ((renames '())) (letrec ((r", +"ename (lambda (var) (let ((x (assq var renames))) (if x (cadr x) (begin (set! re", +"names `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) ", +"unquote renames)) (rename var)))))) (walk (lambda (f form) (cond ((identifier? f", +"orm) (f form)) ((pair? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr for", +"m)))) ((vector? form) `(,(the 'list->vector) (walk f (vector->list form)))) (els", +"e `(,(the 'quote) ,form)))))) (let ((form (walk rename (cadr form)))) `(,(the 'l", +"et) ,(map cdr renames) ,form)))))) (define-macro syntax-quasiquote (lambda (form", +" env) (let ((renames '())) (letrec ((rename (lambda (var) (let ((x (assq var ren", +"ames))) (if x (cadr x) (begin (set! renames `((,var ,(make-identifier var env) (", +",(the 'make-identifier) ',var ',env)) unquote renames)) (rename var))))))) (defi", +"ne (syntax-quasiquote? form) (and (pair? form) (identifier? (car form)) (identif", +"ier=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) (define (synt", +"ax-unquote? form) (and (pair? form) (identifier? (car form)) (identifier=? (the ", +"'syntax-unquote) (make-identifier (car form) env)))) (define (syntax-unquote-spl", +"icing? form) (and (pair? form) (pair? (car form)) (identifier? (caar form)) (ide", +"ntifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) (d", +"efine (qq depth expr) (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr ex", +"pr)) (list (the 'list) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1)", +" (car (cdr expr)))))) ((syntax-unquote-splicing? expr) (if (= depth 1) (list (th", +"e 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (list (the 'cons) (list", +" (the 'list) (list (the 'quote) (the 'syntax-unquote-splicing)) (qq (- depth 1) ", +"(car (cdr (car expr))))) (qq depth (cdr expr))))) ((syntax-quasiquote? expr) (li", +"st (the 'list) (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr e", +"xpr))))) ((pair? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr ex", +"pr)))) ((vector? expr) (list (the 'list->vector) (qq depth (vector->list expr)))", +") ((identifier? expr) (rename expr)) (else (list (the 'quote) expr)))) (let ((bo", +"dy (qq 1 (cadr form)))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (tr", +"ansformer f) (lambda (form env) (let ((ephemeron1 (make-ephemeron)) (ephemeron2 ", +"(make-ephemeron))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1)))", +" (if var2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 v", +"ar2) (ephemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (epheme", +"ron2 var2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identif", +"ier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form))", +")) ((vector? form) (list->vector (walk f (vector->list form)))) (else form))))) ", +"(let ((form (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-m", +"acro define-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr", +" (cdr form)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-la", +"mbda ,(cdr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,t", +"he-begin ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((for", +"mal (car (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(t", +"he 'define-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syn", +"tax (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle n", +"ame) (when (null? name) (error \"library name should be a list of at least one sy", +"mbols\" name)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string", +" n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\/)) (err", +"or \"elements of library name may not contain '.' or '/'\" n))) str) str)) ((and (", +"number? n) (exact? n)) (number->string n)) (else (error \"symbol or integer is re", +"quired\" n)))) (define (join strs delim) (let loop ((res (car strs)) (strs (cdr s", +"trs))) (if (null? strs) res (loop (string-append res delim (car strs)) (cdr strs", +"))))) (join (map ->string name) \".\")) (define-macro define-library (lambda (form", +" _) (let ((lib (mangle (cadr form))) (body (cddr form))) (or (find-library lib) ", +"(make-library lib)) (for-each (lambda (expr) (eval expr lib)) body)))) (define-m", +"acro cond-expand (lambda (form _) (letrec ((test (lambda (form) (or (eq? form 'e", +"lse) (and (symbol? form) (memq form (features))) (and (pair? form) (case (car fo", +"rm) ((library) (find-library (mangle (cadr form)))) ((not) (not (test (cadr form", +")))) ((and) (let loop ((form (cdr form))) (or (null? form) (and (test (car form)", +") (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (and (pair? form) (o", +"r (test (car form)) (loop (cdr form)))))) (else #f))))))) (let loop ((clauses (c", +"dr form))) (if (null? clauses) #undefined (if (test (caar clauses)) `(,the-begin", +" ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (lambda (form", +" _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (prefix symbo", +"l) (string->symbol (string-append (symbol->string prefix) (symbol->string symbol", +"))))) (getlib (lambda (name) (let ((lib (mangle name))) (if (find-library lib) l", +"ib (error \"library not found\" name)))))) (letrec ((extract (lambda (spec) (case ", +"(car spec) ((only rename prefix except) (extract (cadr spec))) (else (getlib spe", +"c))))) (collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (c", +"adr spec)))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ", +"((alist (collect (cadr spec))) (renames (map (lambda (x) `((car x) cadr x)) (cdd", +"r spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix) (l", +"et ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec) (", +"car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (let l", +"oop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec)) (l", +"oop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (map (lambda (", +"x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((import (lambda (s", +"pec) (let ((lib (extract spec)) (alist (collect spec))) (for-each (lambda (slot)", +" (library-import lib (cdr slot) (car slot))) alist))))) (for-each import (cdr fo", +"rm))))))) (define-macro export (lambda (form _) (letrec ((collect (lambda (spec)", +" (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= (length spec", +") 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-ref spec 2))) ", +"(else (error \"malformed export\"))))) (export (lambda (spec) (let ((slot (collect", +" spec))) (library-export (car slot) (cdr slot)))))) (for-each export (cdr form))", +"))) (export define lambda quote set! if begin define-macro let let* letrec letre", +"c* let-values let*-values define-values quasiquote unquote unquote-splicing and ", +"or cond case else => do when unless parameterize define-syntax syntax-quote synt", +"ax-unquote syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax sy", +"ntax-error) ", }; void diff --git a/lib/cont.c b/lib/cont.c index d319e62a..2b6fb1f7 100644 --- a/lib/cont.c +++ b/lib/cont.c @@ -14,6 +14,7 @@ struct cont { ptrdiff_t ci_offset; size_t arena_idx; const struct code *ip; + pic_value dyn_env; int retc; pic_value *retv; @@ -23,6 +24,22 @@ struct cont { static const pic_data_type cont_type = { "cont", NULL }; +static void +do_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + do_wind(pic, here, there->prev); + pic_call(pic, obj_value(pic, there->in), 0); + } + else { + pic_call(pic, obj_value(pic, here->out), 0); + do_wind(pic, here->prev, there); + } +} + void pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) { @@ -33,6 +50,7 @@ pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) cont->sp_offset = pic->sp - pic->stbase; cont->ci_offset = pic->ci - pic->cibase; cont->arena_idx = pic->arena_idx; + cont->dyn_env = pic->dyn_env; cont->ip = pic->ip; cont->prev = pic->cc; cont->retc = 0; @@ -44,13 +62,14 @@ pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) void pic_load_point(pic_state *pic, struct cont *cont) { - pic_wind(pic, pic->cp, cont->cp); + do_wind(pic, pic->cp, cont->cp); /* load runtime context */ pic->cp = cont->cp; pic->sp = pic->stbase + cont->sp_offset; pic->ci = pic->cibase + cont->ci_offset; pic->arena_idx = cont->arena_idx; + pic->dyn_env = cont->dyn_env; pic->ip = cont->ip; pic->cc = cont->prev; } @@ -61,22 +80,6 @@ pic_exit_point(pic_state *pic) pic->cc = pic->cc->prev; } -void -pic_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there) -{ - if (here == there) - return; - - if (here->depth < there->depth) { - pic_wind(pic, here, there->prev); - pic_call(pic, obj_value(pic, there->in), 0); - } - else { - pic_call(pic, obj_value(pic, here->out), 0); - pic_wind(pic, here->prev, there); - } -} - pic_value pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out) { diff --git a/lib/error.c b/lib/error.c index 69afdf8f..ee045714 100644 --- a/lib/error.c +++ b/lib/error.c @@ -12,9 +12,7 @@ pic_panic(pic_state *pic, const char *msg) if (pic->panicf) { pic->panicf(pic, msg); } - PIC_ABORT(pic); - PIC_UNREACHABLE(); } @@ -27,7 +25,6 @@ pic_warnf(pic_state *pic, const char *fmt, ...) va_start(ap, fmt); err = pic_vstrf_value(pic, fmt, ap); va_end(ap); - pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL)); } @@ -45,29 +42,12 @@ native_exception_handler(pic_state *pic) PIC_UNREACHABLE(); } -static pic_value -dynamic_set(pic_state *pic) -{ - pic_value var, val; - - pic_get_args(pic, ""); - - var = pic_closure_ref(pic, 0); - val = pic_closure_ref(pic, 1); - - pic_proc_ptr(pic, var)->locals[0] = val; - - return pic_undef_value(pic); -} - -pic_value +void pic_start_try(pic_state *pic, PIC_JMPBUF *jmp) { struct cont *cont; pic_value handler; - pic_value var, old_val, new_val; - pic_value in, out; - struct checkpoint *here; + pic_value var, env; /* call/cc */ @@ -78,35 +58,15 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp) /* with-exception-handler */ var = pic_ref(pic, "picrin.base", "current-exception-handlers"); - old_val = pic_call(pic, var, 0); - new_val = pic_cons(pic, handler, old_val); - - in = pic_lambda(pic, dynamic_set, 2, var, new_val); - out = pic_lambda(pic, dynamic_set, 2, var, old_val); - - /* dynamic-wind */ - - pic_call(pic, in, 0); /* enter */ - - here = pic->cp; - pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); - pic->cp->prev = here; - pic->cp->depth = here->depth + 1; - pic->cp->in = pic_proc_ptr(pic, in); - pic->cp->out = pic_proc_ptr(pic, out); - - return pic_cons(pic, obj_value(pic, here), out); + env = pic_make_weak(pic); + pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0))); + pic->dyn_env = pic_cons(pic, env, pic->dyn_env); } void -pic_end_try(pic_state *pic, pic_value cookie) +pic_end_try(pic_state *pic) { - struct checkpoint *here = pic_cp_ptr(pic, pic_car(pic, cookie)); - pic_value out = pic_cdr(pic, cookie); - - pic->cp = here; - - pic_call(pic, out, 0); /* exit */ + pic->dyn_env = pic_cdr(pic, pic->dyn_env); pic_exit_point(pic); } @@ -134,7 +94,61 @@ pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs return obj_value(pic, e); } -pic_value pic_raise_continuable(pic_state *, pic_value err); +static pic_value +with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk) +{ + pic_value alist, var = pic_ref(pic, "picrin.base", "current-exception-handlers"); + alist = pic_list(pic, 1, pic_cons(pic, var, handlers)); + return pic_funcall(pic, "picrin.base", "with-dynamic-environment", 2, alist, thunk); +} + +static pic_value +on_raise(pic_state *pic) +{ + pic_value handler, err, val; + bool continuable; + + pic_get_args(pic, ""); + + handler = pic_closure_ref(pic, 0); + err = pic_closure_ref(pic, 1); + continuable = pic_bool(pic, pic_closure_ref(pic, 2)); + + val = pic_call(pic, handler, 1, err); + if (! continuable) { + pic_error(pic, "handler returned", 2, handler, err); + } + return val; +} + +pic_value +pic_raise_continuable(pic_state *pic, pic_value err) +{ + pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk; + + handlers = pic_call(pic, var, 0); + + if (pic_nil_p(pic, handlers)) { + pic_panic(pic, "no exception handler"); + } + thunk = pic_lambda(pic, on_raise, 3, pic_car(pic, handlers), err, pic_true_value(pic)); + return with_exception_handlers(pic, pic_cdr(pic, handlers), thunk); +} + +void +pic_raise(pic_state *pic, pic_value err) +{ + pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk; + + handlers = pic_call(pic, var, 0); + + if (pic_nil_p(pic, handlers)) { + pic_panic(pic, "no exception handler"); + } + thunk = pic_lambda(pic, on_raise, 3, pic_car(pic, handlers), err, pic_false_value(pic)); + with_exception_handlers(pic, pic_cdr(pic, handlers), thunk); + PIC_UNREACHABLE(); +} void pic_error(pic_state *pic, const char *msg, int n, ...) @@ -145,69 +159,20 @@ pic_error(pic_state *pic, const char *msg, int n, ...) va_start(ap, n); irrs = pic_vlist(pic, n, ap); va_end(ap); - pic_raise(pic, pic_make_error(pic, "", msg, irrs)); } -static pic_value -raise_action(pic_state *pic) -{ - pic_get_args(pic, ""); - - pic_call(pic, pic_closure_ref(pic, 0), 1, pic_closure_ref(pic, 1)); - - pic_error(pic, "handler returned", 2, pic_closure_ref(pic, 0), pic_closure_ref(pic, 1)); -} - -void -pic_raise(pic_state *pic, pic_value err) -{ - pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); - - stack = pic_call(pic, exc, 0); - - if (pic_nil_p(pic, stack)) { - pic_panic(pic, "no exception handler"); - } - - pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise_action, 2, pic_car(pic, stack), err)); - - PIC_UNREACHABLE(); -} - -static pic_value -raise_continuable(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic_call(pic, pic_closure_ref(pic, 0), 1, pic_closure_ref(pic, 1)); -} - -pic_value -pic_raise_continuable(pic_state *pic, pic_value err) -{ - pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); - - stack = pic_call(pic, exc, 0); - - if (pic_nil_p(pic, stack)) { - pic_panic(pic, "no exception handler"); - } - - return pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise_continuable, 2, pic_car(pic, stack), err)); -} - static pic_value pic_error_with_exception_handler(pic_state *pic) { pic_value handler, thunk; - pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); + pic_value handlers, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); pic_get_args(pic, "ll", &handler, &thunk); - stack = pic_call(pic, exc, 0); + handlers = pic_call(pic, exc, 0); - return pic_dynamic_bind(pic, exc, pic_cons(pic, handler, stack), thunk); + return with_exception_handlers(pic, pic_cons(pic, handler, handlers), thunk); } static pic_value @@ -233,13 +198,13 @@ pic_error_raise_continuable(pic_state *pic) static pic_value pic_error_error(pic_state *pic) { - const char *str; + const char *cstr; int argc; pic_value *argv; - pic_get_args(pic, "z*", &str, &argc, &argv); + pic_get_args(pic, "z*", &cstr, &argc, &argv); - pic_raise(pic, pic_make_error(pic, "", str, pic_make_list(pic, argc, argv))); + pic_raise(pic, pic_make_error(pic, "", cstr, pic_make_list(pic, argc, argv))); } static pic_value diff --git a/lib/ext/load.c b/lib/ext/load.c index 352ade17..885a49b3 100644 --- a/lib/ext/load.c +++ b/lib/ext/load.c @@ -13,7 +13,6 @@ pic_load(pic_state *pic, pic_value port) while (! pic_eof_p(pic, form = pic_read(pic, port))) { pic_eval(pic, form, pic_current_library(pic)); - pic_leave(pic, ai); } } diff --git a/lib/gc.c b/lib/gc.c index 5c2b29b1..3ebd4af2 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -499,6 +499,9 @@ gc_mark_phase(pic_state *pic) /* error object */ gc_mark(pic, pic->err); + /* dynamic environment */ + gc_mark(pic, pic->dyn_env); + /* features */ gc_mark(pic, pic->features); diff --git a/lib/include/picrin.h b/lib/include/picrin.h index 199ce0ef..d7b4444d 100644 --- a/lib/include/picrin.h +++ b/lib/include/picrin.h @@ -294,23 +294,23 @@ int pic_fgetbuf(pic_state *, pic_value port, const char **buf, int *len); /* dep typedef void (*pic_panicf)(pic_state *, const char *msg); pic_panicf pic_atpanic(pic_state *, pic_panicf f); PIC_NORETURN void pic_panic(pic_state *, const char *msg); -PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...); +pic_value pic_raise_continuable(pic_state *pic, pic_value err); PIC_NORETURN void pic_raise(pic_state *, pic_value v); -pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); /* deprecated */ +PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...); +pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); pic_value pic_get_backtrace(pic_state *); /* deprecated */ -void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */ #define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp)) #define pic_try_(cont, jmp) \ do { \ - extern pic_value pic_start_try(pic_state *, PIC_JMPBUF *); \ - extern void pic_end_try(pic_state *, pic_value); \ + extern void pic_start_try(pic_state *, PIC_JMPBUF *); \ + extern void pic_end_try(pic_state *); \ extern pic_value pic_err(pic_state *); \ PIC_JMPBUF jmp; \ if (PIC_SETJMP(pic, jmp) == 0) { \ - pic_value pic_try_cookie_ = pic_start_try(pic, &jmp); + pic_start_try(pic, &jmp); #define pic_catch(e) pic_catch_(e, PIC_GENSYM(label)) #define pic_catch_(e, label) \ - pic_end_try(pic, pic_try_cookie_); \ + pic_end_try(pic); \ } else { \ e = pic_err(pic); \ goto label; \ diff --git a/lib/object.h b/lib/object.h index 830387f2..4493d903 100644 --- a/lib/object.h +++ b/lib/object.h @@ -300,13 +300,12 @@ struct cont *pic_alloca_cont(pic_state *); pic_value pic_make_cont(pic_state *, struct cont *); void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *); void pic_exit_point(pic_state *); -void pic_wind(pic_state *, struct checkpoint *, struct checkpoint *); pic_value pic_dynamic_wind(pic_state *, pic_value in, pic_value thunk, pic_value out); -pic_value pic_dynamic_bind(pic_state *, pic_value var, pic_value val, pic_value thunk); - pic_value pic_library_environment(pic_state *, const char *); +void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */ + #if defined(__cplusplus) } #endif diff --git a/lib/state.c b/lib/state.c index 45163e9e..aebad456 100644 --- a/lib/state.c +++ b/lib/state.c @@ -227,6 +227,9 @@ pic_open(pic_allocf allocf, void *userdata) /* features */ pic->features = pic_nil_value(pic); + /* dynamic environment */ + pic->dyn_env = pic_invalid_value(pic); + /* libraries */ kh_init(ltable, &pic->ltable); pic->lib = NULL; @@ -238,6 +241,7 @@ pic_open(pic_allocf allocf, void *userdata) /* root tables */ pic->globals = pic_make_weak(pic); pic->macros = pic_make_weak(pic); + pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic)); /* root block */ pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); @@ -281,7 +285,8 @@ pic_close(pic_state *pic) pic->err = pic_invalid_value(pic); pic->globals = pic_invalid_value(pic); pic->macros = pic_invalid_value(pic); - pic->features = pic_nil_value(pic); + pic->features = pic_invalid_value(pic); + pic->dyn_env = pic_invalid_value(pic); /* free all libraries */ kh_clear(ltable, &pic->ltable); diff --git a/lib/state.h b/lib/state.h index 03e1d31f..36d6cfe0 100644 --- a/lib/state.h +++ b/lib/state.h @@ -47,6 +47,8 @@ struct pic_state { const struct code *ip; + pic_value dyn_env; + const char *lib; pic_value features; diff --git a/lib/var.c b/lib/var.c index 7d392cd7..8cfabe96 100644 --- a/lib/var.c +++ b/lib/var.c @@ -6,14 +6,7 @@ #include "object.h" #include "state.h" -static pic_value -var_conv(pic_state *pic, pic_value val, pic_value conv) -{ - if (! pic_false_p(pic, conv)) { - val = pic_call(pic, conv, 1, val); - } - return val; -} +/* implementated by deep binding */ static pic_value var_call(pic_state *pic) @@ -24,11 +17,22 @@ var_call(pic_state *pic) n = pic_get_args(pic, "&|o", &self, &val); if (n == 0) { - return pic_closure_ref(pic, 0); + pic_value env, it; + + pic_for_each(env, pic->dyn_env, it) { + if (pic_weak_has(pic, env, self)) { + return pic_weak_ref(pic, env, self); + } + } + PIC_UNREACHABLE(); /* logic flaw */ } else { + pic_value conv; - pic_closure_set(pic, 0, var_conv(pic, val, pic_closure_ref(pic, 1))); - + conv = pic_closure_ref(pic, 0); + if (! pic_false_p(pic, conv)) { + val = pic_call(pic, conv, 1, val); + } + pic_weak_set(pic, pic_car(pic, pic->dyn_env), self, val); return pic_undef_value(pic); } } @@ -36,36 +40,11 @@ var_call(pic_state *pic) pic_value pic_make_var(pic_state *pic, pic_value init, pic_value conv) { - return pic_lambda(pic, var_call, 2, var_conv(pic, init, conv), conv); -} + pic_value var; -static pic_value -dynamic_set(pic_state *pic) -{ - pic_value var, val; - - pic_get_args(pic, ""); - - var = pic_closure_ref(pic, 0); - val = pic_closure_ref(pic, 1); - - pic_proc_ptr(pic, var)->locals[0] = val; - - return pic_undef_value(pic); -} - -pic_value -pic_dynamic_bind(pic_state *pic, pic_value var, pic_value val, pic_value thunk) -{ - pic_value in, out, new_val, old_val; - - old_val = pic_call(pic, var, 0); - new_val = var_conv(pic, val, pic_proc_ptr(pic, var)->locals[1]); - - in = pic_lambda(pic, dynamic_set, 2, var, new_val); - out = pic_lambda(pic, dynamic_set, 2, var, old_val); - - return pic_dynamic_wind(pic, in, thunk, out); + var = pic_lambda(pic, var_call, 1, conv); + pic_call(pic, var, 1, init); + return var; } static pic_value @@ -79,22 +58,25 @@ pic_var_make_parameter(pic_state *pic) } static pic_value -pic_var_dynamic_bind(pic_state *pic) +pic_var_with_dynamic_environment(pic_state *pic) { - pic_value var, val, thunk; + pic_value alist, thunk, env, it, elt, val; - pic_get_args(pic, "lol", &var, &val, &thunk); + pic_get_args(pic, "ol", &alist, &thunk); - if (! (pic_proc_p(pic, var) && pic_proc_ptr(pic, var)->u.f.func == var_call)) { - pic_error(pic, "parameter required", 1, var); + env = pic_make_weak(pic); + pic_for_each(elt, alist, it) { + pic_weak_set(pic, env, pic_car(pic, elt), pic_cdr(pic, elt)); } - - return pic_dynamic_bind(pic, var, val, thunk); + pic->dyn_env = pic_cons(pic, env, pic->dyn_env); + val = pic_call(pic, thunk, 0); + pic->dyn_env = pic_cdr(pic, pic->dyn_env); + return val; } void pic_init_var(pic_state *pic) { pic_defun(pic, "make-parameter", pic_var_make_parameter); - pic_defun(pic, "dynamic-bind", pic_var_dynamic_bind); + pic_defun(pic, "with-dynamic-environment", pic_var_with_dynamic_environment); } diff --git a/piclib/boot.scm b/piclib/boot.scm index 69689837..03f533b7 100644 --- a/piclib/boot.scm +++ b/piclib/boot.scm @@ -372,11 +372,9 @@ (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr form)))) - (if (null? formal) - `(,the-begin ,@body) - (let ((bind (car formal))) - `(,(the 'dynamic-bind) ,(car bind) ,(cadr bind) - (,the-lambda () (,(the 'parameterize) ,(cdr formal) ,@body)))))))) + `(,(the 'with-dynamic-environment) + (,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal)) + (,the-lambda () ,@body))))) (define-macro syntax-quote (lambda (form env)