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

make-ephemeron -> make-ephemeron-table

This commit is contained in:
Yuichi Nishiwaki 2017-03-31 15:59:22 +09:00
parent fc7b9a50f9
commit 690384c5b4
7 changed files with 75 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Makefile
View File

@ -1,7 +1,6 @@
LIBPICRIN_SRCS = \
lib/blob.c\
lib/bool.c\
lib/boot.c\
lib/char.c\
lib/cont.c\
lib/data.c\
@ -20,6 +19,7 @@ LIBPICRIN_SRCS = \
lib/var.c\
lib/vector.c\
lib/weak.c\
lib/ext/boot.c\
lib/ext/eval.c\
lib/ext/lib.c\
lib/ext/load.c\
@ -73,8 +73,8 @@ src/init_contrib.c:
# libpicrin.so: $(LIBPICRIN_OBJS)
# $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
lib/boot.c: piclib/boot.scm
bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/boot.c
lib/ext/boot.c: piclib/boot.scm
bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/ext/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h
@ -93,7 +93,7 @@ test: test-contribs test-nostdlib test-issue
test-contribs: picrin $(CONTRIB_TESTS)
test-nostdlib: lib/boot.c
test-nostdlib: lib/ext/boot.c
$(CC) -I./lib -I./lib/include -D'PIC_USE_LIBC=0' -D'PIC_USE_STDIO=0' -D'PIC_USE_WRITE=0' -ffreestanding -nostdlib -Os -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o libpicrin-tiny.so $(LIBPICRIN_SRCS) etc/libc_polyfill.c -fno-stack-protector
strip libpicrin-tiny.so
ls -lh libpicrin-tiny.so
@ -119,7 +119,7 @@ install: all
clean:
$(RM) picrin
$(RM) src/load_piclib.c src/init_contrib.c lib/boot.c
$(RM) src/load_piclib.c src/init_contrib.c lib/ext/boot.c
$(RM) libpicrin.so libpicrin-tiny.so
$(RM) $(LIBPICRIN_OBJS)
$(RM) $(PICRIN_OBJS)

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

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

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

