make-register -> make-ephemeron
This commit is contained in:
Yuichi Nishiwaki
parent
b577b2d453
commit
271a4b6586
|
|
@ -1,6 +1,6 @@
|
|||
(define-library (picrin base)
|
||||
|
||||
(define attribute-table (make-register))
|
||||
(define attribute-table (make-ephemeron))
|
||||
|
||||
(define (attribute obj)
|
||||
(let ((r (attribute-table obj)))
|
||||
|
|
|
|||
|
|
@ -40,13 +40,13 @@
|
|||
|
||||
(define (make-syntactic-closure env free form)
|
||||
(letrec
|
||||
((wrap (let ((register (make-register)))
|
||||
((wrap (let ((ephemeron (make-ephemeron)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(let ((id (ephemeron var)))
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var env)))
|
||||
(register var id)
|
||||
(ephemeron var id)
|
||||
id))))))
|
||||
(walk (lambda (f form)
|
||||
(cond
|
||||
|
|
@ -102,13 +102,13 @@
|
|||
(define (er-transformer f)
|
||||
(lambda (form use-env mac-env)
|
||||
(letrec
|
||||
((rename (let ((register (make-register)))
|
||||
((rename (let ((ephemeron (make-ephemeron)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(let ((id (ephemeron var)))
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var mac-env)))
|
||||
(register var id)
|
||||
(ephemeron var id)
|
||||
id))))))
|
||||
(compare (lambda (x y)
|
||||
(identifier=?
|
||||
|
|
@ -118,27 +118,27 @@
|
|||
|
||||
(define (ir-transformer f)
|
||||
(lambda (form use-env mac-env)
|
||||
(let ((register1 (make-register))
|
||||
(register2 (make-register)))
|
||||
(let ((ephemeron1 (make-ephemeron))
|
||||
(ephemeron2 (make-ephemeron)))
|
||||
(letrec
|
||||
((inject (lambda (var1)
|
||||
(let ((var2 (register1 var1)))
|
||||
(let ((var2 (ephemeron1 var1)))
|
||||
(if var2
|
||||
(cdr var2)
|
||||
(let ((var2 (make-identifier var1 use-env)))
|
||||
(register1 var1 var2)
|
||||
(register2 var2 var1)
|
||||
(ephemeron1 var1 var2)
|
||||
(ephemeron2 var2 var1)
|
||||
var2)))))
|
||||
(rename (let ((register (make-register)))
|
||||
(rename (let ((ephemeron (make-ephemeron)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(let ((id (ephemeron var)))
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var mac-env)))
|
||||
(register var id)
|
||||
(ephemeron var id)
|
||||
id))))))
|
||||
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
|
||||
(let ((var1 (register2 var2)))
|
||||
(let ((var1 (ephemeron2 var2)))
|
||||
(if var1
|
||||
(cdr var1)
|
||||
(rename var2)))))
|
||||
|
|
|
|||
|
|
@ -360,13 +360,13 @@
|
|||
#`(call-with-current-environment
|
||||
(lambda (env)
|
||||
(letrec
|
||||
((#,'rename (let ((reg (make-register)))
|
||||
((#,'rename (let ((wm (make-ephemeron)))
|
||||
(lambda (x)
|
||||
(let ((y (reg x)))
|
||||
(let ((y (wm x)))
|
||||
(if y
|
||||
(cdr y)
|
||||
(let ((id (make-identifier x env)))
|
||||
(reg x id)
|
||||
(wm x id)
|
||||
id)))))))
|
||||
(lambda #,'it
|
||||
#,(compile-rules rules))))))
|
||||
|
|
|
|||
|
|
@ -488,19 +488,19 @@ my $src = <<'EOL';
|
|||
|
||||
(define (transformer f)
|
||||
(lambda (form env)
|
||||
(let ((register1 (make-register))
|
||||
(register2 (make-register)))
|
||||
(let ((ephemeron1 (make-ephemeron))
|
||||
(ephemeron2 (make-ephemeron)))
|
||||
(letrec
|
||||
((wrap (lambda (var1)
|
||||
(let ((var2 (register1 var1)))
|
||||
(let ((var2 (ephemeron1 var1)))
|
||||
(if var2
|
||||
(cdr var2)
|
||||
(let ((var2 (make-identifier var1 env)))
|
||||
(register1 var1 var2)
|
||||
(register2 var2 var1)
|
||||
(ephemeron1 var1 var2)
|
||||
(ephemeron2 var2 var1)
|
||||
var2)))))
|
||||
(unwrap (lambda (var2)
|
||||
(let ((var1 (register2 var2)))
|
||||
(let ((var1 (ephemeron2 var2)))
|
||||
(if var1
|
||||
(cdr var1)
|
||||
var2))))
|
||||
|
|
@ -925,85 +925,85 @@ const char pic_boot[][80] = {
|
|||
"? 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 ((register1 (make-registe",
|
||||
"r))\n (register2 (make-register)))\n (letrec\n ((wrap (lambd",
|
||||
"a (var1)\n (let ((var2 (register1 var1)))\n ",
|
||||
"(if var2\n (cdr var2)\n (let ((var",
|
||||
"2 (make-identifier var1 env)))\n (register1 var1 var2)\n",
|
||||
" (register2 var2 var1)\n var2",
|
||||
")))))\n (unwrap (lambda (var2)\n (let ((var1 (regist",
|
||||
"er2 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 (walk f (ca",
|
||||
"r 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 u",
|
||||
"nwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (f",
|
||||
"orm env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)))",
|
||||
")\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the",
|
||||
"-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'tra",
|
||||
"nsformer) (,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-synt",
|
||||
"ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma",
|
||||
"cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n",
|
||||
"\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l",
|
||||
"et ((name (cadr form))\n (body (cddr form)))\n (let ((new-library (o",
|
||||
"r (find-library name) (make-library name))))\n (for-each (lambda (expr) (e",
|
||||
"val expr new-library)) 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 (m",
|
||||
"emq form (features)))\n (and (pair? form)\n ",
|
||||
" (case (car form)\n ((library) (find-library (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 (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 `(,th",
|
||||
"e-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-ma",
|
||||
"cro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr ",
|
||||
"(cdr x)))))\n (prefix\n (lambda (prefix symbol)\n (s",
|
||||
"tring->symbol\n (string-append\n (symbol->string prefix",
|
||||
")\n (symbol->string symbol))))))\n (letrec\n ((extract\n",
|
||||
" (lambda (spec)\n (case (car spec)\n ((only",
|
||||
" rename prefix except)\n (extract (cadr spec)))\n (",
|
||||
"else\n (or (find-library spec) (error \"library not found\" 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 ",
|
||||
"\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-macro define-library\n (lambda (form _",
|
||||
")\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((new-li",
|
||||
"brary (or (find-library name) (make-library name))))\n (for-each (lambda (",
|
||||
"expr) (eval expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (f",
|
||||
"orm _)\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 (cad",
|
||||
"r 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 for",
|
||||
"m)))\n (and (pair? form)\n ",
|
||||
" (or (test (car form)) (loop (cdr form))))))\n ",
|
||||
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? cla",
|
||||
"uses)\n #undefined\n (if (test (caar clauses))\n ",
|
||||
" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(d",
|
||||
"efine-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (c",
|
||||
"ar (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ",
|
||||
" (string->symbol\n (string-append\n (symbol->strin",
|
||||
"g prefix)\n (symbol->string symbol))))))\n (letrec\n ((",
|
||||
"extract\n (lambda (spec)\n (case (car spec)\n ",
|
||||
" ((only rename prefix except)\n (extract (cadr spec)))\n ",
|
||||
" (else\n (or (find-library spec) (error \"library not found\"",
|
||||
" 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 (cadr spec)",
|
||||
")))\n (let loop ((alist alist))\n (if (null?",
|
||||
" alist)\n '()\n (if (memq (caar al",
|
||||
"ist) (cddr spec))\n (loop (cdr alist))\n ",
|
||||
" (cons (car alist) (loop (cdr alist))))))))\n (else\n",
|
||||
" (let ((lib (or (find-library spec) (error \"library not found\" s",
|
||||
"pec))))\n (map (lambda (x) (cons x x)) (library-exports lib))))",
|
||||
"))))\n (letrec\n ((import\n (lambda (spec)\n ",
|
||||
" (let ((lib (extract spec))\n (alist (collect 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 (con",
|
||||
"d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an",
|
||||
"d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l",
|
||||
"ist-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) (cdr 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 let*-valu",
|
||||
"es 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 syntax-unq",
|
||||
"uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\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 (let ((lib (or (find-library spec) (error \"library not ",
|
||||
"found\" spec))))\n (map (lambda (x) (cons x x)) (library-exports",
|
||||
" lib))))))))\n (letrec\n ((import\n (lambda (spec)\n",
|
||||
" (let ((lib (extract spec))\n (alist (colle",
|
||||
"ct 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) (c",
|
||||
"dr 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 l",
|
||||
"et*-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 sy",
|
||||
"ntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ struct pic_state {
|
|||
|
||||
pic_code *ip;
|
||||
|
||||
pic_value ptable; /* list of registers */
|
||||
pic_value ptable; /* list of ephemerons */
|
||||
|
||||
struct pic_lib *lib, *prev_lib;
|
||||
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ pic_weak_del(pic_state *pic, struct pic_weak *weak, void *key)
|
|||
|
||||
it = kh_get(weak, h, key);
|
||||
if (it == kh_end(h)) {
|
||||
pic_errorf(pic, "no slot named ~s found in register", pic_obj_value(key));
|
||||
pic_errorf(pic, "no slot named ~s found in ephemeron", pic_obj_value(key));
|
||||
}
|
||||
kh_del(weak, h, it);
|
||||
}
|
||||
|
|
@ -112,7 +112,7 @@ weak_call(pic_state *pic)
|
|||
n = pic_get_args(pic, "&o|o", &self, &key, &val);
|
||||
|
||||
if (! pic_obj_p(key)) {
|
||||
pic_errorf(pic, "attempted to set a non-object key '~s' in a register", key);
|
||||
pic_errorf(pic, "attempted to set a non-object key '~s' in an ephemeron", key);
|
||||
}
|
||||
|
||||
weak = pic_weak_ptr(pic_proc_env_ref(pic, self, "weak"));
|
||||
|
|
@ -125,7 +125,7 @@ weak_call(pic_state *pic)
|
|||
}
|
||||
|
||||
static pic_value
|
||||
pic_weak_make_register(pic_state *pic)
|
||||
pic_weak_make_ephemeron(pic_state *pic)
|
||||
{
|
||||
struct pic_weak *weak;
|
||||
struct pic_proc *proc;
|
||||
|
|
@ -144,5 +144,5 @@ pic_weak_make_register(pic_state *pic)
|
|||
void
|
||||
pic_init_weak(pic_state *pic)
|
||||
{
|
||||
pic_defun(pic, "make-register", pic_weak_make_register);
|
||||
pic_defun(pic, "make-ephemeron", pic_weak_make_ephemeron);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue