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

add pic->dyn_env

This commit is contained in:
Yuichi Nishiwaki 2017-03-31 14:39:01 +09:00
parent d478affabd
commit 449800c117
11 changed files with 230 additions and 274 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
lib/boot.c
View File

@ -122,95 +122,95 @@ static const char boot_rom[][80] = {
"entifier=? (the '=>) (make-identifier (cadr clause) env))) `(,(car (cdr (cdr cla", "entifier=? (the '=>) (make-identifier (cadr clause) env))) `(,(car (cdr (cdr cla",
"use))) ,the-key) `(,the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (d", "use))) ,the-key) `(,the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (d",
"efine-macro parameterize (lambda (form env) (let ((formal (car (cdr form))) (bod", "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", "y (cdr (cdr form)))) `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (la",
"rmal))) `(,(the 'dynamic-bind) ,(car bind) ,(cadr bind) (,the-lambda () (,(the '", "mbda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))",
"parameterize) ,(cdr formal) ,@body)))))))) (define-macro syntax-quote (lambda (f", ") (define-macro syntax-quote (lambda (form env) (let ((renames '())) (letrec ((r",
"orm env) (let ((renames '())) (letrec ((rename (lambda (var) (let ((x (assq var ", "ename (lambda (var) (let ((x (assq var renames))) (if x (cadr x) (begin (set! re",
"renames))) (if x (cadr x) (begin (set! renames `((,var ,(make-identifier var env", "names `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) ",
") (,(the 'make-identifier) ',var ',env)) unquote renames)) (rename var)))))) (wa", "unquote renames)) (rename var)))))) (walk (lambda (f form) (cond ((identifier? f",
"lk (lambda (f form) (cond ((identifier? form) (f form)) ((pair? form) `(,(the 'c", "orm) (f form)) ((pair? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr for",
"ons) (walk f (car form)) (walk f (cdr form)))) ((vector? form) `(,(the 'list->ve", "m)))) ((vector? form) `(,(the 'list->vector) (walk f (vector->list form)))) (els",
"ctor) (walk f (vector->list form)))) (else `(,(the 'quote) ,form)))))) (let ((fo", "e `(,(the 'quote) ,form)))))) (let ((form (walk rename (cadr form)))) `(,(the 'l",
"rm (walk rename (cadr form)))) `(,(the 'let) ,(map cdr renames) ,form)))))) (def", "et) ,(map cdr renames) ,form)))))) (define-macro syntax-quasiquote (lambda (form",
"ine-macro syntax-quasiquote (lambda (form env) (let ((renames '())) (letrec ((re", " env) (let ((renames '())) (letrec ((rename (lambda (var) (let ((x (assq var ren",
"name (lambda (var) (let ((x (assq var renames))) (if x (cadr x) (begin (set! ren", "ames))) (if x (cadr x) (begin (set! renames `((,var ,(make-identifier var env) (",
"ames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) u", ",(the 'make-identifier) ',var ',env)) unquote renames)) (rename var))))))) (defi",
"nquote renames)) (rename var))))))) (define (syntax-quasiquote? form) (and (pair", "ne (syntax-quasiquote? form) (and (pair? form) (identifier? (car form)) (identif",
"? form) (identifier? (car form)) (identifier=? (the 'syntax-quasiquote) (make-id", "ier=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) (define (synt",
"entifier (car form) env)))) (define (syntax-unquote? form) (and (pair? form) (id", "ax-unquote? form) (and (pair? form) (identifier? (car form)) (identifier=? (the ",
"entifier? (car form)) (identifier=? (the 'syntax-unquote) (make-identifier (car ", "'syntax-unquote) (make-identifier (car form) env)))) (define (syntax-unquote-spl",
"form) env)))) (define (syntax-unquote-splicing? form) (and (pair? form) (pair? (", "icing? form) (and (pair? form) (pair? (car form)) (identifier? (caar form)) (ide",
"car form)) (identifier? (caar form)) (identifier=? (the 'syntax-unquote-splicing", "ntifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) (d",
") (make-identifier (caar form) env)))) (define (qq depth expr) (cond ((syntax-un", "efine (qq depth expr) (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr ex",
"quote? expr) (if (= depth 1) (car (cdr expr)) (list (the 'list) (list (the 'quot", "pr)) (list (the 'list) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1)",
"e) (the 'syntax-unquote)) (qq (- depth 1) (car (cdr expr)))))) ((syntax-unquote-", " (car (cdr expr)))))) ((syntax-unquote-splicing? expr) (if (= depth 1) (list (th",
"splicing? expr) (if (= depth 1) (list (the 'append) (car (cdr (car expr))) (qq d", "e 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (list (the 'cons) (list",
"epth (cdr expr))) (list (the 'cons) (list (the 'list) (list (the 'quote) (the 's", " (the 'list) (list (the 'quote) (the 'syntax-unquote-splicing)) (qq (- depth 1) ",
"yntax-unquote-splicing)) (qq (- depth 1) (car (cdr (car expr))))) (qq depth (cdr", "(car (cdr (car expr))))) (qq depth (cdr expr))))) ((syntax-quasiquote? expr) (li",
" expr))))) ((syntax-quasiquote? expr) (list (the 'list) (list (the 'quote) (the ", "st (the 'list) (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr e",
"'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pair? expr) (list (the 'cons", "xpr))))) ((pair? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr ex",
") (qq depth (car expr)) (qq depth (cdr expr)))) ((vector? expr) (list (the 'list", "pr)))) ((vector? expr) (list (the 'list->vector) (qq depth (vector->list expr)))",
"->vector) (qq depth (vector->list expr)))) ((identifier? expr) (rename expr)) (e", ") ((identifier? expr) (rename expr)) (else (list (the 'quote) expr)))) (let ((bo",
"lse (list (the 'quote) expr)))) (let ((body (qq 1 (cadr form)))) `(,(the 'let) ,", "dy (qq 1 (cadr form)))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (tr",
"(map cdr renames) ,body)))))) (define (transformer f) (lambda (form env) (let ((", "ansformer f) (lambda (form env) (let ((ephemeron1 (make-ephemeron)) (ephemeron2 ",
"ephemeron1 (make-ephemeron)) (ephemeron2 (make-ephemeron))) (letrec ((wrap (lamb", "(make-ephemeron))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1)))",
"da (var1) (let ((var2 (ephemeron1 var1))) (if var2 (cdr var2) (let ((var2 (make-", " (if var2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 v",
"identifier var1 env))) (ephemeron1 var1 var2) (ephemeron2 var2 var1) var2))))) (", "ar2) (ephemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (epheme",
"unwrap (lambda (var2) (let ((var1 (ephemeron2 var2))) (if var1 (cdr var1) var2))", "ron2 var2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identif",
")) (walk (lambda (f form) (cond ((identifier? form) (f form)) ((pair? form) (con", "ier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form))",
"s (walk f (car form)) (walk f (cdr form)))) ((vector? form) (list->vector (walk ", ")) ((vector? form) (list->vector (walk f (vector->list form)))) (else form))))) ",
"f (vector->list form)))) (else form))))) (let ((form (cdr form))) (walk unwrap (", "(let ((form (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-m",
"apply f (walk wrap form)))))))) (define-macro define-syntax (lambda (form env) (", "acro define-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr",
"let ((formal (car (cdr form))) (body (cdr (cdr form)))) (if (pair? formal) `(,(t", " (cdr form)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-la",
"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) `(,the-defi", "mbda ,(cdr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,t",
"ne-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) (define-macro le", "he-begin ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((for",
"trec-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr f", "mal (car (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(t",
"orm)))) `(let () ,@(map (lambda (x) `(,(the 'define-syntax) ,(car x) ,(cadr x)))", "he 'define-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syn",
" formal) ,@body)))) (define-macro let-syntax (lambda (form env) `(,(the 'letrec-", "tax (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle n",
"syntax) ,@(cdr form)))) (define (mangle name) (when (null? name) (error \"library", "ame) (when (null? name) (error \"library name should be a list of at least one sy",
" name should be a list of at least one symbols\" name)) (define (->string n) (con", "mbols\" name)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string",
"d ((symbol? n) (let ((str (symbol->string n))) (string-for-each (lambda (c) (whe", " n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\/)) (err",
"n (or (char=? c #\\.) (char=? c #\\/)) (error \"elements of library name may not co", "or \"elements of library name may not contain '.' or '/'\" n))) str) str)) ((and (",
"ntain '.' or '/'\" n))) str) str)) ((and (number? n) (exact? n)) (number->string ", "number? n) (exact? n)) (number->string n)) (else (error \"symbol or integer is re",
"n)) (else (error \"symbol or integer is required\" n)))) (define (join strs delim)", "quired\" n)))) (define (join strs delim) (let loop ((res (car strs)) (strs (cdr s",
" (let loop ((res (car strs)) (strs (cdr strs))) (if (null? strs) res (loop (stri", "trs))) (if (null? strs) res (loop (string-append res delim (car strs)) (cdr strs",
"ng-append res delim (car strs)) (cdr strs))))) (join (map ->string name) \".\")) (", "))))) (join (map ->string name) \".\")) (define-macro define-library (lambda (form",
"define-macro define-library (lambda (form _) (let ((lib (mangle (cadr form))) (b", " _) (let ((lib (mangle (cadr form))) (body (cddr form))) (or (find-library lib) ",
"ody (cddr form))) (or (find-library lib) (make-library lib)) (for-each (lambda (", "(make-library lib)) (for-each (lambda (expr) (eval expr lib)) body)))) (define-m",
"expr) (eval expr lib)) body)))) (define-macro cond-expand (lambda (form _) (letr", "acro cond-expand (lambda (form _) (letrec ((test (lambda (form) (or (eq? form 'e",
"ec ((test (lambda (form) (or (eq? form 'else) (and (symbol? form) (memq form (fe", "lse) (and (symbol? form) (memq form (features))) (and (pair? form) (case (car fo",
"atures))) (and (pair? form) (case (car form) ((library) (find-library (mangle (c", "rm) ((library) (find-library (mangle (cadr form)))) ((not) (not (test (cadr form",
"adr form)))) ((not) (not (test (cadr form)))) ((and) (let loop ((form (cdr form)", ")))) ((and) (let loop ((form (cdr form))) (or (null? form) (and (test (car form)",
")) (or (null? form) (and (test (car form)) (loop (cdr form)))))) ((or) (let loop", ") (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (and (pair? form) (o",
" ((form (cdr form))) (and (pair? form) (or (test (car form)) (loop (cdr form))))", "r (test (car form)) (loop (cdr form)))))) (else #f))))))) (let loop ((clauses (c",
")) (else #f))))))) (let loop ((clauses (cdr form))) (if (null? clauses) #undefin", "dr form))) (if (null? clauses) #undefined (if (test (caar clauses)) `(,the-begin",
"ed (if (test (caar clauses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses))", " ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (lambda (form",
")))))) (define-macro import (lambda (form _) (let ((caddr (lambda (x) (car (cdr ", " _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (prefix symbo",
"(cdr x))))) (prefix (lambda (prefix symbol) (string->symbol (string-append (symb", "l) (string->symbol (string-append (symbol->string prefix) (symbol->string symbol",
"ol->string prefix) (symbol->string symbol))))) (getlib (lambda (name) (let ((lib", "))))) (getlib (lambda (name) (let ((lib (mangle name))) (if (find-library lib) l",
" (mangle name))) (if (find-library lib) lib (error \"library not found\" name)))))", "ib (error \"library not found\" name)))))) (letrec ((extract (lambda (spec) (case ",
") (letrec ((extract (lambda (spec) (case (car spec) ((only rename prefix except)", "(car spec) ((only rename prefix except) (extract (cadr spec))) (else (getlib spe",
" (extract (cadr spec))) (else (getlib spec))))) (collect (lambda (spec) (case (c", "c))))) (collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (c",
"ar spec) ((only) (let ((alist (collect (cadr spec)))) (map (lambda (var) (assq v", "adr spec)))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ",
"ar alist)) (cddr spec)))) ((rename) (let ((alist (collect (cadr spec))) (renames", "((alist (collect (cadr spec))) (renames (map (lambda (x) `((car x) cadr x)) (cdd",
" (map (lambda (x) `((car x) cadr x)) (cddr spec)))) (map (lambda (s) (or (assq (", "r spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix) (l",
"car s) renames) s)) alist))) ((prefix) (let ((alist (collect (cadr spec)))) (map", "et ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec) (",
" (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist))) ((except) (l", "car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (let l",
"et ((alist (collect (cadr spec)))) (let loop ((alist alist)) (if (null? alist) '", "oop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec)) (l",
"() (if (memq (caar alist) (cddr spec)) (loop (cdr alist)) (cons (car alist) (loo", "oop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (map (lambda (",
"p (cdr alist)))))))) (else (map (lambda (x) (cons x x)) (library-exports (getlib", "x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((import (lambda (s",
" spec)))))))) (letrec ((import (lambda (spec) (let ((lib (extract spec)) (alist ", "pec) (let ((lib (extract spec)) (alist (collect spec))) (for-each (lambda (slot)",
"(collect spec))) (for-each (lambda (slot) (library-import lib (cdr slot) (car sl", " (library-import lib (cdr slot) (car slot))) alist))))) (for-each import (cdr fo",
"ot))) alist))))) (for-each import (cdr form))))))) (define-macro export (lambda ", "rm))))))) (define-macro export (lambda (form _) (letrec ((collect (lambda (spec)",
"(form _) (letrec ((collect (lambda (spec) (cond ((symbol? spec) `(,spec unquote ", " (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= (length spec",
"spec)) ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) `(,(list", ") 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-ref spec 2))) ",
"-ref spec 1) unquote (list-ref spec 2))) (else (error \"malformed export\"))))) (e", "(else (error \"malformed export\"))))) (export (lambda (spec) (let ((slot (collect",
"xport (lambda (spec) (let ((slot (collect spec))) (library-export (car slot) (cd", " spec))) (library-export (car slot) (cdr slot)))))) (for-each export (cdr form))",
"r slot)))))) (for-each export (cdr form))))) (export define lambda quote set! if", "))) (export define lambda quote set! if begin define-macro let let* letrec letre",
" begin define-macro let let* letrec letrec* let-values let*-values define-values", "c* let-values let*-values define-values quasiquote unquote unquote-splicing and ",
" quasiquote unquote unquote-splicing and or cond case else => do when unless par", "or cond case else => do when unless parameterize define-syntax syntax-quote synt",
"ameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote syntax-unq", "ax-unquote syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax sy",
"uote-splicing let-syntax letrec-syntax syntax-error) ", "ntax-error) ",
}; };
void void

