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

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();

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 <string.h>
@@ -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:

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;
 

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();

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);
+  }
+}

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

src/write.c

@@ -333,6 +333,8 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_DICT:
     xfprintf(file, "#<dict %p>", pic_ptr(obj));
     break;
+  case PIC_TT_RECORD:
+    xfprintf(file, "#<record %p>", pic_ptr(obj));
   }
 }