Merge branch 'data-type'

contrib/20.r7rs/scheme/base.scm

@@ -412,11 +412,14 @@
 
   ;; 5.5 Recored-type definitions
 
+  (define (make-record-type name)
+    (vector name))                      ; TODO
+
   (define-syntax (define-record-constructor type name . fields)
     (let ((record #'record))
       #`(define (#,name . #,fields)
-          (let ((#,record (make-record #,type)))
-            #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
+          (let ((#,record (make-record #,type (make-dictionary))))
+            #,@(map (lambda (field) #`(dictionary-set! (record-datum #,record) '#,field #,field)) fields)
             #,record))))
 
   (define-syntax (define-record-predicate type name)
@@ -427,13 +430,13 @@
   (define-syntax (define-record-accessor pred field accessor)
     #`(define (#,accessor record)
         (if (#,pred record)
-            (record-ref record '#,field)
+            (cdr (dictionary-ref (record-datum record) '#,field))
             (error (string-append (symbol->string  '#,accessor) ": wrong record type") record))))
 
   (define-syntax (define-record-modifier pred field modifier)
     #`(define (#,modifier record val)
         (if (#,pred record)
-            (record-set! record '#,field val)
+            (dictionary-set! (record-datum record) '#,field val)
             (error (string-append (symbol->string '#,modifier) ": wrong record type")  record))))
 
   (define-syntax (define-record-field pred field accessor . modifier-opt)
@@ -445,7 +448,7 @@
 
   (define-syntax (define-record-type name ctor pred . fields)
     #`(begin
-        (define #,name (make-record <record-type>))
+        (define #,name (make-record-type '#,name))
         (define-record-constructor #,name #,@ctor)
         (define-record-predicate #,name #,pred)
         #,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))

extlib/benz/gc.c

@@ -378,8 +378,10 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     break;
   }
   case PIC_TT_RECORD: {
-    gc_mark_object(pic, (struct pic_object *)obj->u.rec.type);
-    LOOP(obj->u.rec.data);
+    gc_mark(pic, obj->u.rec.type);
+    if (pic_obj_p(obj->u.rec.datum)) {
+      LOOP(pic_obj_ptr(obj->u.rec.datum));
+    }
     break;
   }
   case PIC_TT_SYMBOL: {

extlib/benz/include/picrin/record.h

@@ -11,18 +11,17 @@ extern "C" {
 
 struct pic_record {
   PIC_OBJECT_HEADER
-  struct pic_record *type;
-  struct pic_dict *data;
+  pic_value type;
+  pic_value datum;
 };
 
-#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
-#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v))
+#define pic_rec_p(v) (pic_type(v) == PIC_TT_RECORD)
+#define pic_rec_ptr(v) ((struct pic_record *)pic_ptr(v))
 
-struct pic_record *pic_make_record(pic_state *, struct pic_record *);
+struct pic_record *pic_make_rec(pic_state *, pic_value, pic_value);
 
-struct pic_record *pic_record_type(pic_state *, struct pic_record *);
-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);
+pic_value pic_rec_type(pic_state *, struct pic_record *);
+pic_value pic_rec_datum(pic_state *, struct pic_record *);
 
 #if defined(__cplusplus)
 }

extlib/benz/proc.c

@@ -27,6 +27,7 @@
  *  p   struct pic_port **      port object
  *  d   struct pic_dict **      dictionary object
  *  e   struct pic_error **     error object
+ *  r   struct pic_record **    record object
  *
  *  |                           optional operator
  *  *   int *, pic_value **  variable length operator
@@ -152,8 +153,8 @@ pic_get_args(pic_state *pic, const char *format, ...)
     PTR_CASE('l', proc, struct pic_proc *)
     PTR_CASE('p', port, struct pic_port *)
     PTR_CASE('d', dict, struct pic_dict *)
-    PTR_CASE('r', record, struct pic_record *)
     PTR_CASE('e', error, struct pic_error *)
+    PTR_CASE('r', rec, struct pic_record *)
 
     default:
       pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c);

extlib/benz/record.c

@@ -5,110 +5,74 @@
 #include "picrin.h"
 
 struct pic_record *
-pic_make_record(pic_state *pic, struct pic_record *type)
+pic_make_rec(pic_state *pic, pic_value type, pic_value datum)
 {
   struct pic_record *rec;
-  struct pic_dict *data = pic_make_dict(pic);
 
   rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
-  rec->data = data;
   rec->type = type;
-
-  if (rec->type == NULL) {
-    rec->type = rec;
-  }
+  rec->datum = datum;
 
   return rec;
 }
 
-struct pic_record *
-pic_record_type(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
+pic_value
+pic_rec_type(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
 {
   return rec->type;
 }
 
 pic_value
-pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot)
+pic_rec_datum(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
 {
-  if (! pic_dict_has(pic, rec->data, slot)) {
-    pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), pic_obj_value(rec));
-  }
-  return pic_dict_ref(pic, rec->data, slot);
-}
-
-void
-pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym *slot, pic_value val)
-{
-  pic_dict_set(pic, rec->data, slot, val);
+  return rec->datum;
 }
 
 static pic_value
-pic_record_make_record(pic_state *pic)
+pic_rec_make_record(pic_state *pic)
 {
-  struct pic_record * rec;
-  pic_value rectype;
+  pic_value type, datum;
 
-  pic_get_args(pic, "o", &rectype);
+  pic_get_args(pic, "oo", &type, &datum);
 
-  pic_assert_type(pic, rectype, record);
-
-  rec = pic_make_record(pic, pic_record_ptr(rectype));
-
-  return pic_obj_value(rec);
+  return pic_obj_value(pic_make_rec(pic, type, datum));
 }
 
 static pic_value
-pic_record_record_p(pic_state *pic)
+pic_rec_record_p(pic_state *pic)
 {
   pic_value rec;
 
   pic_get_args(pic, "o", &rec);
 
-  return pic_bool_value(pic_record_p(rec));
+  return pic_bool_value(pic_rec_p(rec));
 }
 
 static pic_value
-pic_record_record_type(pic_state *pic)
+pic_rec_record_type(pic_state *pic)
 {
   struct pic_record *rec;
 
   pic_get_args(pic, "r", &rec);
 
-  return pic_obj_value(pic_record_type(pic, rec));
+  return pic_rec_type(pic, rec);
 }
 
 static pic_value
-pic_record_record_ref(pic_state *pic)
+pic_rec_record_datum(pic_state *pic)
 {
   struct pic_record *rec;
-  pic_sym *slot;
 
-  pic_get_args(pic, "rm", &rec, &slot);
+  pic_get_args(pic, "r", &rec);
 
-  return pic_record_ref(pic, rec, slot);
-}
-
-static pic_value
-pic_record_record_set(pic_state *pic)
-{
-  struct pic_record *rec;
-  pic_sym *slot;
-  pic_value val;
-
-  pic_get_args(pic, "rmo", &rec, &slot, &val);
-
-  pic_record_set(pic, rec, slot, val);
-
-  return pic_undef_value();
+  return pic_rec_datum(pic, rec);
 }
 
 void
 pic_init_record(pic_state *pic)
 {
-  pic_defun(pic, "make-record", pic_record_make_record);
-  pic_defun(pic, "record?", pic_record_record_p);
-  pic_defun(pic, "record-type", pic_record_record_type);
-  pic_defun(pic, "record-ref", pic_record_record_ref);
-  pic_defun(pic, "record-set!", pic_record_record_set);
-  pic_define(pic, "<record-type>", pic_obj_value(pic_make_record(pic, NULL)));
+  pic_defun(pic, "make-record", pic_rec_make_record);
+  pic_defun(pic, "record?", pic_rec_record_p);
+  pic_defun(pic, "record-type", pic_rec_record_type);
+  pic_defun(pic, "record-datum", pic_rec_record_datum);
 }