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

make-register -> make-ephemeron

This commit is contained in:
Yuichi Nishiwaki 2016-02-10 21:57:20 +09:00
parent b577b2d453
commit 271a4b6586
6 changed files with 109 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
contrib/10.attribute/attr.scm
View File

@ -1,6 +1,6 @@
(define-library (picrin base) (define-library (picrin base)
(define attribute-table (make-register)) (define attribute-table (make-ephemeron))
(define (attribute obj) (define (attribute obj)
(let ((r (attribute-table obj))) (let ((r (attribute-table obj)))

30
contrib/10.macro/macro.scm
View File

@ -40,13 +40,13 @@
(define (make-syntactic-closure env free form) (define (make-syntactic-closure env free form)
(letrec (letrec
((wrap (let ((register (make-register))) ((wrap (let ((ephemeron (make-ephemeron)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (ephemeron var)))
(if id (if id
(cdr id) (cdr id)
(let ((id (make-identifier var env))) (let ((id (make-identifier var env)))
(register var id) (ephemeron var id)
id)))))) id))))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
@ -102,13 +102,13 @@
(define (er-transformer f) (define (er-transformer f)
(lambda (form use-env mac-env) (lambda (form use-env mac-env)
(letrec (letrec
((rename (let ((register (make-register))) ((rename (let ((ephemeron (make-ephemeron)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (ephemeron var)))
(if id (if id
(cdr id) (cdr id)
(let ((id (make-identifier var mac-env))) (let ((id (make-identifier var mac-env)))
(register var id) (ephemeron var id)
id)))))) id))))))
(compare (lambda (x y) (compare (lambda (x y)
(identifier=? (identifier=?
@ -118,27 +118,27 @@
(define (ir-transformer f) (define (ir-transformer f)
(lambda (form use-env mac-env) (lambda (form use-env mac-env)
(let ((register1 (make-register)) (let ((ephemeron1 (make-ephemeron))
(register2 (make-register))) (ephemeron2 (make-ephemeron)))
(letrec (letrec
((inject (lambda (var1) ((inject (lambda (var1)
(let ((var2 (register1 var1))) (let ((var2 (ephemeron1 var1)))
(if var2 (if var2
(cdr var2) (cdr var2)
(let ((var2 (make-identifier var1 use-env))) (let ((var2 (make-identifier var1 use-env)))
(register1 var1 var2) (ephemeron1 var1 var2)
(register2 var2 var1) (ephemeron2 var2 var1)
var2))))) var2)))))
(rename (let ((register (make-register))) (rename (let ((ephemeron (make-ephemeron)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (ephemeron var)))
(if id (if id
(cdr id) (cdr id)
(let ((id (make-identifier var mac-env))) (let ((id (make-identifier var mac-env)))
(register var id) (ephemeron var id)
id)))))) id))))))
(flip (lambda (var2) ; unwrap if injected, wrap if not injected (flip (lambda (var2) ; unwrap if injected, wrap if not injected
(let ((var1 (register2 var2))) (let ((var1 (ephemeron2 var2)))
(if var1 (if var1
(cdr var1) (cdr var1)
(rename var2))))) (rename var2)))))

6
contrib/20.r7rs/scheme/base.scm
View File

@ -360,13 +360,13 @@
#`(call-with-current-environment #`(call-with-current-environment
(lambda (env) (lambda (env)
(letrec (letrec
((#,'rename (let ((reg (make-register))) ((#,'rename (let ((wm (make-ephemeron)))
(lambda (x) (lambda (x)
(let ((y (reg x))) (let ((y (wm x)))
(if y (if y
(cdr y) (cdr y)
(let ((id (make-identifier x env))) (let ((id (make-identifier x env)))
(reg x id) (wm x id)
id))))))) id)))))))
(lambda #,'it (lambda #,'it
#,(compile-rules rules)))))) #,(compile-rules rules))))))

168
extlib/benz/boot.c
View File

@ -488,19 +488,19 @@ my $src = <<'EOL';
(define (transformer f) (define (transformer f)
(lambda (form env) (lambda (form env)
(let ((register1 (make-register)) (let ((ephemeron1 (make-ephemeron))
(register2 (make-register))) (ephemeron2 (make-ephemeron)))
(letrec (letrec
((wrap (lambda (var1) ((wrap (lambda (var1)
(let ((var2 (register1 var1))) (let ((var2 (ephemeron1 var1)))
(if var2 (if var2
(cdr var2) (cdr var2)
(let ((var2 (make-identifier var1 env))) (let ((var2 (make-identifier var1 env)))
(register1 var1 var2) (ephemeron1 var1 var2)
(register2 var2 var1) (ephemeron2 var2 var1)
var2))))) var2)))))
(unwrap (lambda (var2) (unwrap (lambda (var2)
(let ((var1 (register2 var2))) (let ((var1 (ephemeron2 var2)))
(if var1 (if var1
(cdr var1) (cdr var1)
var2)))) var2))))
@ -925,85 +925,85 @@ const char pic_boot[][80] = {
"? expr)\n (rename expr))\n ;; simple datum\n (else\n ", "? expr)\n (rename expr))\n ;; simple datum\n (else\n ",
" (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))", " (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))",
"\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n", "\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n",
"\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-registe", "\n(define (transformer f)\n (lambda (form env)\n (let ((ephemeron1 (make-epheme",
"r))\n (register2 (make-register)))\n (letrec\n ((wrap (lambd", "ron))\n (ephemeron2 (make-ephemeron)))\n (letrec\n ((wrap (l",
"a (var1)\n (let ((var2 (register1 var1)))\n ", "ambda (var1)\n (let ((var2 (ephemeron1 var1)))\n ",
"(if var2\n (cdr var2)\n (let ((var", " (if var2\n (cdr var2)\n (let ",
"2 (make-identifier var1 env)))\n (register1 var1 var2)\n", "((var2 (make-identifier var1 env)))\n (ephemeron1 var1 ",
" (register2 var2 var1)\n var2", "var2)\n (ephemeron2 var2 var1)\n ",
")))))\n (unwrap (lambda (var2)\n (let ((var1 (regist", " var2)))))\n (unwrap (lambda (var2)\n (let ((var1 ",
"er2 var2)))\n (if var1\n (cdr var1", "(ephemeron2 var2)))\n (if var1\n (",
")\n var2))))\n (walk (lambda (f form)\n ", "cdr var1)\n var2))))\n (walk (lambda (f form)\n",
" (cond\n ((identifier? form)\n (f", " (cond\n ((identifier? form)\n ",
" form))\n ((pair? form)\n (cons (walk f (ca", " (f form))\n ((pair? form)\n (cons (wa",
"r form)) (walk f (cdr form))))\n ((vector? form)\n ", "lk f (car form)) (walk f (cdr form))))\n ((vector? form)\n ",
" (list->vector (walk f (vector->list form))))\n (else\n ", " (list->vector (walk f (vector->list form))))\n ",
" form)))))\n (let ((form (cdr form)))\n (walk u", " (else\n form)))))\n (let ((form (cdr form)))\n ",
"nwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (f", " (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (l",
"orm env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)))", "ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr",
")\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the", " form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car forma",
"-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'tra", "l) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(",
"nsformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form", "the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lamb",
" env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", "da (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr fo",
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-synt", "rm))))\n `(let ()\n ,@(map (lambda (x)\n `(,(the 'def",
"ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma", "ine-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(d",
"cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n", "efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr f",
"\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l", "orm))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _",
"et ((name (cadr form))\n (body (cddr form)))\n (let ((new-library (o", ")\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((new-li",
"r (find-library name) (make-library name))))\n (for-each (lambda (expr) (e", "brary (or (find-library name) (make-library name))))\n (for-each (lambda (",
"val expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (form _)\n ", "expr) (eval expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (f",
" (letrec\n ((test (lambda (form)\n (or\n ", "orm _)\n (letrec\n ((test (lambda (form)\n (or\n ",
"(eq? form 'else)\n (and (symbol? form)\n (m", " (eq? form 'else)\n (and (symbol? form)\n ",
"emq form (features)))\n (and (pair? form)\n ", " (memq form (features)))\n (and (pair? form)\n ",
" (case (car form)\n ((library) (find-library (cadr form))", " (case (car form)\n ((library) (find-library (cad",
")\n ((not) (not (test (cadr form))))\n ", "r form)))\n ((not) (not (test (cadr form))))\n ",
" ((and) (let loop ((form (cdr form)))\n (or ", " ((and) (let loop ((form (cdr form)))\n ",
"(null? form)\n (and (test (car form)) (loop ", " (or (null? form)\n (and (test (car form)",
"(cdr form))))))\n ((or) (let loop ((form (cdr form)))\n ", ") (loop (cdr form))))))\n ((or) (let loop ((form (cdr for",
" (and (pair? form)\n ", "m)))\n (and (pair? form)\n ",
" (or (test (car form)) (loop (cdr form))))))\n (else", " (or (test (car form)) (loop (cdr form))))))\n ",
" #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", " (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? cla",
" #undefined\n (if (test (caar clauses))\n `(,th", "uses)\n #undefined\n (if (test (caar clauses))\n ",
"e-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-ma", " `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(d",
"cro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr ", "efine-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (c",
"(cdr x)))))\n (prefix\n (lambda (prefix symbol)\n (s", "ar (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ",
"tring->symbol\n (string-append\n (symbol->string prefix", " (string->symbol\n (string-append\n (symbol->strin",
")\n (symbol->string symbol))))))\n (letrec\n ((extract\n", "g prefix)\n (symbol->string symbol))))))\n (letrec\n ((",
" (lambda (spec)\n (case (car spec)\n ((only", "extract\n (lambda (spec)\n (case (car spec)\n ",
" rename prefix except)\n (extract (cadr spec)))\n (", " ((only rename prefix except)\n (extract (cadr spec)))\n ",
"else\n (or (find-library spec) (error \"library not found\" spec)))", " (else\n (or (find-library spec) (error \"library not found\"",
")))\n (collect\n (lambda (spec)\n (case (car spec", " spec))))))\n (collect\n (lambda (spec)\n (case (",
")\n ((only)\n (let ((alist (collect (cadr spec))))\n", "car spec)\n ((only)\n (let ((alist (collect (cadr s",
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ", "pec))))\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ",
" ((rename)\n (let ((alist (collect (cadr spec)))\n ", " ((rename)\n (let ((alist (collect (cadr spec)))\n ",
" (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", " (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec",
" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ", "))))\n (map (lambda (s) (or (assq (car s) renames) s)) alist)))",
" ((prefix)\n (let ((alist (collect (cadr spec))))\n ", "\n ((prefix)\n (let ((alist (collect (cadr spec))))",
" (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist", "\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s)",
")))\n ((except)\n (let ((alist (collect (cadr spec)", ")) alist)))\n ((except)\n (let ((alist (collect (ca",
")))\n (let loop ((alist alist))\n (if (null?", "dr spec))))\n (let loop ((alist alist))\n (i",
" alist)\n '()\n (if (memq (caar al", "f (null? alist)\n '()\n (if (memq ",
"ist) (cddr spec))\n (loop (cdr alist))\n ", "(caar alist) (cddr spec))\n (loop (cdr alist))\n ",
" (cons (car alist) (loop (cdr alist))))))))\n (else\n", " (cons (car alist) (loop (cdr alist))))))))\n ",
" (let ((lib (or (find-library spec) (error \"library not found\" s", " (else\n (let ((lib (or (find-library spec) (error \"library not ",
"pec))))\n (map (lambda (x) (cons x x)) (library-exports lib))))", "found\" spec))))\n (map (lambda (x) (cons x x)) (library-exports",
"))))\n (letrec\n ((import\n (lambda (spec)\n ", " lib))))))))\n (letrec\n ((import\n (lambda (spec)\n",
" (let ((lib (extract spec))\n (alist (collect spec)", " (let ((lib (extract spec))\n (alist (colle",
"))\n (for-each\n (lambda (slot)\n ", "ct spec)))\n (for-each\n (lambda (slot)\n ",
" (library-import lib (cdr slot) (car slot)))\n alist))", " (library-import lib (cdr slot) (car slot)))\n ",
")))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (lambda ", " alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n ",
"(form _)\n (letrec\n ((collect\n (lambda (spec)\n (con", "(lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ",
"d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an", " (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ",
"d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l", " ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ",
"ist-ref spec 1) . ,(list-ref spec 2)))\n (else\n (error \"", " `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ",
"malformed export\")))))\n (export\n (lambda (spec)\n (", "(error \"malformed export\")))))\n (export\n (lambda (spec)\n ",
"let ((slot (collect spec)))\n (library-export (car slot) (cdr slot)", " (let ((slot (collect spec)))\n (library-export (car slot) (c",
")))))\n (for-each export (cdr form)))))\n\n(export define lambda quote set! if", "dr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote",
" begin define-macro\n let let* letrec letrec*\n let-values let*-valu", " set! if begin define-macro\n let let* letrec letrec*\n let-values l",
"es define-values\n quasiquote unquote unquote-splicing\n and or\n ", "et*-values define-values\n quasiquote unquote unquote-splicing\n and",
" cond case else =>\n do when unless\n parameterize\n define", " or\n cond case else =>\n do when unless\n parameterize\n ",
"-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax-unq", " define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote sy",
"uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n", "ntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };

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

@ -87,7 +87,7 @@ struct pic_state {
pic_code *ip; pic_code *ip;
pic_value ptable; /* list of registers */ pic_value ptable; /* list of ephemerons */
struct pic_lib *lib, *prev_lib; struct pic_lib *lib, *prev_lib;

8
extlib/benz/weak.c
View File

@ -72,7 +72,7 @@ pic_weak_del(pic_state *pic, struct pic_weak *weak, void *key)
it = kh_get(weak, h, key); it = kh_get(weak, h, key);
if (it == kh_end(h)) { 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); kh_del(weak, h, it);
} }
@ -112,7 +112,7 @@ weak_call(pic_state *pic)
n = pic_get_args(pic, "&o|o", &self, &key, &val); n = pic_get_args(pic, "&o|o", &self, &key, &val);
if (! pic_obj_p(key)) { 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")); weak = pic_weak_ptr(pic_proc_env_ref(pic, self, "weak"));
@ -125,7 +125,7 @@ weak_call(pic_state *pic)
} }
static pic_value static pic_value
pic_weak_make_register(pic_state *pic) pic_weak_make_ephemeron(pic_state *pic)
{ {
struct pic_weak *weak; struct pic_weak *weak;
struct pic_proc *proc; struct pic_proc *proc;
@ -144,5 +144,5 @@ pic_weak_make_register(pic_state *pic)
void void
pic_init_weak(pic_state *pic) pic_init_weak(pic_state *pic)
{ {
pic_defun(pic, "make-register", pic_weak_make_register); pic_defun(pic, "make-ephemeron", pic_weak_make_ephemeron);
} }