From 34331dad6fc2bfc5aebc7e6092fcc112b5e9faad Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 23 Feb 2016 20:50:26 +0900 Subject: [PATCH] [bugfix] make-parameter is broken --- contrib/10.callcc/callcc.c | 9 - extlib/benz/boot.c | 275 ++++++++++---------- extlib/benz/cont.c | 7 +- extlib/benz/debug.c | 2 +- extlib/benz/eval.c | 18 +- extlib/benz/gc.c | 3 - extlib/benz/include/picrin/private/object.h | 5 +- extlib/benz/include/picrin/private/state.h | 2 - extlib/benz/proc.c | 4 +- extlib/benz/state.c | 6 - extlib/benz/var.c | 84 +++--- t/issue/parameterize.scm | 13 + 12 files changed, 207 insertions(+), 221 deletions(-) create mode 100644 t/issue/parameterize.scm diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index 8664354c..3cba0975 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -26,8 +26,6 @@ struct fullcont { struct code *ip; - pic_value ptable; - struct object **arena; 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) { 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 }; @@ -151,8 +146,6 @@ save_cont(pic_state *pic, struct fullcont **c) cont->ip = pic->ip; - cont->ptable = pic->ptable; - cont->arena_idx = pic->arena_idx; cont->arena_size = 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->ptable = cont->ptable; - assert(pic->arena_size >= cont->arena_size); memcpy(pic->arena, cont->arena, sizeof(struct object *) * cont->arena_size); pic->arena_size = cont->arena_size; diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 9ad798e3..a25b7be6 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -382,10 +382,11 @@ my $src = <<'EOL'; (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr form)))) - `(,(the 'with-parameter) - (,(the 'lambda) () - ,@formal - ,@body))))) + (if (null? formal) + `(,the-begin ,@body) + (let ((bind (car formal))) + `(,(the 'dynamic-bind) ,(car bind) ,(cadr bind) + (,the-lambda () (,(the 'parameterize) ,(cdr formal) ,@body)))))))) (define-macro syntax-quote (lambda (form env) @@ -894,138 +895,140 @@ const char pic_boot[][80] = { " (cdr clause))) ,the-key)\n `(,the-begin ,@(cdr ", "clause)))\n ,(loop (cdr clauses)))))))))))\n\n(define-m", "acro parameterize\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n `(,(the 'with-parameter)\n (,(the 'l", -"ambda) ()\n ,@formal\n ,@body)))))\n\n(define-macro syntax-quote\n (", -"lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (lam", -"bda (var)\n (let ((x (assq var renames)))\n ", -" (if x\n (cadr x)\n (begin\n", -" (set! renames `((,var ,(make-identifier var env) (,", -"(the 'make-identifier) ',var ',env)) . ,renames))\n (", -"rename var))))))\n (walk (lambda (f form)\n (cond\n ", -" ((identifier? form)\n (f form))\n ", -" ((pair? form)\n `(,(the 'cons) (walk f (car form)) (wa", -"lk f (cdr form))))\n ((vector? form)\n `(,(", -"the 'list->vector) (walk f (vector->list form))))\n (else\n ", -" `(,(the 'quote) ,form))))))\n (let ((form (walk rename (c", -"adr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", -",form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form env)\n (let ((ren", -"ames '()))\n (letrec\n ((rename (lambda (var)\n (", -"let ((x (assq var renames)))\n (if x\n ", -" (cadr x)\n (begin\n (se", -"t! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',e", -"nv)) . ,renames))\n (rename var)))))))\n\n (defi", -"ne (syntax-quasiquote? form)\n (and (pair? form)\n (identif", -"ier? (car form))\n (identifier=? (the 'syntax-quasiquote) (make-ide", -"ntifier (car form) env))))\n\n (define (syntax-unquote? form)\n (an", -"d (pair? form)\n (identifier? (car form))\n (identifie", -"r=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n (define (", -"syntax-unquote-splicing? form)\n (and (pair? form)\n (pair?", -" (car form))\n (identifier? (caar form))\n (identifier", -"=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", -"(define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", -"((syntax-unquote? expr)\n (if (= depth 1)\n (car (cdr ex", -"pr))\n (list (the 'list)\n (list (the 'quote) ", -"(the 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr)))))", -")\n ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ex", -"pr)\n (if (= depth 1)\n (list (the 'append)\n ", -" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", -" (list (the 'cons)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'syntax-unquote-splicing))\n ", -" (qq (- depth 1) (car (cdr (car expr)))))\n ", -" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((syntax-q", -"uasiquote? expr)\n (list (the 'list)\n (list (the 'quo", -"te) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", -" ;; list\n ((pair? expr)\n (list (the 'cons)\n ", -" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", -" ;; vector\n ((vector? expr)\n (list (the 'list->vector) (", -"qq depth (vector->list expr))))\n ;; identifier\n ((identifier", -"? expr)\n (rename expr))\n ;; simple datum\n (else\n ", -" (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))", -"\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n", -"\n(define (transformer f)\n (lambda (form env)\n (let ((ephemeron1 (make-epheme", -"ron))\n (ephemeron2 (make-ephemeron)))\n (letrec\n ((wrap (l", -"ambda (var1)\n (let ((var2 (ephemeron1 var1)))\n ", -" (if var2\n (cdr var2)\n (let ", -"((var2 (make-identifier var1 env)))\n (ephemeron1 var1 ", -"var2)\n (ephemeron2 var2 var1)\n ", -" var2)))))\n (unwrap (lambda (var2)\n (let ((var1 ", -"(ephemeron2 var2)))\n (if var1\n (", -"cdr var1)\n var2))))\n (walk (lambda (f form)\n", -" (cond\n ((identifier? form)\n ", -" (f form))\n ((pair? form)\n (cons (wa", -"lk f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", -" (list->vector (walk f (vector->list form))))\n ", -" (else\n form)))))\n (let ((form (cdr form)))\n ", -" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (l", -"ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr", -" form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car forma", -"l) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(", -"the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lamb", -"da (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr fo", -"rm))))\n `(let ()\n ,@(map (lambda (x)\n `(,(the 'def", -"ine-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(d", -"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr f", -"orm))))\n\n\n;;; library primitives\n\n(define (mangle name)\n (define (->string n)\n ", -" (if (symbol? n)\n (symbol->string n)\n (number->string n)))\n (de", -"fine (join strs delim)\n (let loop ((res (car strs)) (strs (cdr strs)))\n ", -"(if (null? strs)\n res\n (loop (string-append res delim (car str", -"s)) (cdr strs)))))\n (join (map ->string name) \".\"))\n\n(define-macro define-libra", -"ry\n (lambda (form _)\n (let ((lib (mangle (cadr form)))\n (body (cddr", -" form)))\n (or (find-library lib) (make-library lib))\n (for-each (lambd", -"a (expr) (eval expr lib)) body))))\n\n(define-macro cond-expand\n (lambda (form _)", -"\n (letrec\n ((test (lambda (form)\n (or\n ", -" (eq? form 'else)\n (and (symbol? form)\n ", -"(memq form (features)))\n (and (pair? form)\n ", -" (case (car form)\n ((library) (find-library (mangle (c", -"adr form))))\n ((not) (not (test (cadr form))))\n ", -" ((and) (let loop ((form (cdr form)))\n ", -" (or (null? form)\n (and (test (car fo", -"rm)) (loop (cdr form))))))\n ((or) (let loop ((form (cdr ", -"form)))\n (and (pair? form)\n ", -" (or (test (car form)) (loop (cdr form))))))\n ", -" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? ", -"clauses)\n #undefined\n (if (test (caar clauses))\n ", -" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n", -"\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x)", -" (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", -" (string->symbol\n (string-append\n (symbol->st", -"ring prefix)\n (symbol->string symbol)))))\n (getlib\n ", -" (lambda (name)\n (let ((lib (mangle name)))\n (if (", -"find-library lib)\n lib\n (error \"library not ", -"found\" name))))))\n (letrec\n ((extract\n (lambda (spec)\n ", -" (case (car spec)\n ((only rename prefix except)\n ", -" (extract (cadr spec)))\n (else\n (getli", -"b spec)))))\n (collect\n (lambda (spec)\n (case (", -"car spec)\n ((only)\n (let ((alist (collect (cadr s", -"pec))))\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ", -" ((rename)\n (let ((alist (collect (cadr spec)))\n ", -" (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec", -"))))\n (map (lambda (s) (or (assq (car s) renames) s)) alist)))", -"\n ((prefix)\n (let ((alist (collect (cadr spec))))", -"\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s)", -")) alist)))\n ((except)\n (let ((alist (collect (ca", -"dr spec))))\n (let loop ((alist alist))\n (i", -"f (null? alist)\n '()\n (if (memq ", -"(caar alist) (cddr spec))\n (loop (cdr alist))\n ", -" (cons (car alist) (loop (cdr alist))))))))\n ", -" (else\n (map (lambda (x) (cons x x)) (library-exports (getlib s", -"pec))))))))\n (letrec\n ((import\n (lambda (spec)\n ", -" (let ((lib (extract spec))\n (alist (collec", -"t spec)))\n (for-each\n (lambda (slot)\n ", -" (library-import lib (cdr slot) (car slot)))\n ", -"alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (", -"lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ", -" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ", -" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ", -" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n (", -"error \"malformed export\")))))\n (export\n (lambda (spec)\n ", -" (let ((slot (collect spec)))\n (library-export (car slot) (cd", -"r slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote ", -"set! if begin define-macro\n let let* letrec letrec*\n let-values le", -"t*-values define-values\n quasiquote unquote unquote-splicing\n and ", -"or\n cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syn", -"tax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", +" (body (cdr (cdr form))))\n (if (null? formal)\n `(,the-begin ", +",@body)\n (let ((bind (car formal)))\n `(,(the 'dynamic-bind) ", +",(car bind) ,(cadr bind)\n (,the-lambda () (,(the 'parameterize) ,(c", +"dr formal) ,@body))))))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (", +"let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", +" (let ((x (assq var renames)))\n (if x\n ", +" (cadr x)\n (begin\n ", +" (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ", +"',var ',env)) . ,renames))\n (rename var))))))\n ", +" (walk (lambda (f form)\n (cond\n ((ident", +"ifier? form)\n (f form))\n ((pair? form)\n ", +" `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ", +" ((vector? form)\n `(,(the 'list->vector) (wal", +"k f (vector->list form))))\n (else\n `(,(th", +"e 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n ", +"`(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-ma", +"cro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letre", +"c\n ((rename (lambda (var)\n (let ((x (assq var renam", +"es)))\n (if x\n (cadr x)\n ", +" (begin\n (set! renames `((,var ,(ma", +"ke-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? ", +"form)\n (and (pair? form)\n (identifier? (car form))\n ", +" (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env)", +")))\n\n (define (syntax-unquote? form)\n (and (pair? form)\n ", +" (identifier? (car form))\n (identifier=? (the 'syntax-unquot", +"e) (make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing", +"? form)\n (and (pair? form)\n (pair? (car form))\n ", +" (identifier? (caar form))\n (identifier=? (the 'syntax-unquote", +"-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth expr)", +"\n (cond\n ;; syntax-unquote\n ((syntax-unquote? expr)", +"\n (if (= depth 1)\n (car (cdr expr))\n (l", +"ist (the 'list)\n (list (the 'quote) (the 'syntax-unquote))\n", +" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-", +"unquote-splicing\n ((syntax-unquote-splicing? expr)\n (if (= ", +"depth 1)\n (list (the 'append)\n (car (cdr (ca", +"r expr)))\n (qq depth (cdr expr)))\n (list (th", +"e 'cons)\n (list (the 'list)\n (li", +"st (the 'quote) (the 'syntax-unquote-splicing))\n (qq ", +"(- depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr))", +")))\n ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n ", +" (list (the 'list)\n (list (the 'quote) (the 'quasiquote))\n", +" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ", +" ((pair? expr)\n (list (the 'cons)\n (qq depth (car", +" expr))\n (qq depth (cdr expr))))\n ;; vector\n ", +" ((vector? expr)\n (list (the 'list->vector) (qq depth (vector->list ", +"expr))))\n ;; identifier\n ((identifier? expr)\n (re", +"name expr))\n ;; simple datum\n (else\n (list (the '", +"quote) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'let", +")\n ,(map cdr renames)\n ,body))))))\n\n(define (transformer f", +")\n (lambda (form env)\n (let ((ephemeron1 (make-ephemeron))\n (epheme", +"ron2 (make-ephemeron)))\n (letrec\n ((wrap (lambda (var1)\n ", +" (let ((var2 (ephemeron1 var1)))\n (if var2\n ", +" (cdr var2)\n (let ((var2 (make-identifier", +" var1 env)))\n (ephemeron1 var1 var2)\n ", +" (ephemeron2 var2 var1)\n var2)))))\n ", +" (unwrap (lambda (var2)\n (let ((var1 (ephemeron2 var2)))\n ", +" (if var1\n (cdr var1)\n ", +" var2))))\n (walk (lambda (f form)\n (con", +"d\n ((identifier? form)\n (f form))\n ", +" ((pair? form)\n (cons (walk f (car form)) (walk ", +"f (cdr form))))\n ((vector? form)\n (list->", +"vector (walk f (vector->list form))))\n (else\n ", +" form)))))\n (let ((form (cdr form)))\n (walk unwrap (apply f ", +"(walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (l", +"et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pa", +"ir? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr f", +"ormal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,the", +"-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ", +"((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ", +" ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(", +"cadr x)))\n formal)\n ,@body))))\n\n(define-macro let-syntax\n", +" (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library p", +"rimitives\n\n(define (mangle name)\n (define (->string n)\n (if (symbol? n)\n ", +" (symbol->string n)\n (number->string n)))\n (define (join strs delim)\n", +" (let loop ((res (car strs)) (strs (cdr strs)))\n (if (null? strs)\n ", +" res\n (loop (string-append res delim (car strs)) (cdr strs)))))\n (j", +"oin (map ->string name) \".\"))\n\n(define-macro define-library\n (lambda (form _)\n ", +" (let ((lib (mangle (cadr form)))\n (body (cddr form)))\n (or (fin", +"d-library lib) (make-library lib))\n (for-each (lambda (expr) (eval expr lib", +")) body))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((", +"test (lambda (form)\n (or\n (eq? form 'else)\n ", +" (and (symbol? form)\n (memq form (features)))", +"\n (and (pair? form)\n (case (car form)\n ", +" ((library) (find-library (mangle (cadr form))))\n ", +" ((not) (not (test (cadr form))))\n ((and) ", +"(let loop ((form (cdr form)))\n (or (null? form)", +"\n (and (test (car form)) (loop (cdr form)))", +")))\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or (t", +"est (car form)) (loop (cdr form))))))\n (else #f)))))))\n ", +" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #u", +"ndefined\n (if (test (caar clauses))\n `(,the-begin ,@(c", +"dar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n ", +" (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n", +" (prefix\n (lambda (prefix symbol)\n (string->symbo", +"l\n (string-append\n (symbol->string prefix)\n ", +" (symbol->string symbol)))))\n (getlib\n (lambda (name)\n ", +" (let ((lib (mangle name)))\n (if (find-library lib)\n ", +" lib\n (error \"library not found\" name))))))\n ", +" (letrec\n ((extract\n (lambda (spec)\n (case (car", +" spec)\n ((only rename prefix except)\n (extract (c", +"adr spec)))\n (else\n (getlib spec)))))\n ", +"(collect\n (lambda (spec)\n (case (car spec)\n ", +" ((only)\n (let ((alist (collect (cadr spec))))\n ", +" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((rename", +")\n (let ((alist (collect (cadr spec)))\n (r", +"enames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", +" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pref", +"ix)\n (let ((alist (collect (cadr spec))))\n (ma", +"p (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", +" ((except)\n (let ((alist (collect (cadr spec))))\n ", +" (let loop ((alist alist))\n (if (null? alist)\n ", +" '()\n (if (memq (caar alist) (cddr spec", +"))\n (loop (cdr alist))\n ", +"(cons (car alist) (loop (cdr alist))))))))\n (else\n ", +" (map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))\n (le", +"trec\n ((import\n (lambda (spec)\n (let ((", +"lib (extract spec))\n (alist (collect spec)))\n ", +" (for-each\n (lambda (slot)\n (librar", +"y-import lib (cdr slot) (car slot)))\n alist)))))\n (f", +"or-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (le", +"trec\n ((collect\n (lambda (spec)\n (cond\n (", +"(symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec) (", +"= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) ", +". ,(list-ref spec 2)))\n (else\n (error \"malformed export", +"\")))))\n (export\n (lambda (spec)\n (let ((slot (coll", +"ect spec)))\n (library-export (car slot) (cdr slot))))))\n (for", +"-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-ma", +"cro\n let let* letrec letrec*\n let-values let*-values define-values", +"\n quasiquote unquote unquote-splicing\n and or\n cond case el", +"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", "", "" }; diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 2f3e8ce9..dc34f2a2 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -16,7 +16,6 @@ struct pic_cont { ptrdiff_t ci_offset; ptrdiff_t xp_offset; size_t arena_idx; - pic_value ptable; struct code *ip; 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->arena_idx = pic->arena_idx; cont->ip = pic->ip; - cont->ptable = pic->ptable; cont->prev = pic->cc; cont->retc = 0; 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->arena_idx = cont->arena_idx; pic->ip = cont->ip; - pic->ptable = cont->ptable; 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) { struct checkpoint *here; pic_value val; + assert(pic_proc_p(pic, thunk)); + pic_call(pic, in, 0); /* enter */ here = pic->cp; diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index d47ed186..ad4592a7 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -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, "(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")); } else { trace = pic_str_cat(pic, trace, pic_lit_value(pic, " (unknown location)\n")); /* TODO */ diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c index 2564f60c..26b6e66e 100644 --- a/extlib/benz/eval.c +++ b/extlib/benz/eval.c @@ -1050,22 +1050,13 @@ pic_compile(pic_state *pic, pic_value obj) size_t ai = pic_enter(pic); #if 0 - fprintf(stdout, "ai = %zu\n", pic_enter(pic)); - - fprintf(stdout, "# input expression\n"); - pic_write(pic, obj); - fprintf(stdout, "\n"); - - fprintf(stdout, "ai = %zu\n", pic_enter(pic)); + pic_printf(pic, "# input expression\n~s\n", obj); #endif /* optimize */ obj = pic_optimize(pic, obj); #if 0 - fprintf(stdout, "## optimize completed\n"); - pic_write(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_enter(pic)); + pic_printf(pic, "## optimize completed\n~s\n", obj); #endif SAVE(pic, ai, obj); @@ -1073,10 +1064,7 @@ pic_compile(pic_state *pic, pic_value obj) /* analyze */ obj = pic_analyze(pic, obj); #if 0 - fprintf(stdout, "## analyzer completed\n"); - pic_write(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_enter(pic)); + pic_printf(pic, "## analyzer completed\n~s\n", obj); #endif SAVE(pic, ai, obj); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 23ddd5e0..9bbec745 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -467,9 +467,6 @@ gc_mark_phase(pic_state *pic) /* features */ gc_mark(pic, pic->features); - /* parameter table */ - gc_mark(pic, pic->ptable); - /* library table */ for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) { if (! kh_exist(&pic->ltable, it)) { diff --git a/extlib/benz/include/picrin/private/object.h b/extlib/benz/include/picrin/private/object.h index 2dedfcec..f92db235 100644 --- a/extlib/benz/include/picrin/private/object.h +++ b/extlib/benz/include/picrin/private/object.h @@ -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_decref(pic_state *, struct rope *); -#define pic_func_p(proc) (pic_type(pic, proc) == PIC_TYPE_FUNC) -#define pic_irep_p(proc) (pic_type(pic, proc) == PIC_TYPE_IREP) +#define pic_func_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_FUNC) +#define pic_irep_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_IREP) 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) diff --git a/extlib/benz/include/picrin/private/state.h b/extlib/benz/include/picrin/private/state.h index a5ea7ae8..9a59574d 100644 --- a/extlib/benz/include/picrin/private/state.h +++ b/extlib/benz/include/picrin/private/state.h @@ -54,8 +54,6 @@ struct pic_state { struct code *ip; - pic_value ptable; /* list of ephemerons */ - struct lib *lib; pic_value features; diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 66061ade..93cb3831 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -918,7 +918,7 @@ pic_closure_ref(pic_state *pic, int n) { 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) { 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); - assert(pic_func_p(self)); + assert(pic_func_p(pic, self)); 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)); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index bbbc28d7..95918308 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -290,9 +290,6 @@ pic_open(pic_allocf allocf, void *userdata) xfopen_null(pic, "w"); #endif - /* parameter table */ - pic->ptable = pic_nil_value(pic); - /* native stack marker */ pic->native_stack_start = &t; @@ -306,9 +303,6 @@ pic_open(pic_allocf allocf, void *userdata) pic->cp->depth = 0; pic->cp->in = pic->cp->out = NULL; - /* parameter table */ - pic->ptable = pic_cons(pic, pic_make_weak(pic), pic_nil_value(pic)); - /* standard libraries */ pic_make_library(pic, "picrin.user"); pic_in_library(pic, "picrin.user"); diff --git a/extlib/benz/var.c b/extlib/benz/var.c index 72105734..4418a8dc 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -8,28 +8,12 @@ #include "picrin/private/state.h" 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; - - pic_for_each (weak, pic->ptable, it) { - if (pic_weak_has(pic, weak, var)) { - return pic_weak_ref(pic, weak, var); - } + if (! pic_false_p(pic, conv)) { + val = pic_call(pic, conv, 1, val); } - PIC_UNREACHABLE(); -} - -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); + return val; } static pic_value @@ -41,28 +25,48 @@ var_call(pic_state *pic) n = pic_get_args(pic, "&|o", &self, &val); if (n == 0) { - return var_get(pic, self); + return pic_closure_ref(pic, 0); } else { - pic_value conv; - conv = pic_closure_ref(pic, 0); - if (! pic_false_p(pic, conv)) { - val = pic_call(pic, conv, 1, val); - } - return var_set(pic, self, val); + pic_closure_set(pic, 0, var_conv(pic, val, pic_closure_ref(pic, 1))); + + return pic_undef_value(pic); } } pic_value 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 @@ -76,24 +80,22 @@ pic_var_make_parameter(pic_state *pic) } 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); - - pic->ptable = pic_cdr(pic, pic->ptable); - - return val; + return pic_dynamic_bind(pic, var, val, thunk); } void pic_init_var(pic_state *pic) { 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); } diff --git a/t/issue/parameterize.scm b/t/issue/parameterize.scm new file mode 100644 index 00000000..699c47cd --- /dev/null +++ b/t/issue/parameterize.scm @@ -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)