From c76dfcb861ef9d64fbf02e831498ebac99cbcbf9 Mon Sep 17 00:00:00 2001 From: Yuito Murase Date: Sat, 26 Jul 2014 10:47:48 +0900 Subject: [PATCH] implement native record native record primitives are defined in (picrin record-primitive) - (make-record rectype) - (record-of? record rectype) - (record-ref record rectype field-name) - (record-set! record rectype field-name value) define-record-type is defined using these primitives --- include/picrin/record.h | 31 ++++++++ include/picrin/value.h | 5 +- piclib/prelude.scm | 172 ++++++++++++---------------------------- src/codegen.c | 1 + src/gc.c | 17 ++++ src/init.c | 2 + src/macro.c | 1 + src/record.c | 114 ++++++++++++++++++++++++++ src/vm.c | 18 +++++ src/write.c | 2 + 10 files changed, 240 insertions(+), 123 deletions(-) create mode 100644 include/picrin/record.h create mode 100644 src/record.c diff --git a/include/picrin/record.h b/include/picrin/record.h new file mode 100644 index 00000000..b15e5f31 --- /dev/null +++ b/include/picrin/record.h @@ -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_value, pic_sym); +void pic_record_set(pic_state *, struct pic_record *, pic_value, pic_sym, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/include/picrin/value.h b/include/picrin/value.h index 283bac28..bfc9d1ca 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -115,7 +115,8 @@ enum pic_tt { PIC_TT_VAR, PIC_TT_IREP, PIC_TT_DATA, - PIC_TT_DICT + PIC_TT_DICT, + PIC_TT_RECORD }; #define PIC_OBJECT_HEADER \ @@ -268,6 +269,8 @@ pic_type_repr(enum pic_tt tt) return "data"; case PIC_TT_DICT: return "dict"; + case PIC_TT_RECORD: + return "record"; } UNREACHABLE(); } diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 5a5008c0..b655b002 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -406,148 +406,76 @@ ;;; Record Type (define-library (picrin record) (import (scheme base) - (picrin macro)) + (picrin macro) + (picrin record-primitive)) - (define record-marker (list 'record-marker)) + (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 real-vector? vector?) + (define (make-record-type name) + (let ((rectype (make-record #t))) + (record-set! rectype #t 'name name) + rectype)) - (set! vector? - (lambda (x) - (and (real-vector? x) - (or (= 0 (vector-length x)) - (not (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 ,rectype ',field ,field)) + fields) + record)))))) - #| - ;; (scheme eval) is not provided for now - (define eval - (let ((real-eval eval)) - (lambda (exp env) - ((real-eval `(lambda (vector?) ,exp)) - vector?)))) - |# - - (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-predicate + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (cadr form)) + (name (caddr form))) + `(define (,name 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 ((rectype (cadr form)) + (field-name (caddr form)) + (accessor (cadddr form)) + (modifier? (cddddr form))) + (if (null? modifier?) + `(define (,accessor record) + (record-roef record ,rectype ',field-name)) `(begin - (define ,(car acc-mod) - (record-accessor ,type ',field-tag)) - (define ,(cadr acc-mod) - (record-modifier ,type ',field-tag)))))))) + (define (,accessor record) + (record-ref record ,rectype ',field-name)) + (define (,(car modifier?) record val) + (record-set! record ,rectype ',field-name val)))))))) (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)))))) + (define ,name (make-record-type ',name)) + (define-record-constructor ,name ,@constructor) + (define-record-predicate ,name ,pred) + ,@(map (lambda (field) `(define-record-field ,name ,@field)) + fields)))))) (export define-record-type)) (import (picrin macro) (picrin values) (picrin parameter) - (picrin record)) + (picrin record)) (export let-values let*-values diff --git a/src/codegen.c b/src/codegen.c index a5c35eb8..a42c378a 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -831,6 +831,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: pic_errorf(pic, "invalid expression given: ~s", obj); } UNREACHABLE(); diff --git a/src/gc.c b/src/gc.c index 3d28aa96..dcebb4e2 100644 --- a/src/gc.c +++ b/src/gc.c @@ -20,6 +20,7 @@ #include "picrin/var.h" #include "picrin/data.h" #include "picrin/dict.h" +#include "picrin/record.h" #if GC_DEBUG # include @@ -506,6 +507,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_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: @@ -658,6 +670,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_NIL: case PIC_TT_BOOL: case PIC_TT_FLOAT: diff --git a/src/init.c b/src/init.c index 3bb10991..8afd5a44 100644 --- a/src/init.c +++ b/src/init.c @@ -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_contrib(pic_state *); void pic_load_piclib(pic_state *); @@ -92,6 +93,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_load_piclib(pic); DONE; diff --git a/src/macro.c b/src/macro.c index 597eb57f..c181545a 100644 --- a/src/macro.c +++ b/src/macro.c @@ -416,6 +416,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) case PIC_TT_IREP: case PIC_TT_DATA: case PIC_TT_DICT: + case PIC_TT_RECORD: pic_errorf(pic, "unexpected value type: ~s", expr); } UNREACHABLE(); diff --git a/src/record.c b/src/record.c new file mode 100644 index 00000000..f0028d65 --- /dev/null +++ b/src/record.c @@ -0,0 +1,114 @@ +/** + * 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_value rectype, 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); + } + 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) +{ + if (! pic_eq_p(rec->rectype, rectype)) { + pic_errorf(pic, "value is not record of ~s", rectype); + } + + 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_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_value rectype; + pic_sym slotname; + + pic_get_args(pic, "rom", &rec, &rectype, &slotname); + + return pic_record_ref(pic, rec, rectype, 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_record_set(pic, rec, rectype, slotname, val); + + return pic_none_value(); +} + +void +pic_init_record(pic_state *pic) +{ + pic_deflibrary ("(picrin record-primitive)") { + pic_defun(pic, "make-record", pic_record_record); + 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); + } +} diff --git a/src/vm.c b/src/vm.c index 8e2ddb6c..2c1c1eeb 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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)]) @@ -346,6 +347,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; + } default: pic_error(pic, "pic_get_args: invalid argument specifier given"); } diff --git a/src/write.c b/src/write.c index 61551b1a..d776eaa0 100644 --- a/src/write.c +++ b/src/write.c @@ -333,6 +333,8 @@ write_core(struct writer_control *p, pic_value obj) case PIC_TT_DICT: xfprintf(file, "#", pic_ptr(obj)); break; + case PIC_TT_RECORD: + xfprintf(file, "#", pic_ptr(obj)); } }