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",
"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

37
lib/cont.c
View File

@ -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)
{

171
lib/error.c
View File

@ -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

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))) {
pic_eval(pic, form, pic_current_library(pic));
pic_leave(pic, ai);
}
}

3
lib/gc.c
View File

@ -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);

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);
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; \

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 *);
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

7
lib/state.c
View File

@ -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);

2
lib/state.h
View File

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

78
lib/var.c
View File

@ -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);
}

8
piclib/boot.scm
View File

@ -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)