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";
}

200
piclib/scheme/base.scm
View File

@ -732,140 +732,78 @@
(export parameterize make-parameter)
(define-library (picrin record)
(import (scheme base)
(scheme eval)
(picrin macro))
(define record-marker (list 'record-marker))
(define real-vector? vector?)
(set! vector?
(lambda (x)
(and (real-vector? x)
(or (= 0 (vector-length x))
(not (eq? (vector-ref x 0)
record-marker))))))
(define (record? x)
(and (real-vector? x)
(< 0 (vector-length x))
(eq? (vector-ref x 0) record-marker)))
(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-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))
`(begin
(define ,(car acc-mod)
(record-accessor ,type ',field-tag))
(define ,(cadr acc-mod)
(record-modifier ,type ',field-tag))))))))
(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))))))
`(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))
;; 5.5 Recored-type definitions
(import (picrin record))
(define (caddr x) (car (cddr x)))
(define (cdddr x) (cdr (cddr x)))
(define (cadddr x) (car (cdddr x)))
(define (cddddr x) (cdr (cdddr x)))
(define (make-record-type name)
(let ((rectype (make-record #t)))
(record-set! rectype 'name name)
rectype))
(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-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 ((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 (,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 ((name (cadr form))
(constructor (caddr form))
(pred (cadddr form))
(fields (cddddr form)))
`(begin
(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;