@ -40,7 +40,7 @@
(define (make-syntactic-closure env free form)
(letrec
((wrap (let ((ephemeron (make-ephemeron)))
((wrap (let ((ephemeron (make-ephemeron-table)))
(lambda (var)
(let ((id (ephemeron var)))
(if id
@ -102,7 +102,7 @@
(define (er-transformer f)
(lambda (form use-env mac-env)
(letrec
((rename (let ((ephemeron (make-ephemeron)))
((rename (let ((ephemeron (make-ephemeron-table)))
(lambda (var)
(let ((id (ephemeron var)))
(if id
@ -118,8 +118,8 @@
(define (ir-transformer f)
(lambda (form use-env mac-env)
(let ((ephemeron1 (make-ephemeron))
(ephemeron2 (make-ephemeron)))
(let ((ephemeron1 (make-ephemeron-table))
(ephemeron2 (make-ephemeron-table)))
(letrec
((inject (lambda (var1)
(let ((var2 (ephemeron1 var1)))
@ -129,7 +129,7 @@
(ephemeron1 var1 var2)
(ephemeron2 var2 var1)
var2)))))
(rename (let ((ephemeron (make-ephemeron)))
(rename (let ((ephemeron (make-ephemeron-table)))
(lambda (var)
(let ((id (ephemeron var)))
(if id

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

@ -359,7 +359,7 @@
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((wm (make-ephemeron)))
((#,'rename (let ((wm (make-ephemeron-table)))
(lambda (x)
(let ((y (wm x)))
(if y

118
lib/boot.c → lib/ext/boot.c
View File

@ -152,65 +152,65 @@ static const char boot_rom[][80] = {
"pr)))) ((vector? expr) (list (the 'list->vector) (qq depth (vector->list expr)))",
") ((identifier? expr) (rename expr)) (else (list (the 'quote) expr)))) (let ((bo",
"dy (qq 1 (cadr form)))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (tr",
"ansformer f) (lambda (form env) (let ((ephemeron1 (make-ephemeron)) (ephemeron2 ",
"(make-ephemeron))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1)))",
" (if var2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 v",
"ar2) (ephemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (epheme",
"ron2 var2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identif",
"ier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form))",
")) ((vector? form) (list->vector (walk f (vector->list form)))) (else form))))) ",
"(let ((form (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-m",
"acro define-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr",
" (cdr form)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-la",
"mbda ,(cdr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,t",
"he-begin ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((for",
"mal (car (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(t",
"he 'define-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syn",
"tax (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle n",
"ame) (when (null? name) (error \"library name should be a list of at least one sy",
"mbols\" name)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string",
" n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\/)) (err",
"or \"elements of library name may not contain '.' or '/'\" n))) str) str)) ((and (",
"number? n) (exact? n)) (number->string n)) (else (error \"symbol or integer is re",
"quired\" n)))) (define (join strs delim) (let loop ((res (car strs)) (strs (cdr s",
"trs))) (if (null? strs) res (loop (string-append res delim (car strs)) (cdr strs",
"))))) (join (map ->string name) \".\")) (define-macro define-library (lambda (form",
" _) (let ((lib (mangle (cadr form))) (body (cddr form))) (or (find-library lib) ",
"(make-library lib)) (for-each (lambda (expr) (eval expr lib)) body)))) (define-m",
"acro cond-expand (lambda (form _) (letrec ((test (lambda (form) (or (eq? form 'e",
"lse) (and (symbol? form) (memq form (features))) (and (pair? form) (case (car fo",
"rm) ((library) (find-library (mangle (cadr form)))) ((not) (not (test (cadr form",
")))) ((and) (let loop ((form (cdr form))) (or (null? form) (and (test (car form)",
") (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (and (pair? form) (o",
"r (test (car form)) (loop (cdr form)))))) (else #f))))))) (let loop ((clauses (c",
"dr form))) (if (null? clauses) #undefined (if (test (caar clauses)) `(,the-begin",
" ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (lambda (form",
" _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (prefix symbo",
"l) (string->symbol (string-append (symbol->string prefix) (symbol->string symbol",
"))))) (getlib (lambda (name) (let ((lib (mangle name))) (if (find-library lib) l",
"ib (error \"library not found\" name)))))) (letrec ((extract (lambda (spec) (case ",
"(car spec) ((only rename prefix except) (extract (cadr spec))) (else (getlib spe",
"c))))) (collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (c",
"adr spec)))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ",
"((alist (collect (cadr spec))) (renames (map (lambda (x) `((car x) cadr x)) (cdd",
"r spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix) (l",
"et ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec) (",
"car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (let l",
"oop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec)) (l",
"oop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (map (lambda (",
"x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((import (lambda (s",
"pec) (let ((lib (extract spec)) (alist (collect spec))) (for-each (lambda (slot)",
" (library-import lib (cdr slot) (car slot))) alist))))) (for-each import (cdr fo",
"rm))))))) (define-macro export (lambda (form _) (letrec ((collect (lambda (spec)",
" (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= (length spec",
") 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-ref spec 2))) ",
"(else (error \"malformed export\"))))) (export (lambda (spec) (let ((slot (collect",
" spec))) (library-export (car slot) (cdr slot)))))) (for-each export (cdr form))",
"))) (export define lambda quote set! if begin define-macro let let* letrec letre",
"c* let-values let*-values define-values quasiquote unquote unquote-splicing and ",
"or cond case else => do when unless parameterize define-syntax syntax-quote synt",
"ax-unquote syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax sy",
"ntax-error) ",
"ansformer f) (lambda (form env) (let ((ephemeron1 (make-ephemeron-table)) (ephem",
"eron2 (make-ephemeron-table))) (letrec ((wrap (lambda (var1) (let ((var2 (epheme",
"ron1 var1))) (if var2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephem",
"eron1 var1 var2) (ephemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((",
"var1 (ephemeron2 var2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (co",
"nd ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f",
" (cdr form)))) ((vector? form) (list->vector (walk f (vector->list form)))) (els",
"e form))))) (let ((form (cdr form))) (walk unwrap (apply f (walk wrap form))))))",
")) (define-macro define-syntax (lambda (form env) (let ((formal (car (cdr form))",
") (body (cdr (cdr form)))) (if (pair? formal) `(,(the 'define-syntax) ,(car form",
"al) (,the-lambda ,(cdr formal) ,@body)) `(,the-define-macro ,formal (,(the 'tran",
"sformer) (,the-begin ,@body))))))) (define-macro letrec-syntax (lambda (form env",
") (let ((formal (car (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lamb",
"da (x) `(,(the 'define-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-m",
"acro let-syntax (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (defi",
"ne (mangle name) (when (null? name) (error \"library name should be a list of at ",
"least one symbols\" name)) (define (->string n) (cond ((symbol? n) (let ((str (sy",
"mbol->string n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (char=? ",
"c #\\/)) (error \"elements of library name may not contain '.' or '/'\" n))) str) s",
"tr)) ((and (number? n) (exact? n)) (number->string n)) (else (error \"symbol or i",
"nteger is required\" n)))) (define (join strs delim) (let loop ((res (car strs)) ",
"(strs (cdr strs))) (if (null? strs) res (loop (string-append res delim (car strs",
")) (cdr strs))))) (join (map ->string name) \".\")) (define-macro define-library (",
"lambda (form _) (let ((lib (mangle (cadr form))) (body (cddr form))) (or (find-l",
"ibrary lib) (make-library lib)) (for-each (lambda (expr) (eval expr lib)) body))",
")) (define-macro cond-expand (lambda (form _) (letrec ((test (lambda (form) (or ",
"(eq? form 'else) (and (symbol? form) (memq form (features))) (and (pair? form) (",
"case (car form) ((library) (find-library (mangle (cadr form)))) ((not) (not (tes",
"t (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (and (tes",
"t (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (and (pa",
"ir? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let loop ",
"((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clauses)) ",
"`(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (",
"lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (",
"prefix symbol) (string->symbol (string-append (symbol->string prefix) (symbol->s",
"tring symbol))))) (getlib (lambda (name) (let ((lib (mangle name))) (if (find-li",
"brary lib) lib (error \"library not found\" name)))))) (letrec ((extract (lambda (",
"spec) (case (car spec) ((only rename prefix except) (extract (cadr spec))) (else",
" (getlib spec))))) (collect (lambda (spec) (case (car spec) ((only) (let ((alist",
" (collect (cadr spec)))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((r",
"ename) (let ((alist (collect (cadr spec))) (renames (map (lambda (x) `((car x) c",
"adr x)) (cddr spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ",
"((prefix) (let ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (c",
"addr spec) (car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spe",
"c)))) (let loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cd",
"dr spec)) (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (m",
"ap (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((impor",
"t (lambda (spec) (let ((lib (extract spec)) (alist (collect spec))) (for-each (l",
"ambda (slot) (library-import lib (cdr slot) (car slot))) alist))))) (for-each im",
"port (cdr form))))))) (define-macro export (lambda (form _) (letrec ((collect (l",
"ambda (spec) (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= ",
"(length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-re",
"f spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let ((s",
"lot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each export",
" (cdr form))))) (export define lambda quote set! if begin define-macro let let* ",
"letrec letrec* let-values let*-values define-values quasiquote unquote unquote-s",
"plicing and or cond case else => do when unless parameterize define-syntax synta",
"x-quote syntax-unquote syntax-quasiquote syntax-unquote-splicing let-syntax letr",
"ec-syntax syntax-error) ",
};
void

4
lib/weak.c
View File

@ -97,7 +97,7 @@ weak_call(pic_state *pic)
}
static pic_value
pic_weak_make_ephemeron(pic_state *pic)
pic_weak_make_ephemeron_table(pic_state *pic)
{
pic_get_args(pic, "");
@ -107,5 +107,5 @@ pic_weak_make_ephemeron(pic_state *pic)
void
pic_init_weak(pic_state *pic)
{
pic_defun(pic, "make-ephemeron", pic_weak_make_ephemeron);
pic_defun(pic, "make-ephemeron-table", pic_weak_make_ephemeron_table);
}

4
piclib/boot.scm
View File

@ -477,8 +477,8 @@
(define (transformer f)
(lambda (form env)
(let ((ephemeron1 (make-ephemeron))
(ephemeron2 (make-ephemeron)))
(let ((ephemeron1 (make-ephemeron-table))
(ephemeron2 (make-ephemeron-table)))
(letrec
((wrap (lambda (var1)
(let ((var2 (ephemeron1 var1)))