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

Merge pull request #182 from zeptometer/native-record 

Native record
This commit is contained in:
zeptometer 2014-08-04 23:28:09 +09:00
parent 0095fa6a57 ef38874850
commit bca13f3f44
8 changed files with 259 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
include/picrin/record.h Normal file
View File

@ -0,0 +1,31 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_RECORD_H
#define PICRIN_RECORD_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_record {
PIC_OBJECT_HEADER
pic_value rectype;
xhash hash;
};
#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v))
struct pic_record *pic_record_new(pic_state *, pic_value);
bool pic_record_of(pic_state *, struct pic_record *, pic_value);
pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym);
void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value);
#if defined(__cplusplus)
}
#endif
#endif

3
include/picrin/value.h
View File

@ -116,6 +116,7 @@ enum pic_tt {
PIC_TT_IREP,
PIC_TT_DATA,
PIC_TT_DICT,
PIC_TT_RECORD,
PIC_TT_BLK,
};
@ -269,6 +270,8 @@ pic_type_repr(enum pic_tt tt)
return "data";
case PIC_TT_DICT:
return "dict";
case PIC_TT_RECORD:
return "record";
case PIC_TT_BLK:
return "block";
}

174
piclib/scheme/base.scm
View File

@ -732,139 +732,77 @@
(export parameterize make-parameter)
(define-library (picrin record)
(import (scheme base)
(scheme eval)
(picrin macro))
;; 5.5 Recored-type definitions
(define record-marker (list 'record-marker))
(import (picrin record))
(define real-vector? vector?)
(define (caddr x) (car (cddr x)))
(define (cdddr x) (cdr (cddr x)))
(define (cadddr x) (car (cdddr x)))
(define (cddddr x) (cdr (cdddr x)))
(set! vector?
(lambda (x)
(and (real-vector? x)
(or (= 0 (vector-length x))
(not (eq? (vector-ref x 0)
record-marker))))))
(define (make-record-type name)
(let ((rectype (make-record #t)))
(record-set! rectype 'name name)
rectype))
(define (record? x)
(and (real-vector? x)
(< 0 (vector-length x))
(eq? (vector-ref x 0) record-marker)))
(define-syntax define-record-constructor
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (cadr form))
(name (caddr form))
(fields (cdddr form)))
`(define (,name ,@fields)
(let ((record (make-record ,rectype)))
,@(map (lambda (field)
`(record-set! record ',field ,field))
fields)
record))))))
(define (make-record size)
(let ((new (make-vector (+ size 1))))
(vector-set! new 0 record-marker)
new))
(define (record-ref record index)
(vector-ref record (+ index 1)))
(define (record-set! record index value)
(vector-set! record (+ index 1) value))
(define record-type% (make-record 3))
(record-set! record-type% 0 record-type%)
(record-set! record-type% 1 'record-type%)
(record-set! record-type% 2 '(name field-tags))
(define (make-record-type name field-tags)
(let ((new (make-record 3)))
(record-set! new 0 record-type%)
(record-set! new 1 name)
(record-set! new 2 field-tags)
new))
(define (record-type record)
(record-ref record 0))
(define (record-type-name record-type)
(record-ref record-type 1))
(define (record-type-field-tags record-type)
(record-ref record-type 2))
(define (field-index type tag)
(let rec ((i 1) (tags (record-type-field-tags type)))
(cond ((null? tags)
(error "record type has no such field" type tag))
((eq? tag (car tags)) i)
(else (rec (+ i 1) (cdr tags))))))
(define (record-constructor type tags)
(let ((size (length (record-type-field-tags type)))
(arg-count (length tags))
(indexes (map (lambda (tag) (field-index type tag)) tags)))
(lambda args
(if (= (length args) arg-count)
(let ((new (make-record (+ size 1))))
(record-set! new 0 type)
(for-each (lambda (arg i) (record-set! new i arg)) args indexes)
new)
(error "wrong number of arguments to constructor" type args)))))
(define (record-predicate type)
(lambda (thing)
(and (record? thing)
(eq? (record-type thing)
type))))
(define (record-accessor type tag)
(let ((index (field-index type tag)))
(lambda (thing)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-ref thing index)
(error "accessor applied to bad value" type tag thing)))))
(define (record-modifier type tag)
(let ((index (field-index type tag)))
(lambda (thing value)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-set! thing index value)
(error "modifier applied to bad value" type tag thing)))))
(define-syntax define-record-predicate
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (cadr form))
(name (caddr form)))
`(define (,name obj)
(and (record? obj)
(record-of? obj ,rectype)))))))
(define-syntax define-record-field
(ir-macro-transformer
(lambda (form inject compare?)
(let ((type (car (cdr form)))
(field-tag (car (cdr (cdr form))))
(acc-mod (cdr (cdr (cdr form)))))
(if (= 1 (length acc-mod))
`(define ,(car acc-mod)
(record-accessor ,type ',field-tag))
(let ((pred (cadr form))
(field-name (caddr form))
(accessor (cadddr form))
(modifier? (cddddr form)))
(if (null? modifier?)
`(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error "wrong record type")))
`(begin
(define ,(car acc-mod)
(record-accessor ,type ',field-tag))
(define ,(cadr acc-mod)
(record-modifier ,type ',field-tag))))))))
(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error "wrong record type")))
(define (,(car modifier?) record val)
(if (,pred record)
(record-set! record ',field-name val)
(error "wrong record type")))))))))
(define-syntax define-record-type
(ir-macro-transformer
(lambda (form inject compare?)
(let ((type (cadr form))
(constructor (car (cdr (cdr form))))
(predicate (car (cdr (cdr (cdr form)))))
(field-tag (cdr (cdr (cdr (cdr form))))))
(let ((name (cadr form))
(constructor (caddr form))
(pred (cadddr form))
(fields (cddddr form)))
`(begin
(define ,type
(make-record-type ',type ',(cdr constructor)))
(define ,(car constructor)
(record-constructor ,type ',(cdr constructor)))
(define ,predicate
(record-predicate ,type))
,@(map
(lambda (x)
`(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
field-tag))))))
(export define-record-type))
(import (picrin record))
(define ,name (make-record-type ',name))
(define-record-constructor ,name ,@constructor)
(define-record-predicate ,name ,pred)
,@(map (lambda (field) `(define-record-field ,pred ,@field))
fields))))))
(export define-record-type)

1
src/codegen.c
View File

@ -819,6 +819,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
case PIC_TT_IREP:
case PIC_TT_DATA:
case PIC_TT_DICT:
case PIC_TT_RECORD:
case PIC_TT_BLK:
pic_errorf(pic, "invalid expression given: ~s", obj);
}

17
src/gc.c
View File

@ -20,6 +20,7 @@
#include "picrin/var.h"
#include "picrin/data.h"
#include "picrin/dict.h"
#include "picrin/record.h"
#if GC_DEBUG
# include <string.h>
@ -501,6 +502,17 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_iter it;
gc_mark(pic, rec->rectype);
xh_begin(&it, &rec->hash);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
break;
}
case PIC_TT_BLK: {
struct pic_block *blk = (struct pic_block *)obj;
@ -677,6 +689,11 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
xh_destroy(&dict->hash);
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_destroy(&rec->hash);
break;
}
case PIC_TT_BLK: {
break;
}

2
src/init.c
View File

@ -31,6 +31,7 @@ void pic_init_load(pic_state *);
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_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_contrib(pic_state *);
@ -94,6 +95,7 @@ pic_init_core(pic_state *pic)
pic_init_write(pic); DONE;
pic_init_read(pic); DONE;
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;

118
src/record.c Normal file
View File

@ -0,0 +1,118 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/record.h"
struct pic_record *
pic_record_new(pic_state *pic, pic_value rectype)
{
struct pic_record *rec;
rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
rec->rectype = rectype;
xh_init_int(&rec->hash, sizeof(pic_value));
return rec;
}
bool
pic_record_of(pic_state *pic, struct pic_record *rec, pic_value rectype)
{
UNUSED(pic);
return pic_eq_p(rec->rectype, rectype);
}
pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slotname)
{
xh_entry *e;
e = xh_get_int(&rec->hash, slotname);
if (! e) {
pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slotname), rec);
}
return xh_val(e, pic_value);
}
void
pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slotname, pic_value val)
{
UNUSED(pic);
xh_put_int(&rec->hash, slotname, &val);
}
static pic_value
pic_record_record(pic_state *pic)
{
struct pic_record * rec;
pic_value rectype;
pic_get_args(pic, "o", &rectype);
rec = pic_record_new(pic, rectype);
return pic_obj_value(rec);
}
static pic_value
pic_record_record_p(pic_state *pic)
{
pic_value rec;
pic_get_args(pic, "o", &rec);
return pic_bool_value(pic_record_p(rec));
}
static pic_value
pic_record_record_of(pic_state *pic)
{
struct pic_record *rec;
pic_value rectype;
pic_get_args(pic, "ro", &rec, &rectype);
return pic_bool_value(pic_record_of(pic, rec, rectype));
}
static pic_value
pic_record_record_ref(pic_state *pic)
{
struct pic_record *rec;
pic_sym slotname;
pic_get_args(pic, "rm", &rec, &slotname);
return pic_record_ref(pic, rec, slotname);
}
static pic_value
pic_record_record_set(pic_state *pic)
{
struct pic_record *rec;
pic_sym slotname;
pic_value val;
pic_get_args(pic, "rmo", &rec, &slotname, &val);
pic_record_set(pic, rec, slotname, val);
return pic_none_value();
}
void
pic_init_record(pic_state *pic)
{
pic_deflibrary (pic, "(picrin record)") {
pic_defun(pic, "make-record", pic_record_record);
pic_defun(pic, "record?", pic_record_record_p);
pic_defun(pic, "record-of?", pic_record_record_of);
pic_defun(pic, "record-ref", pic_record_record_ref);
pic_defun(pic, "record-set!", pic_record_record_set);
}
}

18
src/vm.c
View File

@ -20,6 +20,7 @@
#include "picrin/macro.h"
#include "picrin/error.h"
#include "picrin/dict.h"
#include "picrin/record.h"
#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])
@ -347,6 +348,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
}
break;
}
case 'r': {
struct pic_record **r;
pic_value v;
r = va_arg(ap, struct pic_record **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_record_p(v)) {
*r = pic_record_ptr(v);
}
else {
pic_errorf(pic, "pic_get_args: expected record, but got ~s", v);
}
i++;
}
break;
}
case 'e': {
struct pic_error **e;
pic_value v;