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

[bugfix] make-parameter is broken

This commit is contained in:
Yuichi Nishiwaki 2016-02-23 20:50:26 +09:00
parent 4c6fe54d34
commit 34331dad6f
12 changed files with 207 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
contrib/10.callcc/callcc.c
View File

@ -26,8 +26,6 @@ struct fullcont {
struct code *ip; struct code *ip;
pic_value ptable;
struct object **arena; struct object **arena;
size_t arena_size, arena_idx; size_t arena_size, arena_idx;
@ -89,9 +87,6 @@ cont_mark(pic_state *pic, void *data, void (*mark)(pic_state *, pic_value))
for (i = 0; i < cont->arena_idx; ++i) { for (i = 0; i < cont->arena_idx; ++i) {
mark(pic, pic_obj_value(cont->arena[i])); mark(pic, pic_obj_value(cont->arena[i]));
} }
/* parameter table */
mark(pic, cont->ptable);
} }
static const pic_data_type cont_type = { "continuation", cont_dtor, cont_mark }; static const pic_data_type cont_type = { "continuation", cont_dtor, cont_mark };
@ -151,8 +146,6 @@ save_cont(pic_state *pic, struct fullcont **c)
cont->ip = pic->ip; cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->arena_idx = pic->arena_idx; cont->arena_idx = pic->arena_idx;
cont->arena_size = pic->arena_size; cont->arena_size = pic->arena_size;
cont->arena = pic_malloc(pic, sizeof(struct object *) * pic->arena_size); cont->arena = pic_malloc(pic, sizeof(struct object *) * pic->arena_size);
@ -204,8 +197,6 @@ restore_cont(pic_state *pic, struct fullcont *cont)
pic->ip = cont->ip; pic->ip = cont->ip;
pic->ptable = cont->ptable;
assert(pic->arena_size >= cont->arena_size); assert(pic->arena_size >= cont->arena_size);
memcpy(pic->arena, cont->arena, sizeof(struct object *) * cont->arena_size); memcpy(pic->arena, cont->arena, sizeof(struct object *) * cont->arena_size);
pic->arena_size = cont->arena_size; pic->arena_size = cont->arena_size;

275
extlib/benz/boot.c
View File

