[bugfix] make-parameter is broken
This commit is contained in:
Yuichi Nishiwaki
parent
4c6fe54d34
commit
34331dad6f
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)) {
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -54,8 +54,6 @@ struct pic_state {
|
|||
|
||||
struct code *ip;
|
||||
|
||||
pic_value ptable; /* list of ephemerons */
|
||||
|
||||
struct lib *lib;
|
||||
|
||||
pic_value features;
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue