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); struct pic_record *pic_record_new(pic_state *, pic_value);
bool pic_record_of(pic_state *, struct pic_record *, 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); pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym);
void pic_record_set(pic_state *, struct pic_record *, pic_value, pic_sym, pic_value); void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

20
piclib/scheme/base.scm
View File

@ -743,7 +743,7 @@
(define (make-record-type name) (define (make-record-type name)
(let ((rectype (make-record #t))) (let ((rectype (make-record #t)))
(record-set! rectype #t 'name name) (record-set! rectype 'name name)
rectype)) rectype))
(define-syntax define-record-constructor (define-syntax define-record-constructor
@ -755,7 +755,7 @@
`(define (,name ,@fields) `(define (,name ,@fields)
(let ((record (make-record ,rectype))) (let ((record (make-record ,rectype)))
,@(map (lambda (field) ,@(map (lambda (field)
`(record-set! record ,rectype ',field ,field)) `(record-set! record ',field ,field))
fields) fields)
record)))))) record))))))
@ -770,18 +770,24 @@
(define-syntax define-record-field (define-syntax define-record-field
(ir-macro-transformer (ir-macro-transformer
(lambda (form inject compare?) (lambda (form inject compare?)
(let ((rectype (cadr form)) (let ((pred (cadr form))
(field-name (caddr form)) (field-name (caddr form))
(accessor (cadddr form)) (accessor (cadddr form))
(modifier? (cddddr form))) (modifier? (cddddr form)))
(if (null? modifier?) (if (null? modifier?)
`(define (,accessor record) `(define (,accessor record)
(record-ref record ,rectype ',field-name)) (if (,pred record)
(record-ref record ',field-name)
(error "wrong record type")))
`(begin `(begin
(define (,accessor record) (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) (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 (define-syntax define-record-type
(ir-macro-transformer (ir-macro-transformer
@ -794,7 +800,7 @@
(define ,name (make-record-type ',name)) (define ,name (make-record-type ',name))
(define-record-constructor ,name ,@constructor) (define-record-constructor ,name ,@constructor)
(define-record-predicate ,name ,pred) (define-record-predicate ,name ,pred)
,@(map (lambda (field) `(define-record-field ,name ,@field)) ,@(map (lambda (field) `(define-record-field ,pred ,@field))
fields)))))) fields))))))
(export define-record-type) (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_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; 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); e = xh_get_int(&rec->hash, slotname);
if (! e) { 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); return xh_val(e, pic_value);
} }
void 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)) { UNUSED(pic);
pic_errorf(pic, "value is not record of ~s", rectype);
}
xh_put_int(&rec->hash, slotname, &val); xh_put_int(&rec->hash, slotname, &val);
} }
@ -80,25 +74,23 @@ static pic_value
pic_record_record_ref(pic_state *pic) pic_record_record_ref(pic_state *pic)
{ {
struct pic_record *rec; struct pic_record *rec;
pic_value rectype;
pic_sym slotname; 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 static pic_value
pic_record_record_set(pic_state *pic) pic_record_record_set(pic_state *pic)
{ {
struct pic_record *rec; struct pic_record *rec;
pic_value rectype;
pic_sym slotname; pic_sym slotname;
pic_value val; 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(); return pic_none_value();
} }