@ -382,10 +382,11 @@ my $src = <<'EOL';
(lambda (form env) (lambda (form env)
(let ((formal (car (cdr form))) (let ((formal (car (cdr form)))
(body (cdr (cdr form)))) (body (cdr (cdr form))))
`(,(the 'with-parameter) (if (null? formal)
(,(the 'lambda) () `(,the-begin ,@body)
,@formal (let ((bind (car formal)))
,@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)
@ -894,138 +895,140 @@ const char pic_boot[][80] = {
" (cdr clause))) ,the-key)\n `(,the-begin ,@(cdr ", " (cdr clause))) ,the-key)\n `(,the-begin ,@(cdr ",
"clause)))\n ,(loop (cdr clauses)))))))))))\n\n(define-m", "clause)))\n ,(loop (cdr clauses)))))))))))\n\n(define-m",
"acro parameterize\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", "acro parameterize\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
" (body (cdr (cdr form))))\n `(,(the 'with-parameter)\n (,(the 'l", " (body (cdr (cdr form))))\n (if (null? formal)\n `(,the-begin ",
"ambda) ()\n ,@formal\n ,@body)))))\n\n(define-macro syntax-quote\n (", ",@body)\n (let ((bind (car formal)))\n `(,(the 'dynamic-bind) ",
"lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (lam", ",(car bind) ,(cadr bind)\n (,the-lambda () (,(the 'parameterize) ,(c",
"bda (var)\n (let ((x (assq var renames)))\n ", "dr formal) ,@body))))))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (",
" (if x\n (cadr x)\n (begin\n", "let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
" (set! renames `((,var ,(make-identifier var env) (,", " (let ((x (assq var renames)))\n (if x\n ",
"(the 'make-identifier) ',var ',env)) . ,renames))\n (", " (cadr x)\n (begin\n ",
"rename var))))))\n (walk (lambda (f form)\n (cond\n ", " (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ",
" ((identifier? form)\n (f form))\n ", "',var ',env)) . ,renames))\n (rename var))))))\n ",
" ((pair? form)\n `(,(the 'cons) (walk f (car form)) (wa", " (walk (lambda (f form)\n (cond\n ((ident",
"lk f (cdr form))))\n ((vector? form)\n `(,(", "ifier? form)\n (f form))\n ((pair? form)\n ",
"the 'list->vector) (walk f (vector->list form))))\n (else\n ", " `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
" `(,(the 'quote) ,form))))))\n (let ((form (walk rename (c", " ((vector? form)\n `(,(the 'list->vector) (wal",
"adr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", "k f (vector->list form))))\n (else\n `(,(th",
",form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form env)\n (let ((ren", "e 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n ",
"ames '()))\n (letrec\n ((rename (lambda (var)\n (", "`(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-ma",
"let ((x (assq var renames)))\n (if x\n ", "cro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letre",
" (cadr x)\n (begin\n (se", "c\n ((rename (lambda (var)\n (let ((x (assq var renam",
"t! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',e", "es)))\n (if x\n (cadr x)\n ",
"nv)) . ,renames))\n (rename var)))))))\n\n (defi", " (begin\n (set! renames `((,var ,(ma",
"ne (syntax-quasiquote? form)\n (and (pair? form)\n (identif", "ke-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
"ier? (car form))\n (identifier=? (the 'syntax-quasiquote) (make-ide", " (rename var)))))))\n\n (define (syntax-quasiquote? ",
"ntifier (car form) env))))\n\n (define (syntax-unquote? form)\n (an", "form)\n (and (pair? form)\n (identifier? (car form))\n ",
"d (pair? form)\n (identifier? (car form))\n (identifie", " (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env)",
"r=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n (define (", ")))\n\n (define (syntax-unquote? form)\n (and (pair? form)\n ",
"syntax-unquote-splicing? form)\n (and (pair? form)\n (pair?", " (identifier? (car form))\n (identifier=? (the 'syntax-unquot",
" (car form))\n (identifier? (caar form))\n (identifier", "e) (make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing",
"=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", "? form)\n (and (pair? form)\n (pair? (car form))\n ",
"(define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", " (identifier? (caar form))\n (identifier=? (the 'syntax-unquote",
"((syntax-unquote? expr)\n (if (= depth 1)\n (car (cdr ex", "-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth expr)",
"pr))\n (list (the 'list)\n (list (the 'quote) ", "\n (cond\n ;; syntax-unquote\n ((syntax-unquote? expr)",
"(the 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr)))))", "\n (if (= depth 1)\n (car (cdr expr))\n (l",
")\n ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ex", "ist (the 'list)\n (list (the 'quote) (the 'syntax-unquote))\n",
"pr)\n (if (= depth 1)\n (list (the 'append)\n ", " (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-",
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", "unquote-splicing\n ((syntax-unquote-splicing? expr)\n (if (= ",
" (list (the 'cons)\n (list (the 'list)\n ", "depth 1)\n (list (the 'append)\n (car (cdr (ca",
" (list (the 'quote) (the 'syntax-unquote-splicing))\n ", "r expr)))\n (qq depth (cdr expr)))\n (list (th",
" (qq (- depth 1) (car (cdr (car expr)))))\n ", "e 'cons)\n (list (the 'list)\n (li",
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((syntax-q", "st (the 'quote) (the 'syntax-unquote-splicing))\n (qq ",
"uasiquote? expr)\n (list (the 'list)\n (list (the 'quo", "(- depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr))",
"te) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", ")))\n ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n ",
" ;; list\n ((pair? expr)\n (list (the 'cons)\n ", " (list (the 'list)\n (list (the 'quote) (the 'quasiquote))\n",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", " (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ",
" ;; vector\n ((vector? expr)\n (list (the 'list->vector) (", " ((pair? expr)\n (list (the 'cons)\n (qq depth (car",
"qq depth (vector->list expr))))\n ;; identifier\n ((identifier", " expr))\n (qq depth (cdr expr))))\n ;; vector\n ",
"? expr)\n (rename expr))\n ;; simple datum\n (else\n ", " ((vector? expr)\n (list (the 'list->vector) (qq depth (vector->list ",
" (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))", "expr))))\n ;; identifier\n ((identifier? expr)\n (re",
"\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n", "name expr))\n ;; simple datum\n (else\n (list (the '",
"\n(define (transformer f)\n (lambda (form env)\n (let ((ephemeron1 (make-epheme", "quote) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'let",
"ron))\n (ephemeron2 (make-ephemeron)))\n (letrec\n ((wrap (l", ")\n ,(map cdr renames)\n ,body))))))\n\n(define (transformer f",
"ambda (var1)\n (let ((var2 (ephemeron1 var1)))\n ", ")\n (lambda (form env)\n (let ((ephemeron1 (make-ephemeron))\n (epheme",
" (if var2\n (cdr var2)\n (let ", "ron2 (make-ephemeron)))\n (letrec\n ((wrap (lambda (var1)\n ",
"((var2 (make-identifier var1 env)))\n (ephemeron1 var1 ", " (let ((var2 (ephemeron1 var1)))\n (if var2\n ",
"var2)\n (ephemeron2 var2 var1)\n ", " (cdr var2)\n (let ((var2 (make-identifier",
" var2)))))\n (unwrap (lambda (var2)\n (let ((var1 ", " var1 env)))\n (ephemeron1 var1 var2)\n ",
"(ephemeron2 var2)))\n (if var1\n (", " (ephemeron2 var2 var1)\n var2)))))\n ",
"cdr var1)\n var2))))\n (walk (lambda (f form)\n", " (unwrap (lambda (var2)\n (let ((var1 (ephemeron2 var2)))\n ",
" (cond\n ((identifier? form)\n ", " (if var1\n (cdr var1)\n ",
" (f form))\n ((pair? form)\n (cons (wa", " var2))))\n (walk (lambda (f form)\n (con",
"lk f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", "d\n ((identifier? form)\n (f form))\n ",
" (list->vector (walk f (vector->list form))))\n ", " ((pair? form)\n (cons (walk f (car form)) (walk ",
" (else\n form)))))\n (let ((form (cdr form)))\n ", "f (cdr form))))\n ((vector? form)\n (list->",
" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (l", "vector (walk f (vector->list form))))\n (else\n ",
"ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr", " form)))))\n (let ((form (cdr form)))\n (walk unwrap (apply f ",
" form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car forma", "(walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (l",
"l) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(", "et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pa",
"the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lamb", "ir? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr f",
"da (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr fo", "ormal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,the",
"rm))))\n `(let ()\n ,@(map (lambda (x)\n `(,(the 'def", "-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ",
"ine-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(d", "((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ",
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr f", " ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(",
"orm))))\n\n\n;;; library primitives\n\n(define (mangle name)\n (define (->string n)\n ", "cadr x)))\n formal)\n ,@body))))\n\n(define-macro let-syntax\n",
" (if (symbol? n)\n (symbol->string n)\n (number->string n)))\n (de", " (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library p",
"fine (join strs delim)\n (let loop ((res (car strs)) (strs (cdr strs)))\n ", "rimitives\n\n(define (mangle name)\n (define (->string n)\n (if (symbol? n)\n ",
"(if (null? strs)\n res\n (loop (string-append res delim (car str", " (symbol->string n)\n (number->string n)))\n (define (join strs delim)\n",
"s)) (cdr strs)))))\n (join (map ->string name) \".\"))\n\n(define-macro define-libra", " (let loop ((res (car strs)) (strs (cdr strs)))\n (if (null? strs)\n ",
"ry\n (lambda (form _)\n (let ((lib (mangle (cadr form)))\n (body (cddr", " res\n (loop (string-append res delim (car strs)) (cdr strs)))))\n (j",
" form)))\n (or (find-library lib) (make-library lib))\n (for-each (lambd", "oin (map ->string name) \".\"))\n\n(define-macro define-library\n (lambda (form _)\n ",
"a (expr) (eval expr lib)) body))))\n\n(define-macro cond-expand\n (lambda (form _)", " (let ((lib (mangle (cadr form)))\n (body (cddr form)))\n (or (fin",
"\n (letrec\n ((test (lambda (form)\n (or\n ", "d-library lib) (make-library lib))\n (for-each (lambda (expr) (eval expr lib",
" (eq? form 'else)\n (and (symbol? form)\n ", ")) body))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((",
"(memq form (features)))\n (and (pair? form)\n ", "test (lambda (form)\n (or\n (eq? form 'else)\n ",
" (case (car form)\n ((library) (find-library (mangle (c", " (and (symbol? form)\n (memq form (features)))",
"adr form))))\n ((not) (not (test (cadr form))))\n ", "\n (and (pair? form)\n (case (car form)\n ",
" ((and) (let loop ((form (cdr form)))\n ", " ((library) (find-library (mangle (cadr form))))\n ",
" (or (null? form)\n (and (test (car fo", " ((not) (not (test (cadr form))))\n ((and) ",
"rm)) (loop (cdr form))))))\n ((or) (let loop ((form (cdr ", "(let loop ((form (cdr form)))\n (or (null? form)",
"form)))\n (and (pair? form)\n ", "\n (and (test (car form)) (loop (cdr form)))",
" (or (test (car form)) (loop (cdr form))))))\n ", ")))\n ((or) (let loop ((form (cdr form)))\n ",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? ", " (and (pair? form)\n (or (t",
"clauses)\n #undefined\n (if (test (caar clauses))\n ", "est (car form)) (loop (cdr form))))))\n (else #f)))))))\n ",
" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n", " (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #u",
"\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x)", "ndefined\n (if (test (caar clauses))\n `(,the-begin ,@(c",
" (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", "dar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n ",
" (string->symbol\n (string-append\n (symbol->st", " (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n",
"ring prefix)\n (symbol->string symbol)))))\n (getlib\n ", " (prefix\n (lambda (prefix symbol)\n (string->symbo",
" (lambda (name)\n (let ((lib (mangle name)))\n (if (", "l\n (string-append\n (symbol->string prefix)\n ",
"find-library lib)\n lib\n (error \"library not ", " (symbol->string symbol)))))\n (getlib\n (lambda (name)\n ",
"found\" name))))))\n (letrec\n ((extract\n (lambda (spec)\n ", " (let ((lib (mangle name)))\n (if (find-library lib)\n ",
" (case (car spec)\n ((only rename prefix except)\n ", " lib\n (error \"library not found\" name))))))\n ",
" (extract (cadr spec)))\n (else\n (getli", " (letrec\n ((extract\n (lambda (spec)\n (case (car",
"b spec)))))\n (collect\n (lambda (spec)\n (case (", " spec)\n ((only rename prefix except)\n (extract (c",
"car spec)\n ((only)\n (let ((alist (collect (cadr s", "adr spec)))\n (else\n (getlib spec)))))\n ",
"pec))))\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ", "(collect\n (lambda (spec)\n (case (car spec)\n ",
" ((rename)\n (let ((alist (collect (cadr spec)))\n ", " ((only)\n (let ((alist (collect (cadr spec))))\n ",
" (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec", " (map (lambda (var) (assq var alist)) (cddr spec))))\n ((rename",
"))))\n (map (lambda (s) (or (assq (car s) renames) s)) alist)))", ")\n (let ((alist (collect (cadr spec)))\n (r",
"\n ((prefix)\n (let ((alist (collect (cadr spec))))", "enames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ",
"\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s)", " (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pref",
")) alist)))\n ((except)\n (let ((alist (collect (ca", "ix)\n (let ((alist (collect (cadr spec))))\n (ma",
"dr spec))))\n (let loop ((alist alist))\n (i", "p (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ",
"f (null? alist)\n '()\n (if (memq ", " ((except)\n (let ((alist (collect (cadr spec))))\n ",
"(caar alist) (cddr spec))\n (loop (cdr alist))\n ", " (let loop ((alist alist))\n (if (null? alist)\n ",
" (cons (car alist) (loop (cdr alist))))))))\n ", " '()\n (if (memq (caar alist) (cddr spec",
" (else\n (map (lambda (x) (cons x x)) (library-exports (getlib s", "))\n (loop (cdr alist))\n ",
"pec))))))))\n (letrec\n ((import\n (lambda (spec)\n ", "(cons (car alist) (loop (cdr alist))))))))\n (else\n ",
" (let ((lib (extract spec))\n (alist (collec", " (map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))\n (le",
"t spec)))\n (for-each\n (lambda (slot)\n ", "trec\n ((import\n (lambda (spec)\n (let ((",
" (library-import lib (cdr slot) (car slot)))\n ", "lib (extract spec))\n (alist (collect spec)))\n ",
"alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (", " (for-each\n (lambda (slot)\n (librar",
"lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", "y-import lib (cdr slot) (car slot)))\n alist)))))\n (f",
" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", "or-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (le",
" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", "trec\n ((collect\n (lambda (spec)\n (cond\n (",
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n (", "(symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec) (",
"error \"malformed export\")))))\n (export\n (lambda (spec)\n ", "= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) ",
" (let ((slot (collect spec)))\n (library-export (car slot) (cd", ". ,(list-ref spec 2)))\n (else\n (error \"malformed export",
"r slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote ", "\")))))\n (export\n (lambda (spec)\n (let ((slot (coll",
"set! if begin define-macro\n let let* letrec letrec*\n let-values le", "ect spec)))\n (library-export (car slot) (cdr slot))))))\n (for",
"t*-values define-values\n quasiquote unquote unquote-splicing\n and ", "-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-ma",
"or\n cond case else =>\n do when unless\n parameterize\n ", "cro\n let let* letrec letrec*\n let-values let*-values define-values",
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syn", "\n quasiquote unquote unquote-splicing\n and or\n cond case el",
"tax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", "se =>\n do when unless\n parameterize\n define-syntax\n ",
"syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ",
" let-syntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };

7
extlib/benz/cont.c
View File

@ -16,7 +16,6 @@ struct pic_cont {
ptrdiff_t ci_offset; ptrdiff_t ci_offset;
ptrdiff_t xp_offset; ptrdiff_t xp_offset;
size_t arena_idx; size_t arena_idx;
pic_value ptable;
struct code *ip; struct code *ip;
int retc; int retc;
@ -39,7 +38,6 @@ pic_save_point(pic_state *pic, struct pic_cont *cont, PIC_JMPBUF *jmp)
cont->xp_offset = pic->xp - pic->xpbase; cont->xp_offset = pic->xp - pic->xpbase;
cont->arena_idx = pic->arena_idx; cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip; cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->prev = pic->cc; cont->prev = pic->cc;
cont->retc = 0; cont->retc = 0;
cont->retv = NULL; cont->retv = NULL;
@ -60,7 +58,6 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
pic->xp = pic->xpbase + cont->xp_offset; pic->xp = pic->xpbase + cont->xp_offset;
pic->arena_idx = cont->arena_idx; pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip; pic->ip = cont->ip;
pic->ptable = cont->ptable;
pic->cc = cont->prev; pic->cc = cont->prev;
} }
@ -86,12 +83,14 @@ pic_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there)
} }
} }
static 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)
{ {
struct checkpoint *here; struct checkpoint *here;
pic_value val; pic_value val;
assert(pic_proc_p(pic, thunk));
pic_call(pic, in, 0); /* enter */ pic_call(pic, in, 0); /* enter */
here = pic->cp; here = pic->cp;

2
extlib/benz/debug.c
View File

@ -22,7 +22,7 @@ pic_get_backtrace(pic_state *pic)
trace = pic_str_cat(pic, trace, pic_lit_value(pic, " at ")); trace = pic_str_cat(pic, trace, pic_lit_value(pic, " at "));
trace = pic_str_cat(pic, trace, pic_lit_value(pic, "(anonymous lambda)")); trace = pic_str_cat(pic, trace, pic_lit_value(pic, "(anonymous lambda)"));
if (pic_func_p(proc)) { if (pic_func_p(pic, proc)) {
trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (native function)\n")); trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (native function)\n"));
} else { } else {
trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */ trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */

18
extlib/benz/eval.c
View File

@ -1050,22 +1050,13 @@ pic_compile(pic_state *pic, pic_value obj)
size_t ai = pic_enter(pic); size_t ai = pic_enter(pic);
#if 0 #if 0
fprintf(stdout, "ai = %zu\n", pic_enter(pic)); pic_printf(pic, "# input expression\n~s\n", obj);
fprintf(stdout, "# input expression\n");
pic_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_enter(pic));
#endif #endif
/* optimize */ /* optimize */
obj = pic_optimize(pic, obj); obj = pic_optimize(pic, obj);
#if 0 #if 0
fprintf(stdout, "## optimize completed\n"); pic_printf(pic, "## optimize completed\n~s\n", obj);
pic_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_enter(pic));
#endif #endif
SAVE(pic, ai, obj); SAVE(pic, ai, obj);
@ -1073,10 +1064,7 @@ pic_compile(pic_state *pic, pic_value obj)
/* analyze */ /* analyze */
obj = pic_analyze(pic, obj); obj = pic_analyze(pic, obj);
#if 0 #if 0
fprintf(stdout, "## analyzer completed\n"); pic_printf(pic, "## analyzer completed\n~s\n", obj);
pic_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_enter(pic));
#endif #endif
SAVE(pic, ai, obj); SAVE(pic, ai, obj);

3
extlib/benz/gc.c
View File

@ -467,9 +467,6 @@ gc_mark_phase(pic_state *pic)
/* features */ /* features */
gc_mark(pic, pic->features); gc_mark(pic, pic->features);
/* parameter table */
gc_mark(pic, pic->ptable);
/* library table */ /* library table */
for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) { for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
if (! kh_exist(&pic->ltable, it)) { if (! kh_exist(&pic->ltable, it)) {

5
extlib/benz/include/picrin/private/object.h
View File

@ -185,10 +185,11 @@ pic_value pic_id_name(pic_state *, pic_value id);
void pic_rope_incref(pic_state *, struct rope *); void pic_rope_incref(pic_state *, struct rope *);
void pic_rope_decref(pic_state *, struct rope *); void pic_rope_decref(pic_state *, struct rope *);
#define pic_func_p(proc) (pic_type(pic, proc) == PIC_TYPE_FUNC) #define pic_func_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_FUNC)
#define pic_irep_p(proc) (pic_type(pic, proc) == PIC_TYPE_IREP) #define pic_irep_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_IREP)
void pic_wind(pic_state *, struct checkpoint *, struct checkpoint *); 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);
#if defined(__cplusplus) #if defined(__cplusplus)

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

@ -54,8 +54,6 @@ struct pic_state {
struct code *ip; struct code *ip;
pic_value ptable; /* list of ephemerons */
struct lib *lib; struct lib *lib;
pic_value features; pic_value features;

4
extlib/benz/proc.c
View File

@ -918,7 +918,7 @@ pic_closure_ref(pic_state *pic, int n)
{ {
pic_value self = GET_OPERAND(pic, 0); pic_value self = GET_OPERAND(pic, 0);
assert(pic_func_p(self)); assert(pic_func_p(pic, self));
if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) { if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
@ -931,7 +931,7 @@ pic_closure_set(pic_state *pic, int n, pic_value v)
{ {
pic_value self = GET_OPERAND(pic, 0); pic_value self = GET_OPERAND(pic, 0);
assert(pic_func_p(self)); assert(pic_func_p(pic, self));
if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) { if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) {
pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n)); pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));

6
extlib/benz/state.c
View File

@ -290,9 +290,6 @@ pic_open(pic_allocf allocf, void *userdata)
xfopen_null(pic, "w"); xfopen_null(pic, "w");
#endif #endif
/* parameter table */
pic->ptable = pic_nil_value(pic);
/* native stack marker */ /* native stack marker */
pic->native_stack_start = &t; pic->native_stack_start = &t;
@ -306,9 +303,6 @@ pic_open(pic_allocf allocf, void *userdata)
pic->cp->depth = 0; pic->cp->depth = 0;
pic->cp->in = pic->cp->out = NULL; pic->cp->in = pic->cp->out = NULL;
/* parameter table */
pic->ptable = pic_cons(pic, pic_make_weak(pic), pic_nil_value(pic));
/* standard libraries */ /* standard libraries */
pic_make_library(pic, "picrin.user"); pic_make_library(pic, "picrin.user");
pic_in_library(pic, "picrin.user"); pic_in_library(pic, "picrin.user");

84
extlib/benz/var.c
View File

@ -8,28 +8,12 @@
#include "picrin/private/state.h" #include "picrin/private/state.h"
static pic_value static pic_value
var_get(pic_state *pic, pic_value var) var_conv(pic_state *pic, pic_value val, pic_value conv)
{ {
pic_value weak, it; if (! pic_false_p(pic, conv)) {
val = pic_call(pic, conv, 1, val);
pic_for_each (weak, pic->ptable, it) {
if (pic_weak_has(pic, weak, var)) {
return pic_weak_ref(pic, weak, var);
}
} }
PIC_UNREACHABLE(); return val;
}
static pic_value
var_set(pic_state *pic, pic_value var, pic_value val)
{
pic_value weak;
weak = pic_car(pic, pic->ptable);
pic_weak_set(pic, weak, var, val);
return pic_undef_value(pic);
} }
static pic_value static pic_value
@ -41,28 +25,48 @@ 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 var_get(pic, self); return pic_closure_ref(pic, 0);
} else { } else {
pic_value conv;
conv = pic_closure_ref(pic, 0); pic_closure_set(pic, 0, var_conv(pic, val, pic_closure_ref(pic, 1)));
if (! pic_false_p(pic, conv)) {
val = pic_call(pic, conv, 1, val); return pic_undef_value(pic);
}
return var_set(pic, self, val);
} }
} }
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)
{ {
pic_value var; return pic_lambda(pic, var_call, 2, var_conv(pic, init, conv), conv);
}
var = pic_lambda(pic, var_call, 1, conv); static pic_value
dynamic_set(pic_state *pic)
{
pic_value var, val;
pic_call(pic, var, 1, init); pic_get_args(pic, "");
return var; 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
@ -76,24 +80,22 @@ pic_var_make_parameter(pic_state *pic)
} }
static pic_value static pic_value
pic_var_with_parameter(pic_state *pic) pic_var_dynamic_bind(pic_state *pic)
{ {
pic_value body, val; pic_value var, val, thunk;
pic_get_args(pic, "l", &body); pic_get_args(pic, "lol", &var, &val, &thunk);
pic->ptable = pic_cons(pic, pic_make_weak(pic), pic->ptable); if (! (pic_proc_p(pic, var) && pic_proc_ptr(pic, var)->u.f.func == var_call)) {
pic_error(pic, "parameter required", 1, var);
}
val = pic_call(pic, body, 0); return pic_dynamic_bind(pic, var, val, thunk);
pic->ptable = pic_cdr(pic, pic->ptable);
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, "with-parameter", pic_var_with_parameter); pic_defun(pic, "dynamic-bind", pic_var_dynamic_bind);
} }

13
t/issue/parameterize.scm Normal file
View File

@ -0,0 +1,13 @@
(import (scheme base)
(picrin test))
(test-begin)
(define a #f)
(parameterize ()
(set! a (make-parameter 1)))
(test 1 (a))
(test-end)