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

record-ref and record-set! don't check type

This commit is contained in:
Yuito Murase 2014-08-04 12:40:41 +09:00
parent 8934c99ac2
commit cd96014104
3 changed files with 23 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
include/picrin/record.h
View File

@ -21,8 +21,8 @@ struct pic_record {
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_value, pic_sym);
void pic_record_set(pic_state *, struct pic_record *, pic_value, pic_sym, 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)
}

20
piclib/scheme/base.scm
View File

@ -743,7 +743,7 @@
(define (make-record-type name)
(let ((rectype (make-record #t)))
(record-set! rectype #t 'name name)
(record-set! rectype 'name name)
rectype))
(define-syntax define-record-constructor
@ -755,7 +755,7 @@
`(define (,name ,@fields)
(let ((record (make-record ,rectype)))
,@(map (lambda (field)
`(record-set! record ,rectype ',field ,field))
`(record-set! record ',field ,field))
fields)
record))))))
@ -770,18 +770,24 @@
(define-syntax define-record-field
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (cadr form))
(let ((pred (cadr form))
(field-name (caddr form))
(accessor (cadddr form))
(modifier? (cddddr form)))
(if (null? modifier?)
`(define (,accessor record)
(record-ref record ,rectype ',field-name))
(if (,pred record)
(record-ref record ',field-name)
(error "wrong record type")))
`(begin
(define (,accessor record)
(record-ref record ,rectype ',field-name))
(if (,pred record)
(record-ref record ',field-name)
(error "wrong record type")))
(define (,(car modifier?) record val)
(record-set! record ,rectype ',field-name val))))))))
(if (,pred record)
(record-set! record ',field-name val)
(error "wrong record type")))))))))
(define-syntax define-record-type
(ir-macro-transformer
@ -794,7 +800,7 @@
(define ,name (make-record-type ',name))
(define-record-constructor ,name ,@constructor)
(define-record-predicate ,name ,pred)
,@(map (lambda (field) `(define-record-field ,name ,@field))
,@(map (lambda (field) `(define-record-field ,pred ,@field))
fields))))))
(export define-record-type)

24
src/record.c
View File

@ -26,28 +26,22 @@ pic_record_of(pic_state *pic, struct pic_record *rec, pic_value rectype)
}
pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_value rectype, pic_sym slotname)
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slotname)
{
xh_entry *e;
if (! pic_eq_p(rec->rectype, rectype)) {
pic_errorf(pic, "value is not record of ~s", rectype);
}
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), rectype);
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_value rectype, pic_sym slotname, pic_value val)
pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slotname, pic_value val)
{
if (! pic_eq_p(rec->rectype, rectype)) {
pic_errorf(pic, "value is not record of ~s", rectype);
}
UNUSED(pic);
xh_put_int(&rec->hash, slotname, &val);
}
@ -80,25 +74,23 @@ static pic_value
pic_record_record_ref(pic_state *pic)
{
struct pic_record *rec;
pic_value rectype;
pic_sym slotname;
pic_get_args(pic, "rom", &rec, &rectype, &slotname);
pic_get_args(pic, "rm", &rec, &slotname);
return pic_record_ref(pic, rec, rectype, slotname);
return pic_record_ref(pic, rec, slotname);
}
static pic_value
pic_record_record_set(pic_state *pic)
{
struct pic_record *rec;
pic_value rectype;
pic_sym slotname;
pic_value val;
pic_get_args(pic, "romo", &rec, &rectype, &slotname, &val);
pic_get_args(pic, "rmo", &rec, &slotname, &val);
pic_record_set(pic, rec, rectype, slotname, val);
pic_record_set(pic, rec, slotname, val);
return pic_none_value();
}