Merge branch 'reader-constructor'

piclib/picrin/array.scm

@@ -1,5 +1,7 @@
 (define-library (picrin array)
-  (import (scheme base))
+  (import (scheme base)
+          (scheme write)
+          (picrin record))
 
   (define-record-type <array>
     (create-array data size head tail)
@@ -87,6 +89,20 @@
   (define (array-for-each proc ary)
     (for-each proc (array->list ary)))
 
+  (define (print-array array)
+    (call-with-port (open-output-string)
+      (lambda (port)
+        (display "#.(array" port)
+        (array-for-each
+         (lambda (obj)
+           (display " " port)
+           (write obj port))
+         array)
+        (display ")" port)
+        (get-output-string port))))
+
+  (record-set! <array> 'writer print-array)
+
   (export make-array
           array
           array?

piclib/picrin/user.scm

@@ -11,4 +11,6 @@
           (scheme cxr)
           (scheme lazy)
           (scheme time)
-          (picrin macro)))
+          (picrin macro)
+          (picrin dictionary)
+          (picrin array)))

piclib/scheme/base.scm

@@ -750,19 +750,34 @@
 
   ;; 5.5 Recored-type definitions
 
-  (import (picrin record))
+  (import (picrin record)
+          (scheme write))
+
+  (define ((default-record-writer ctor) 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)))
+
+  (define ((boot-make-record-type <meta-type>) name ctor)
+    (let ((rectype (make-record <meta-type>)))
+      (record-set! rectype 'name name)
+      (record-set! rectype 'writer (default-record-writer ctor))
+      rectype))
 
   (define <record-type>
-    (let ((<record-type> (make-record #t)))    ; bootstrap
-      (let ((type-type (make-record <record-type>)))
-        (record-set! <record-type> '@@type type-type)
-        (record-set! type-type 'name '<record-type>)
-        <record-type>)))
+    (let ((<record-type>
+           ((boot-make-record-type #t) 'record-type '(record-type name writer))))
+      (record-set! <record-type> '@@type <record-type>)
+      <record-type>))
 
-  (define (make-record-type name)
-    (let ((rectype (make-record <record-type>)))
-      (record-set! rectype 'name name)
-      rectype))
+  (define make-record-type (boot-make-record-type <record-type>))
 
   (define-syntax define-record-constructor
     (ir-macro-transformer
@@ -817,7 +832,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/codegen.c

@@ -796,35 +796,9 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
 
     return analyze_call(state, obj, tailpos);
   }
-  case PIC_TT_BOOL:
-  case PIC_TT_FLOAT:
-  case PIC_TT_INT:
-  case PIC_TT_NIL:
-  case PIC_TT_CHAR:
-  case PIC_TT_STRING:
-  case PIC_TT_VECTOR:
-  case PIC_TT_BLOB: {
+  default:
     return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj);
   }
-  case PIC_TT_CONT:
-  case PIC_TT_ENV:
-  case PIC_TT_PROC:
-  case PIC_TT_UNDEF:
-  case PIC_TT_EOF:
-  case PIC_TT_PORT:
-  case PIC_TT_ERROR:
-  case PIC_TT_SENV:
-  case PIC_TT_MACRO:
-  case PIC_TT_LIB:
-  case PIC_TT_VAR:
-  case PIC_TT_IREP:
-  case PIC_TT_DATA:
-  case PIC_TT_DICT:
-  case PIC_TT_RECORD:
-  case PIC_TT_BLK:
-    pic_errorf(pic, "invalid expression given: ~s", obj);
-  }
-  UNREACHABLE();
 }
 
 pic_value

src/read.c

@@ -149,6 +149,18 @@ read_directive(pic_state *pic, struct pic_port *port, int c)
   return read_comment(pic, port, c);
 }
 
+static pic_value
+read_eval(pic_state *pic, struct pic_port *port, int c)
+{
+  pic_value form;
+
+  UNUSED(c);
+
+  form = read(pic, port, next(port));
+
+  return pic_eval(pic, form, pic->lib);
+}
+
 static pic_value
 read_quote(pic_state *pic, struct pic_port *port, int c)
 {
@@ -655,6 +667,8 @@ read_dispatch(pic_state *pic, struct pic_port *port, int c)
     return read_label(pic, port, c);
   case 'u':
     return read_unsigned_blob(pic, port, c);
+  case '.':
+    return read_eval(pic, port, c);
   default:
     read_error(pic, "unexpected dispatch character");
   }

src/write.c

@@ -10,7 +10,9 @@
 #include "picrin/string.h"
 #include "picrin/vector.h"
 #include "picrin/blob.h"
-#include "picrin/macro.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,35 @@ 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;
+
+#if DEBUG
+
+  xfprintf(file, "#<record %p>", rec);
+
+#else
+
+  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)));
+
+#endif
+}
+
 static void
 write_core(struct writer_control *p, pic_value obj)
 {
@@ -179,6 +210,7 @@ write_core(struct writer_control *p, pic_value obj)
   xFILE *file = p->file;
   size_t i;
   xh_entry *e;
+  xh_iter it;
   int c;
   float f;
 
@@ -198,6 +230,9 @@ write_core(struct writer_control *p, pic_value obj)
   }
 
   switch (pic_type(obj)) {
+  case PIC_TT_UNDEF:
+    xfprintf(file, "#<undef>");
+    break;
   case PIC_TT_NIL:
     xfprintf(file, "()");
     break;
@@ -266,16 +301,7 @@ write_core(struct writer_control *p, pic_value obj)
     xfprintf(file, "%d", pic_int(obj));
     break;
   case PIC_TT_EOF:
-    xfprintf(file, "#<eof-object>");
-    break;
-  case PIC_TT_UNDEF:
-    xfprintf(file, "#<undef>");
-    break;
-  case PIC_TT_PROC:
-    xfprintf(file, "#<proc %p>", pic_ptr(obj));
-    break;
-  case PIC_TT_PORT:
-    xfprintf(file, "#<port %p>", pic_ptr(obj));
+    xfprintf(file, "#.(eof-object)");
     break;
   case PIC_TT_STRING:
     if (p->mode == DISPLAY_MODE) {
@@ -306,8 +332,21 @@ write_core(struct writer_control *p, pic_value obj)
     }
     xfprintf(file, ")");
     break;
+  case PIC_TT_DICT:
+    xfprintf(file, "#.(dictionary");
+    xh_begin(&it, &pic_dict_ptr(obj)->hash);
+    while (xh_next(&it)) {
+      xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym)));
+      write_core(p, xh_val(it.e, pic_value));
+    }
+    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;
   }
 }