Merge branch 'define-record-writer'

piclib/CMakeLists.txt

@@ -6,6 +6,7 @@ list(APPEND PICLIB_SCHEME_LIBS
 
   ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
 
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm

piclib/picrin/array.scm

@@ -89,19 +89,17 @@
   (define (array-for-each proc ary)
     (for-each proc (array->list ary)))
 
-  (define (print-array array)
+  (define-record-writer (<array> array)
     (call-with-port (open-output-string)
-      (lambda (port)
+     (lambda (port)
-        (display "#.(array" port)
+       (display "#.(array" port)
-        (array-for-each
+       (array-for-each
-         (lambda (obj)
+        (lambda (obj)
-           (display " " port)
+          (display " " port)
-           (write obj port))
+          (write obj port))
-         array)
+        array)
-        (display ")" port)
+       (display ")" port)
-        (get-output-string port))))
+       (get-output-string port))))
-
-  (record-set! <array> 'writer print-array)
 
   (export make-array
           array

piclib/picrin/record.scm

@@ -0,0 +1,17 @@
+(define-library (picrin record)
+  (import (scheme base))
+
+  (define (define-record-writer* record-type writer)
+    (record-set! record-type 'writer writer))
+
+  (define-syntax define-record-writer
+    (syntax-rules ()
+      ((_ (type obj) body ...)
+       (define-record-writer* type
+         (lambda (obj)
+           body ...)))
+      ((_ type writer)
+       (define-record-writer* type
+         writer))))
+
+  (export define-record-writer))