From c76dfcb861ef9d64fbf02e831498ebac99cbcbf9 Mon Sep 17 00:00:00 2001
From: Yuito Murase <themamedaifuku@gmail.com>
Date: Sat, 26 Jul 2014 10:47:48 +0900
Subject: [PATCH 1/5] 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 <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:
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, "#<dict %p>", pic_ptr(obj));
     break;
+  case PIC_TT_RECORD:
+    xfprintf(file, "#<record %p>", pic_ptr(obj));
   }
 }
 

From 9e9666999ea8a0c779f6851d293f672a129cfd4e Mon Sep 17 00:00:00 2001
From: Yuito Murase <yuito.murase@gmail.com>
Date: Mon, 4 Aug 2014 07:36:31 +0900
Subject: [PATCH 2/5] fix style

---
 src/record.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/record.c b/src/record.c
index 0e9b026f..af33cbd4 100644
--- a/src/record.c
+++ b/src/record.c
@@ -18,7 +18,8 @@ pic_record_new(pic_state *pic, pic_value rectype)
 }
 
 bool
-pic_record_of(pic_state *pic, struct pic_record *rec, pic_value rectype) {
+pic_record_of(pic_state *pic, struct pic_record *rec, pic_value rectype)
+{
   UNUSED(pic);
 
   return pic_eq_p(rec->rectype, rectype);

From 8934c99ac26a4103b2e88c69e60efe8235994faa Mon Sep 17 00:00:00 2001
From: Yuito Murase <yuito.murase@gmail.com>
Date: Mon, 4 Aug 2014 07:38:27 +0900
Subject: [PATCH 3/5] move (picrin record-primitive) to (picrin record)

---
 piclib/scheme/base.scm | 130 ++++++++++++++++++++---------------------
 src/record.c           |   2 +-
 2 files changed, 63 insertions(+), 69 deletions(-)

diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index accc1737..f547b342 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -732,77 +732,71 @@
 
   (export parameterize make-parameter)
 
-;;; Record Type
-  (define-library (picrin record)
-    (import (scheme base)
-	    (picrin macro)
-	    (picrin record-primitive))
-
-    (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 (make-record-type name)
-      (let ((rectype (make-record #t)))
-	(record-set! rectype #t 'name name)
-	rectype))
-
-    (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))))))
-
-    (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 ((rectype (cadr form))
-	       (field-name (caddr form))
-	       (accessor (cadddr form))
-	       (modifier? (cddddr form)))
-	   (if (null? modifier?)
-	       `(define (,accessor record)
-		  (record-ref record ,rectype ',field-name))
-	       `(begin
-		  (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 ((name (cadr form))
-	       (constructor (caddr form))
-	       (pred (cadddr form))
-	       (fields (cddddr form)))
-	   `(begin
-	      (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))
+  ;; 5.5 Recored-type definitions
 
   (import (picrin record))
 
+  (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 (make-record-type name)
+    (let ((rectype (make-record #t)))
+      (record-set! rectype #t 'name name)
+      rectype))
+
+  (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))))))
+
+  (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 ((rectype (cadr form))
+	     (field-name (caddr form))
+	     (accessor (cadddr form))
+	     (modifier? (cddddr form)))
+	 (if (null? modifier?)
+	     `(define (,accessor record)
+		(record-ref record ,rectype ',field-name))
+	     `(begin
+		(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 ((name (cadr form))
+	     (constructor (caddr form))
+	     (pred (cadddr form))
+	     (fields (cddddr form)))
+	 `(begin
+	    (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)
 
 
diff --git a/src/record.c b/src/record.c
index af33cbd4..d6d9cde1 100644
--- a/src/record.c
+++ b/src/record.c
@@ -106,7 +106,7 @@ pic_record_record_set(pic_state *pic)
 void
 pic_init_record(pic_state *pic)
 {
-  pic_deflibrary (pic, "(picrin record-primitive)") {
+  pic_deflibrary (pic, "(picrin record)") {
     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);

From cd96014104974a711b2b0f15d23202edfb6cf219 Mon Sep 17 00:00:00 2001
From: Yuito Murase <yuito.murase@gmail.com>
Date: Mon, 4 Aug 2014 12:40:41 +0900
Subject: [PATCH 4/5] record-ref and record-set! don't check type

---
 include/picrin/record.h |  4 ++--
 piclib/scheme/base.scm  | 20 +++++++++++++-------
 src/record.c            | 24 ++++++++----------------
 3 files changed, 23 insertions(+), 25 deletions(-)

diff --git a/include/picrin/record.h b/include/picrin/record.h
index b15e5f31..32ca9223 100644
--- a/include/picrin/record.h
+++ b/include/picrin/record.h
@@ -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)
 }
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index f547b342..ae6416fe 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -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)
diff --git a/src/record.c b/src/record.c
index d6d9cde1..572eb013 100644
--- a/src/record.c
+++ b/src/record.c
@@ -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();
 }

From ef3887485062f2d324c08caa7aa94f03118f5f24 Mon Sep 17 00:00:00 2001
From: Yuito Murase <yuito.murase@gmail.com>
Date: Mon, 4 Aug 2014 23:01:47 +0900
Subject: [PATCH 5/5] add predicate record? to (picrin record), and fix bug of
 record-type predicate

---
 piclib/scheme/base.scm |  3 ++-
 src/record.c           | 11 +++++++++++
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index ae6416fe..dc697aa2 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -765,7 +765,8 @@
        (let ((rectype (cadr form))
 	     (name (caddr form)))
 	 `(define (,name obj)
-	    (record-of? obj ,rectype))))))
+	    (and (record? obj)
+		 (record-of? obj ,rectype)))))))
 
   (define-syntax define-record-field
     (ir-macro-transformer
diff --git a/src/record.c b/src/record.c
index 572eb013..8412c874 100644
--- a/src/record.c
+++ b/src/record.c
@@ -59,6 +59,16 @@ pic_record_record(pic_state *pic)
   return pic_obj_value(rec);
 }
 
+static pic_value
+pic_record_record_p(pic_state *pic)
+{
+  pic_value rec;
+
+  pic_get_args(pic, "o", &rec);
+
+  return pic_bool_value(pic_record_p(rec));
+}
+
 static pic_value
 pic_record_record_of(pic_state *pic)
 {
@@ -100,6 +110,7 @@ pic_init_record(pic_state *pic)
 {
   pic_deflibrary (pic, "(picrin record)") {
     pic_defun(pic, "make-record", pic_record_record);
+    pic_defun(pic, "record?", pic_record_record_p);
     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);