user-defined printers for record objects

piclib/scheme/base.scm

@@ -750,13 +750,26 @@
 
   (define <record-type> #t)             ; bootstrap
 
-  (define (make-record-type name)
+  (import (scheme write))
+
+  (define (make-record-type name ctor)
     (let ((rectype (make-record <record-type>)))
       (record-set! rectype 'name name)
+      (record-set! rectype 'writer (lambda (obj)
+                                     (let ((port (open-output-string)))
+                                       (display "#.(" port)
+                                       (display (car ctor) port)
+                                       (for-each
+                                        (lambda (field)
+                                          (display " " port)
+                                          (write (record-ref obj field) port))
+                                        (cdr ctor))
+                                       (display ")" port)
+                                       (get-output-string port))))
       rectype))
 
   (set! <record-type>
-        (let ((<record-type> (make-record-type '<record-type>)))
+        (let ((<record-type> (make-record-type '<record-type> '(name writer))))
           (record-set! <record-type> '@@type <record-type>)
           <record-type>))
 
@@ -813,7 +826,7 @@
 	     (pred   (car (cdr (cdr (cdr form)))))
 	     (fields (cdr (cdr (cdr (cdr form))))))
 	 `(begin
-	    (define ,name (make-record-type ',name))
+	    (define ,name (make-record-type ',name ',ctor))
 	    (define-record-constructor ,name ,@ctor)
 	    (define-record-predicate ,name ,pred)
 	    ,@(map (lambda (field) `(define-record-field ,pred ,@field))

src/write.c

@@ -11,6 +11,8 @@
 #include "picrin/vector.h"
 #include "picrin/blob.h"
 #include "picrin/dict.h"
+#include "picrin/record.h"
+#include "picrin/proc.h"
 
 static bool
 is_tagged(pic_state *pic, pic_sym tag, pic_value pair)
@@ -172,6 +174,27 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file)
   }
 }
 
+static void
+write_record(pic_state *pic, struct pic_record *rec, xFILE *file)
+{
+  const pic_sym sWRITER = pic_intern_cstr(pic, "writer");
+  pic_value type, writer, str;
+
+  type = pic_record_type(pic, rec);
+  if (! pic_record_p(type)) {
+    pic_errorf(pic, "\"@@type\" property of record object is not of record type");
+  }
+  writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER);
+  if (! pic_proc_p(writer)) {
+    pic_errorf(pic, "\"writer\" property of record type object is not a procedure");
+  }
+  str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec));
+  if (! pic_str_p(str)) {
+    pic_errorf(pic, "return value from writer procedure is not of string type");
+  }
+  xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str)));
+}
+
 static void
 write_core(struct writer_control *p, pic_value obj)
 {
@@ -310,6 +333,9 @@ write_core(struct writer_control *p, pic_value obj)
     }
     xfprintf(file, ")");
     break;
+  case PIC_TT_RECORD:
+    write_record(pic, pic_record_ptr(obj), file);
+    break;
   default:
     xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
     break;