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

ephemeron-table -> attribute

This commit is contained in:
Yuichi Nishiwaki 2017-04-30 00:23:38 +09:00
parent 4dc449b09b
commit df68b0ed72
16 changed files with 2266 additions and 2270 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
(define-library (picrin base)
(export attribute)
(define attribute-table (make-ephemeron-table))
(define attribute-table (make-attribute))
(define (attribute obj)
(or (attribute-table obj)

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

@ -53,17 +53,17 @@
(define (transformer f)
(lambda (form env)
(let ((ephemeron1 (make-ephemeron-table))
(ephemeron2 (make-ephemeron-table)))
(let ((attr1 (make-attribute))
(attr2 (make-attribute)))
(letrec
((wrap (lambda (var1)
(or (ephemeron1 var1)
(or (attr1 var1)
(let ((var2 (make-identifier var1 env)))
(ephemeron1 var1 var2)
(ephemeron2 var2 var1)
(attr1 var1 var2)
(attr2 var2 var1)
var2))))
(unwrap (lambda (var2)
(or (ephemeron2 var2)
(or (attr2 var2)
var2)))
(walk (lambda (f form)
(cond
@ -203,11 +203,11 @@
(define (make-syntactic-closure env free form)
(letrec
((wrap (let ((ephemeron (make-ephemeron-table)))
((wrap (let ((attr (make-attribute)))
(lambda (var)
(or (ephemeron var)
(or (attr var)
(let ((id (make-identifier var env)))
(ephemeron var id)
(attr var id)
id)))))
(walk (lambda (f form)
(cond
@ -263,11 +263,11 @@
(define (er-transformer f)
(lambda (form use-env mac-env)
(letrec
((rename (let ((ephemeron (make-ephemeron-table)))
((rename (let ((attr (make-attribute)))
(lambda (var)
(or (ephemeron var)
(or (attr var)
(let ((id (make-identifier var mac-env)))
(ephemeron var id)
(attr var id)
id)))))
(compare (lambda (x y)
(identifier=?
@ -277,23 +277,23 @@
(define (ir-transformer f)
(lambda (form use-env mac-env)
(let ((ephemeron1 (make-ephemeron-table))
(ephemeron2 (make-ephemeron-table)))
(let ((attr1 (make-attribute))
(attr2 (make-attribute)))
(letrec
((inject (lambda (var1)
(or (ephemeron1 var1)
(or (attr1 var1)
(let ((var2 (make-identifier var1 use-env)))
(ephemeron1 var1 var2)
(ephemeron2 var2 var1)
(attr1 var1 var2)
(attr2 var2 var1)
var2))))
(rename (let ((ephemeron (make-ephemeron-table)))
(rename (let ((attr (make-attribute)))
(lambda (var)
(or (ephemeron var)
(or (attr var)
(let ((id (make-identifier var mac-env)))
(ephemeron var id)
(attr var id)
id)))))
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
(or (ephemeron2 var2)
(or (attr2 var2)
(rename var2))))
(walk (lambda (f form)
(cond

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

@ -343,7 +343,7 @@
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((wm (make-ephemeron-table)))
((#,'rename (let ((wm (make-attribute)))
(lambda (x)
(or (wm x)
(let ((id (make-identifier x env)))

2
lib/Makefile
View File

@ -1,4 +1,5 @@
LIBPICRIN_SRCS = \
attr.c\
blob.c\
bool.c\
char.c\
@ -17,7 +18,6 @@ LIBPICRIN_SRCS = \
symbol.c\
var.c\
vector.c\
weak.c\
ext/cont.c\
ext/eval.c\
ext/read.c\

107
lib/attr.c Normal file
View File

@ -0,0 +1,107 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "object.h"
KHASH_DEFINE(attr, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
static pic_value
attr_call(pic_state *pic)
{
pic_value self, key, val;
int n;
n = pic_get_args(pic, "&o|o", &self, &key, &val);
if (! obj_p(pic, key)) {
pic_error(pic, "attempted to set a non-object key", 1, key);
}
if (n == 1) {
if (! pic_attr_has(pic, self, key)) {
return pic_false_value(pic);
}
return pic_attr_ref(pic, self, key);
} else {
if (pic_false_p(pic, val)) {
if (pic_attr_has(pic, self, key)) {
pic_attr_del(pic, self, key);
}
} else {
pic_attr_set(pic, self, key, val);
}
return pic_undef_value(pic);
}
}
pic_value
pic_make_attr(pic_state *pic)
{
struct attr *attr;
attr = (struct attr *)pic_obj_alloc(pic, PIC_TYPE_ATTR);
attr->prev = NULL;
kh_init(attr, &attr->hash);
return pic_lambda(pic, attr_call, 1, obj_value(pic, attr));
}
pic_value
pic_attr_ref(pic_state *pic, pic_value attr, pic_value key)
{
khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
int it;
it = kh_get(attr, h, obj_ptr(pic, key));
if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key);
}
return kh_val(h, it);
}
void
pic_attr_set(pic_state *pic, pic_value attr, pic_value key, pic_value val)
{
khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
int ret;
int it;
it = kh_put(attr, h, obj_ptr(pic, key), &ret);
kh_val(h, it) = val;
}
bool
pic_attr_has(pic_state *pic, pic_value attr, pic_value key)
{
khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
return kh_get(attr, h, obj_ptr(pic, key)) != kh_end(h);
}
void
pic_attr_del(pic_state *pic, pic_value attr, pic_value key)
{
khash_t(attr) *h = &attr_ptr(pic, proc_ptr(pic, attr)->env->regs[0])->hash;
int it;
it = kh_get(attr, h, obj_ptr(pic, key));
if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key);
}
kh_del(attr, h, it);
}
static pic_value
pic_attr_make_attribute(pic_state *pic)
{
pic_get_args(pic, "");
return pic_make_attr(pic);
}
void
pic_init_attr(pic_state *pic)
{
pic_defun(pic, "make-attribute", pic_attr_make_attribute);
}

8
lib/error.c
View File

@ -73,8 +73,8 @@ pic_enter_try(pic_state *pic)
handler = pic_lambda(pic, native_exception_handler, 1, cont);
/* with-exception-handler */
var = pic_exc(pic);
env = pic_make_weak(pic);
pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
env = pic_make_attr(pic);
pic_attr_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
pic_leave(pic, pic->cxt->ai);
@ -137,8 +137,8 @@ with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk)
{
pic_value var, env, r;
var = pic_exc(pic);
env = pic_make_weak(pic);
pic_weak_set(pic, env, var, handlers);
env = pic_make_attr(pic);
pic_attr_set(pic, env, var, handlers);
pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
r = pic_call(pic, thunk, 0);
pic->dyn_env = pic_cdr(pic, pic->dyn_env);

4146
lib/ext/eval.c
View File

File diff suppressed because it is too large Load Diff

30
lib/ext/write.c
View File

@ -29,8 +29,8 @@ writer_control_init(pic_state *pic, struct writer_control *p, int mode, int op)
p->mode = mode;
p->op = op;
p->cnt = 0;
p->shared = pic_make_weak(pic);
p->labels = pic_make_weak(pic);
p->shared = pic_make_attr(pic);
p->labels = pic_make_attr(pic);
}
static void
@ -48,9 +48,9 @@ traverse(pic_state *pic, pic_value obj, struct writer_control *p)
case PIC_TYPE_DICT:
case PIC_TYPE_RECORD: {
if (! pic_weak_has(pic, shared, obj)) {
if (! pic_attr_has(pic, shared, obj)) {
/* first time */
pic_weak_set(pic, shared, obj, pic_int_value(pic, 0));
pic_attr_set(pic, shared, obj, pic_int_value(pic, 0));
if (pic_pair_p(pic, obj)) {
/* pair */
@ -75,13 +75,13 @@ traverse(pic_state *pic, pic_value obj, struct writer_control *p)
}
if (p->op == OP_WRITE) {
if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) {
pic_weak_del(pic, shared, obj);
if (pic_int(pic, pic_attr_ref(pic, shared, obj)) == 0) {
pic_attr_del(pic, shared, obj);
}
}
} else {
/* second time */
pic_weak_set(pic, shared, obj, pic_int_value(pic, 1));
pic_attr_set(pic, shared, obj, pic_int_value(pic, 1));
}
break;
}
@ -97,10 +97,10 @@ is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
if (! obj_p(pic, obj)) {
return false;
}
if (! pic_weak_has(pic, shared, obj)) {
if (! pic_attr_has(pic, shared, obj)) {
return false;
}
return pic_int(pic, pic_weak_ref(pic, shared, obj)) > 0;
return pic_int(pic, pic_attr_ref(pic, shared, obj)) > 0;
}
static void
@ -369,8 +369,8 @@ typename(pic_state *pic, pic_value obj)
return "data";
case PIC_TYPE_DICT:
return "dictionary";
case PIC_TYPE_WEAK:
return "ephemeron";
case PIC_TYPE_ATTR:
return "attribute";
case PIC_TYPE_RECORD:
return "record";
default:
@ -386,13 +386,13 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
/* shared objects */
if (is_shared_object(pic, obj, p)) {
if (pic_weak_has(pic, labels, obj)) {
pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj)));
if (pic_attr_has(pic, labels, obj)) {
pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_attr_ref(pic, labels, obj)));
return;
}
i = p->cnt++;
pic_fprintf(pic, port, "#%d=", i);
pic_weak_set(pic, labels, obj, pic_int_value(pic, i));
pic_attr_set(pic, labels, obj, pic_int_value(pic, i));
}
switch (pic_type(pic, obj)) {
@ -451,7 +451,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
if (p->op == OP_WRITE) {
if (is_shared_object(pic, obj, p)) {
pic_weak_del(pic, labels, obj);
pic_attr_del(pic, labels, obj);
}
}
}

44
lib/gc.c
View File

@ -20,7 +20,7 @@ struct object {
struct pair pair;
struct vector vec;
struct dict dict;
struct weak weak;
struct attr attr;
struct data data;
struct record rec;
struct proc proc;
@ -52,7 +52,7 @@ struct heap_page {
struct heap {
union header base, *freep;
struct heap_page *pages;
struct weak *weaks; /* weak map chain */
struct attr *attrs; /* weak map chain */
};
#define unitsof(type) ((type2size(type) + sizeof(union header) - 1) / sizeof(union header))
@ -69,7 +69,7 @@ pic_heap_open(pic_state *pic)
heap->freep = &heap->base;
heap->pages = NULL;
heap->weaks = NULL;
heap->attrs = NULL;
return heap;
}
@ -304,11 +304,11 @@ gc_mark_object(pic_state *pic, struct object *obj)
LOOP(obj->u.sym.str);
break;
}
case PIC_TYPE_WEAK: {
struct weak *weak = (struct weak *)obj;
case PIC_TYPE_ATTR: {
struct attr *attr = (struct attr *)obj;
weak->prev = pic->heap->weaks;
pic->heap->weaks = weak;
attr->prev = pic->heap->attrs;
pic->heap->attrs = attr;
break;
}
default:
@ -322,7 +322,7 @@ gc_mark_phase(pic_state *pic)
struct context *cxt;
size_t j;
assert(pic->heap->weaks == NULL);
assert(pic->heap->attrs == NULL);
/* context */
for (cxt = pic->cxt; cxt != NULL; cxt = cxt->prev) {
@ -354,14 +354,14 @@ gc_mark_phase(pic_state *pic)
struct object *key;
pic_value val;
int it;
khash_t(weak) *h;
struct weak *weak;
khash_t(attr) *h;
struct attr *attr;
j = 0;
weak = pic->heap->weaks;
attr = pic->heap->attrs;
while (weak != NULL) {
h = &weak->hash;
while (attr != NULL) {
h = &attr->hash;
for (it = kh_begin(h); it != kh_end(h); ++it) {
if (! kh_exist(h, it))
continue;
@ -374,7 +374,7 @@ gc_mark_phase(pic_state *pic)
}
}
}
weak = weak->prev;
attr = attr->prev;
}
} while (j > 0);
}
@ -411,8 +411,8 @@ gc_finalize_object(pic_state *pic, struct object *obj)
/* TODO: remove this symbol's entry from pic->syms immediately */
break;
}
case PIC_TYPE_WEAK: {
kh_destroy(weak, &obj->u.weak.hash);
case PIC_TYPE_ATTR: {
kh_destroy(attr, &obj->u.attr.hash);
break;
}
case PIC_TYPE_IREP: {
@ -455,7 +455,7 @@ type2size(int type)
case PIC_TYPE_DATA: return sizeof(struct data);
case PIC_TYPE_DICT: return sizeof(struct dict);
case PIC_TYPE_SYMBOL: return sizeof(struct symbol);
case PIC_TYPE_WEAK: return sizeof(struct weak);
case PIC_TYPE_ATTR: return sizeof(struct attr);
case PIC_TYPE_IREP: return sizeof(struct irep);
case PIC_TYPE_PORT: return sizeof(struct port);
case PIC_TYPE_PAIR: return sizeof(struct pair);
@ -600,24 +600,24 @@ gc_sweep_phase(pic_state *pic)
{
struct heap_page *page;
int it;
khash_t(weak) *h;
khash_t(attr) *h;
khash_t(oblist) *s = &pic->oblist;
struct symbol *sym;
struct object *obj;
size_t total = 0, inuse = 0;
/* weak maps */
while (pic->heap->weaks != NULL) {
h = &pic->heap->weaks->hash;
while (pic->heap->attrs != NULL) {
h = &pic->heap->attrs->hash;
for (it = kh_begin(h); it != kh_end(h); ++it) {
if (! kh_exist(h, it))
continue;
obj = kh_key(h, it);
if (! is_alive(obj)) {
kh_del(weak, h, it);
kh_del(attr, h, it);
}
}
pic->heap->weaks = pic->heap->weaks->prev;
pic->heap->attrs = pic->heap->attrs->prev;
}
/* symbol table */

12
lib/include/picrin.h
View File

@ -194,14 +194,14 @@ bool pic_dict_next(pic_state *, pic_value dict, int *iter, pic_value *key, pic_v
/*
* ephemeron table
* attribute
*/
pic_value pic_make_weak(pic_state *);
pic_value pic_weak_ref(pic_state *, pic_value weak, pic_value key);
void pic_weak_set(pic_state *, pic_value weak, pic_value key, pic_value val);
void pic_weak_del(pic_state *, pic_value weak, pic_value key);
bool pic_weak_has(pic_state *, pic_value weak, pic_value key);
pic_value pic_make_attr(pic_state *);
pic_value pic_attr_ref(pic_state *, pic_value attr, pic_value key);
void pic_attr_set(pic_state *, pic_value attr, pic_value key, pic_value val);
void pic_attr_del(pic_state *, pic_value attr, pic_value key);
bool pic_attr_has(pic_state *, pic_value attr, pic_value key);
/*

4
lib/include/picrin/value.h
View File

@ -29,7 +29,7 @@ enum {
PIC_TYPE_VECTOR = 21,
PIC_TYPE_DICT = 22,
PIC_TYPE_RECORD = 23,
PIC_TYPE_WEAK = 24,
PIC_TYPE_ATTR = 24,
PIC_TYPE_PORT = 25,
PIC_TYPE_ERROR = 26,
PIC_TYPE_IREP = 27,
@ -224,7 +224,7 @@ DEFPRED(pic_vec_p, PIC_TYPE_VECTOR)
DEFPRED(pic_blob_p, PIC_TYPE_BLOB)
DEFPRED(pic_error_p, PIC_TYPE_ERROR)
DEFPRED(pic_dict_p, PIC_TYPE_DICT)
DEFPRED(pic_weak_p, PIC_TYPE_WEAK)
DEFPRED(pic_attr_p, PIC_TYPE_ATTR)
DEFPRED(pic_rec_p, PIC_TYPE_RECORD)
DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL)
DEFPRED(pic_pair_p, PIC_TYPE_PAIR)

10
lib/object.h
View File

@ -52,12 +52,12 @@ struct dict {
khash_t(dict) hash;
};
KHASH_DECLARE(weak, struct object *, pic_value)
KHASH_DECLARE(attr, struct object *, pic_value)
struct weak {
struct attr {
OBJECT_HEADER
khash_t(weak) hash;
struct weak *prev; /* for GC */
khash_t(attr) hash;
struct attr *prev; /* for GC */
};
struct vector {
@ -253,7 +253,7 @@ DEFPTR(blob, struct blob)
DEFPTR(pair, struct pair)
DEFPTR(vec, struct vector)
DEFPTR(dict, struct dict)
DEFPTR(weak, struct weak)
DEFPTR(attr, struct attr)
DEFPTR(data, struct data)
DEFPTR(proc, struct proc)
DEFPTR(port, struct port)

6
lib/state.c
View File

@ -107,7 +107,7 @@ void pic_init_write(pic_state *);
void pic_init_read(pic_state *);
void pic_init_dict(pic_state *);
void pic_init_record(pic_state *);
void pic_init_weak(pic_state *);
void pic_init_attr(pic_state *);
void pic_init_file(pic_state *);
void pic_init_state(pic_state *);
void pic_init_eval(pic_state *);
@ -133,7 +133,7 @@ pic_init_core(pic_state *pic)
pic_init_var(pic); DONE;
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_weak(pic); DONE;
pic_init_attr(pic); DONE;
pic_init_state(pic); DONE;
#if PIC_USE_CALLCC
@ -205,7 +205,7 @@ pic_open(pic_allocf allocf, void *userdata)
pic->features = pic_nil_value(pic);
/* dynamic environment */
pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
pic->dyn_env = pic_list(pic, 1, pic_make_attr(pic));
/* top continuation */
{

8
lib/var.c
View File

@ -20,8 +20,8 @@ var_call(pic_state *pic)
pic_value env, it;
pic_for_each(env, pic->dyn_env, it) {
if (pic_weak_has(pic, env, self)) {
return pic_weak_ref(pic, env, self);
if (pic_attr_has(pic, env, self)) {
return pic_attr_ref(pic, env, self);
}
}
PIC_UNREACHABLE(); /* logic flaw */
@ -32,7 +32,7 @@ var_call(pic_state *pic)
if (! pic_false_p(pic, conv)) {
val = pic_call(pic, conv, 1, val);
}
pic_weak_set(pic, pic_car(pic, pic->dyn_env), self, val);
pic_attr_set(pic, pic_car(pic, pic->dyn_env), self, val);
return pic_undef_value(pic);
}
}
@ -48,7 +48,7 @@ pic_make_var(pic_state *pic, pic_value init, pic_value conv)
if (! pic_false_p(pic, conv)) {
init = pic_call(pic, conv, 1, init);
}
pic_weak_set(pic, pic_car(pic, env), var, init);
pic_attr_set(pic, pic_car(pic, env), var, init);
break;
}
env = pic_cdr(pic, env);

107
lib/weak.c
View File

@ -1,107 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "object.h"
KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
static pic_value
weak_call(pic_state *pic)
{
pic_value self, key, val;
int n;
n = pic_get_args(pic, "&o|o", &self, &key, &val);
if (! obj_p(pic, key)) {
pic_error(pic, "attempted to set a non-object key", 1, key);
}
if (n == 1) {
if (! pic_weak_has(pic, self, key)) {
return pic_false_value(pic);
}
return pic_weak_ref(pic, self, key);
} else {
if (pic_false_p(pic, val)) {
if (pic_weak_has(pic, self, key)) {
pic_weak_del(pic, self, key);
}
} else {
pic_weak_set(pic, self, key, val);
}
return pic_undef_value(pic);
}
}
pic_value
pic_make_weak(pic_state *pic)
{
struct weak *weak;
weak = (struct weak *)pic_obj_alloc(pic, PIC_TYPE_WEAK);
weak->prev = NULL;
kh_init(weak, &weak->hash);
return pic_lambda(pic, weak_call, 1, obj_value(pic, weak));
}
pic_value
pic_weak_ref(pic_state *pic, pic_value weak, pic_value key)
{
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int it;
it = kh_get(weak, h, obj_ptr(pic, key));
if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key);
}
return kh_val(h, it);
}
void
pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
{
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int ret;
int it;
it = kh_put(weak, h, obj_ptr(pic, key), &ret);
kh_val(h, it) = val;
}
bool
pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
{
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
return kh_get(weak, h, obj_ptr(pic, key)) != kh_end(h);
}
void
pic_weak_del(pic_state *pic, pic_value weak, pic_value key)
{
khash_t(weak) *h = &weak_ptr(pic, proc_ptr(pic, weak)->env->regs[0])->hash;
int it;
it = kh_get(weak, h, obj_ptr(pic, key));
if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key);
}
kh_del(weak, h, it);
}
static pic_value
pic_weak_make_ephemeron_table(pic_state *pic)
{
pic_get_args(pic, "");
return pic_make_weak(pic);
}
void
pic_init_weak(pic_state *pic)
{
pic_defun(pic, "make-ephemeron-table", pic_weak_make_ephemeron_table);
}

6
piclib/eval.scm
View File

@ -99,7 +99,7 @@
((environment-binding env) id uid))
(define (make-environment prefix)
(%make-environment #f (symbol->string prefix) (make-ephemeron-table)))
(%make-environment #f (symbol->string prefix) (make-attribute)))
(define default-environment
(let ((env (make-environment (string->symbol ""))))
@ -116,7 +116,7 @@
env)))
(define (extend-environment parent)
(%make-environment parent #f (make-ephemeron-table)))
(%make-environment parent #f (make-attribute)))
;; macro
@ -589,7 +589,7 @@
(let ((table (the 'table))
(prev (the 'prev))
(it (the 'it)))
`(,(the 'let) ((,table (,(the 'make-ephemeron-table)))
`(,(the 'let) ((,table (,(the 'make-attribute)))
(,prev (,(the 'current-dynamic-environment))))
(,(the 'current-dynamic-environment) (,(the 'cons) ,table ,prev))
(,the-begin . ,formal)