37
lib/cont.c
View File

@ -14,6 +14,7 @@ struct cont {
ptrdiff_t ci_offset; ptrdiff_t ci_offset;
size_t arena_idx; size_t arena_idx;
const struct code *ip; const struct code *ip;
pic_value dyn_env;
int retc; int retc;
pic_value *retv; pic_value *retv;
@ -23,6 +24,22 @@ struct cont {
static const pic_data_type cont_type = { "cont", NULL }; 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 void
pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp) 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->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase; cont->ci_offset = pic->ci - pic->cibase;
cont->arena_idx = pic->arena_idx; cont->arena_idx = pic->arena_idx;
cont->dyn_env = pic->dyn_env;
cont->ip = pic->ip; cont->ip = pic->ip;
cont->prev = pic->cc; cont->prev = pic->cc;
cont->retc = 0; cont->retc = 0;
@ -44,13 +62,14 @@ pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
void void
pic_load_point(pic_state *pic, struct cont *cont) 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 */ /* load runtime context */
pic->cp = cont->cp; pic->cp = cont->cp;
pic->sp = pic->stbase + cont->sp_offset; pic->sp = pic->stbase + cont->sp_offset;
pic->ci = pic->cibase + cont->ci_offset; pic->ci = pic->cibase + cont->ci_offset;
pic->arena_idx = cont->arena_idx; pic->arena_idx = cont->arena_idx;
pic->dyn_env = cont->dyn_env;
pic->ip = cont->ip; pic->ip = cont->ip;
pic->cc = cont->prev; pic->cc = cont->prev;
} }
@ -61,22 +80,6 @@ pic_exit_point(pic_state *pic)
pic->cc = pic->cc->prev; 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_value
pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out) pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out)
{ {

171
lib/error.c
View File

@ -12,9 +12,7 @@ pic_panic(pic_state *pic, const char *msg)
if (pic->panicf) { if (pic->panicf) {
pic->panicf(pic, msg); pic->panicf(pic, msg);
} }
PIC_ABORT(pic); PIC_ABORT(pic);
PIC_UNREACHABLE(); PIC_UNREACHABLE();
} }
@ -27,7 +25,6 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
va_start(ap, fmt); va_start(ap, fmt);
err = pic_vstrf_value(pic, fmt, ap); err = pic_vstrf_value(pic, fmt, ap);
va_end(ap); va_end(ap);
pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL)); 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(); PIC_UNREACHABLE();
} }
static pic_value void
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_start_try(pic_state *pic, PIC_JMPBUF *jmp) pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
{ {
struct cont *cont; struct cont *cont;
pic_value handler; pic_value handler;
pic_value var, old_val, new_val; pic_value var, env;
pic_value in, out;
struct checkpoint *here;
/* call/cc */ /* call/cc */
@ -78,35 +58,15 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
/* with-exception-handler */ /* with-exception-handler */
var = pic_ref(pic, "picrin.base", "current-exception-handlers"); var = pic_ref(pic, "picrin.base", "current-exception-handlers");
old_val = pic_call(pic, var, 0); env = pic_make_weak(pic);
new_val = pic_cons(pic, handler, old_val); 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);
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);
} }
void 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->dyn_env = pic_cdr(pic, pic->dyn_env);
pic_value out = pic_cdr(pic, cookie);
pic->cp = here;
pic_call(pic, out, 0); /* exit */
pic_exit_point(pic); 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); 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 void
pic_error(pic_state *pic, const char *msg, int n, ...) 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); va_start(ap, n);
irrs = pic_vlist(pic, n, ap); irrs = pic_vlist(pic, n, ap);
va_end(ap); va_end(ap);
pic_raise(pic, pic_make_error(pic, "", msg, irrs)); 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 static pic_value
pic_error_with_exception_handler(pic_state *pic) pic_error_with_exception_handler(pic_state *pic)
{ {
pic_value handler, thunk; 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); 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 static pic_value
@ -233,13 +198,13 @@ pic_error_raise_continuable(pic_state *pic)
static pic_value static pic_value
pic_error_error(pic_state *pic) pic_error_error(pic_state *pic)
{ {
const char *str; const char *cstr;
int argc; int argc;
pic_value *argv; 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 static pic_value

1
lib/ext/load.c
View File

@ -13,7 +13,6 @@ pic_load(pic_state *pic, pic_value port)
while (! pic_eof_p(pic, form = pic_read(pic, port))) { while (! pic_eof_p(pic, form = pic_read(pic, port))) {
pic_eval(pic, form, pic_current_library(pic)); pic_eval(pic, form, pic_current_library(pic));
pic_leave(pic, ai); pic_leave(pic, ai);
} }
} }

3
lib/gc.c
View File

@ -499,6 +499,9 @@ gc_mark_phase(pic_state *pic)
/* error object */ /* error object */
gc_mark(pic, pic->err); gc_mark(pic, pic->err);
/* dynamic environment */
gc_mark(pic, pic->dyn_env);
/* features */ /* features */
gc_mark(pic, pic->features); gc_mark(pic, pic->features);

14
lib/include/picrin.h
View File

@ -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); typedef void (*pic_panicf)(pic_state *, const char *msg);
pic_panicf pic_atpanic(pic_state *, pic_panicf f); pic_panicf pic_atpanic(pic_state *, pic_panicf f);
PIC_NORETURN void pic_panic(pic_state *, const char *msg); 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_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 */ 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 pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp))
#define pic_try_(cont, jmp) \ #define pic_try_(cont, jmp) \
do { \ do { \
extern pic_value pic_start_try(pic_state *, PIC_JMPBUF *); \ extern void pic_start_try(pic_state *, PIC_JMPBUF *); \
extern void pic_end_try(pic_state *, pic_value); \ extern void pic_end_try(pic_state *); \
extern pic_value pic_err(pic_state *); \ extern pic_value pic_err(pic_state *); \
PIC_JMPBUF jmp; \ PIC_JMPBUF jmp; \
if (PIC_SETJMP(pic, jmp) == 0) { \ 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) pic_catch_(e, PIC_GENSYM(label))
#define pic_catch_(e, label) \ #define pic_catch_(e, label) \
pic_end_try(pic, pic_try_cookie_); \ pic_end_try(pic); \
} else { \ } else { \
e = pic_err(pic); \ e = pic_err(pic); \
goto label; \ goto label; \

5
lib/object.h
View File

@ -300,13 +300,12 @@ struct cont *pic_alloca_cont(pic_state *);
pic_value pic_make_cont(pic_state *, struct cont *); pic_value pic_make_cont(pic_state *, struct cont *);
void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *); void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
void pic_exit_point(pic_state *); 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_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 *); pic_value pic_library_environment(pic_state *, const char *);
void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
#if defined(__cplusplus) #if defined(__cplusplus)
} }
#endif #endif

7
lib/state.c
View File

@ -227,6 +227,9 @@ pic_open(pic_allocf allocf, void *userdata)
/* features */ /* features */
pic->features = pic_nil_value(pic); pic->features = pic_nil_value(pic);
/* dynamic environment */
pic->dyn_env = pic_invalid_value(pic);
/* libraries */ /* libraries */
kh_init(ltable, &pic->ltable); kh_init(ltable, &pic->ltable);
pic->lib = NULL; pic->lib = NULL;
@ -238,6 +241,7 @@ pic_open(pic_allocf allocf, void *userdata)
/* root tables */ /* root tables */
pic->globals = pic_make_weak(pic); pic->globals = pic_make_weak(pic);
pic->macros = pic_make_weak(pic); pic->macros = pic_make_weak(pic);
pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
/* root block */ /* root block */
pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); 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->err = pic_invalid_value(pic);
pic->globals = pic_invalid_value(pic); pic->globals = pic_invalid_value(pic);
pic->macros = 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 */ /* free all libraries */
kh_clear(ltable, &pic->ltable); kh_clear(ltable, &pic->ltable);

2
lib/state.h
View File

@ -47,6 +47,8 @@ struct pic_state {
const struct code *ip; const struct code *ip;
pic_value dyn_env;
const char *lib; const char *lib;
pic_value features; pic_value features;

78
lib/var.c
View File

@ -6,14 +6,7 @@
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
static pic_value /* implementated by deep binding */
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;
}
static pic_value static pic_value
var_call(pic_state *pic) var_call(pic_state *pic)
@ -24,11 +17,22 @@ var_call(pic_state *pic)
n = pic_get_args(pic, "&|o", &self, &val); n = pic_get_args(pic, "&|o", &self, &val);
if (n == 0) { 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 { } 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); return pic_undef_value(pic);
} }
} }
@ -36,36 +40,11 @@ var_call(pic_state *pic)
pic_value pic_value
pic_make_var(pic_state *pic, pic_value init, pic_value conv) 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 var = pic_lambda(pic, var_call, 1, conv);
dynamic_set(pic_state *pic) pic_call(pic, var, 1, init);
{ return var;
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);
} }
static pic_value static pic_value
@ -79,22 +58,25 @@ pic_var_make_parameter(pic_state *pic)
} }
static pic_value 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)) { env = pic_make_weak(pic);
pic_error(pic, "parameter required", 1, var); pic_for_each(elt, alist, it) {
pic_weak_set(pic, env, pic_car(pic, elt), pic_cdr(pic, elt));
} }
pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
return pic_dynamic_bind(pic, var, val, thunk); val = pic_call(pic, thunk, 0);
pic->dyn_env = pic_cdr(pic, pic->dyn_env);
return val;
} }
void void
pic_init_var(pic_state *pic) pic_init_var(pic_state *pic)
{ {
pic_defun(pic, "make-parameter", pic_var_make_parameter); 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);
} }

8
piclib/boot.scm
View File

@ -372,11 +372,9 @@
(lambda (form env) (lambda (form env)
(let ((formal (car (cdr form))) (let ((formal (car (cdr form)))
(body (cdr (cdr form)))) (body (cdr (cdr form))))
(if (null? formal) `(,(the 'with-dynamic-environment)
`(,the-begin ,@body) (,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))
(let ((bind (car formal))) (,the-lambda () ,@body)))))
`(,(the 'dynamic-bind) ,(car bind) ,(cadr bind)
(,the-lambda () (,(the 'parameterize) ,(cdr formal) ,@body))))))))
(define-macro syntax-quote (define-macro syntax-quote
(lambda (form env) (lambda (form env)