>From a9c71a2dcab99f5b3359fd42e442162d97c82bcf Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Tue, 13 Aug 2019 21:53:35 +1200
Subject: [PATCH] Add `record-printer' and `set-record-printer!' procedures

These offer a procedural way to specify how records are printed. They
deprecate the `define-record-printer' macro, which isn't a "real"
definition (see #1294).
---
 DEPRECATED                    |  3 +++
 NEWS                          |  3 +++
 chicken.base.import.scm       |  2 ++
 distribution/manifest         |  1 +
 library.scm                   | 28 ++++++++++++++++++++++------
 manual/Module (chicken base)  | 19 +++++++++++++------
 tests/record-printer-test.scm | 29 +++++++++++++++++++++++++++++
 tests/runtests.bat            |  6 ++++++
 tests/runtests.sh             |  3 +++
 types.db                      |  3 +++
 10 files changed, 85 insertions(+), 12 deletions(-)
 create mode 100644 tests/record-printer-test.scm

diff --git a/DEPRECATED b/DEPRECATED
index 6a43e129..8ab451e9 100644
--- a/DEPRECATED
+++ b/DEPRECATED
@@ -5,6 +5,9 @@ Deprecated functions and variables
 
 - ##sys#check-exact and its C implementations C_i_check_exact and
   C_i_check_exact_2 have been deprecated (see also #1631).
+- The define-record-printer macro has been deprecated in favour of
+  record-printer and set-record-printer! procedures, and a SRFI-17
+  setter for the former.
 
 
 5.0.0
diff --git a/NEWS b/NEWS
index e8cc6054..56ad305d 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,9 @@
   - for-each and map now behave consistently in compiled and interpreted
     mode, like in SRFI-1.  They now stop when the shortest list is
     exhausted instead of raising an exception (fixes #1422).
+  - The procedures `record-printer` and `set-record-printer!` and a
+    corresponding SRFI-17 setter have been added. These deprecate
+    `define-record-printer` which isn't a "real" definition (see #1294).
 
 - Runtime system
   - Quoted empty keywords like ||: and :|| are now read like prescribed
diff --git a/chicken.base.import.scm b/chicken.base.import.scm
index 7c823271..79c8e19f 100644
--- a/chicken.base.import.scm
+++ b/chicken.base.import.scm
@@ -96,6 +96,8 @@
    (quotient&remainder . chicken.base#quotient&remainder)
    (rassoc . chicken.base#rassoc)
    (ratnum? . chicken.base#ratnum?)
+   (record-printer . chicken.base#record-printer)
+   (set-record-printer! . chicken.base#set-record-printer!)
    (setter . chicken.base#setter)
    (signum . chicken.base#signum)
    (sleep . chicken.base#sleep)
diff --git a/distribution/manifest b/distribution/manifest
index 928d5ef1..316736e5 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -129,6 +129,7 @@ tests/compiler-tests.scm
 tests/inlining-tests.scm
 tests/locative-stress-test.scm
 tests/record-rename-test.scm
+tests/record-printer-test.scm
 tests/r4rstest.scm
 tests/r4rstest.expected
 tests/null.scm
diff --git a/library.scm b/library.scm
index bc0ef42c..142e7f8f 100644
--- a/library.scm
+++ b/library.scm
@@ -592,6 +592,7 @@ EOF
    notice procedure-information setter signum string->uninterned-symbol
    subvector symbol-append vector-copy! vector-resize
    warning quotient&remainder quotient&modulo
+   record-printer set-record-printer!
    alist-ref alist-update alist-update! rassoc atom? butlast chop
    compress flatten intersperse join list-of? tail? constantly
    complement compose conjoin disjoin each flip identity o
@@ -660,6 +661,8 @@ EOF
 (define procedure-information)
 (define setter)
 (define string->uninterned-symbol)
+(define record-printer)
+(define set-record-printer!)
 
 (define gensym)
 
@@ -4654,12 +4657,25 @@ EOF
 
 (define ##sys#record-printers '())
 
-(define (##sys#register-record-printer type proc)
-  (let ([a (assq type ##sys#record-printers)])
-    (if a 
-	(##sys#setslot a 1 proc)
-	(set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)) )
-    (##core#undefined) ) )
+(set! chicken.base#record-printer
+  (lambda (type)
+    (let ((a (assq type ##sys#record-printers)))
+      (and a (cdr a)))))
+
+(set! chicken.base#set-record-printer!
+  (lambda (type proc)
+    (##sys#check-closure proc 'set-record-printer!)
+    (let ((a (assq type ##sys#record-printers)))
+      (if a
+	  (##sys#setslot a 1 proc)
+	  (set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)))
+      (##core#undefined))))
+
+;; OBSOLETE can be removed after bootstrapping
+(set! ##sys#register-record-printer chicken.base#set-record-printer!)
+
+(set! chicken.base#record-printer
+  (getter-with-setter record-printer set-record-printer!))
 
 (define (##sys#user-print-hook x readable port)
   (let* ((type (##sys#slot x 0))
diff --git a/manual/Module (chicken base) b/manual/Module (chicken base)
index 3a8fab1e..49dad575 100644
--- a/manual/Module (chicken base)	
+++ b/manual/Module (chicken base)	
@@ -1187,11 +1187,17 @@ doesn't have to).
 This special form is also compatible with the definition from the R7RS
 {{(scheme base)}} library.
 
+==== record-printer
 
-==== define-record-printer
+<procedure>(record-printer NAME)</procedure><br>
 
-<macro>(define-record-printer (NAME RECORDVAR PORTVAR) BODY ...)</macro><br>
-<macro>(define-record-printer NAME PROCEDURE)</macro>
+Returns the procedure used to print records of the type {{NAME}} if
+one has been set with {{set-record-printer!}}, {{#f}} otherwise.
+
+==== set-record-printer!
+
+<procedure>(set-record-printer! NAME PROCEDURE)</procedure><br>
+<procedure>(set! (record-printer NAME) PROCEDURE)</procedure>
 
 Defines a printing method for record of the type {{NAME}} by
 associating a procedure with the record type. When a record of this
@@ -1205,9 +1211,10 @@ and an output-port.
   (y foo-y)
   (z foo-z))
 (define f (make-foo 1 2 3))
-(define-record-printer (foo x out)
-  (fprintf out "#,(foo ~S ~S ~S)"
-           (foo-x x) (foo-y x) (foo-z x)) )
+(set-record-printer! foo
+  (lambda (x out)
+    (fprintf out "#,(foo ~S ~S ~S)"
+             (foo-x x) (foo-y x) (foo-z x))))
 (define-reader-ctor 'foo make-foo)
 (define s (with-output-to-string
               (lambda () (write f))))
diff --git a/tests/record-printer-test.scm b/tests/record-printer-test.scm
new file mode 100644
index 00000000..60fcc51b
--- /dev/null
+++ b/tests/record-printer-test.scm
@@ -0,0 +1,29 @@
+;;;; record-printer-test.scm
+
+(import (chicken format)
+	(chicken string))
+
+(define-record kons x y)
+
+;; no printer to start out
+
+(assert (not (record-printer kons)))
+(assert (equal? "#<kons>" (conc (make-kons 1 2))))
+
+;; custom printer
+
+(set-record-printer! kons
+ (lambda (k p)
+   (fprintf p "#<kons ~a ~a>" (kons-x k) (kons-y k))))
+
+(assert (equal? "#<kons 1 2>" (conc (make-kons 1 2))))
+
+;; srfi-17 style assignment
+
+(assert (procedure? (setter record-printer)))
+
+(set! (record-printer kons)
+  (lambda (k p)
+    (fprintf p "#[~a . ~a]" (kons-x k) (kons-y k))))
+
+(assert (equal? "#[1 . 2]" (conc (make-kons 1 2))))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 5765f146..3234ee06 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -219,6 +219,12 @@ if errorlevel 1 exit /b 1
 if errorlevel 1 exit /b 1
 a.out
 if errorlevel 1 exit /b 1
+%interpret% -s record-printer-test.scm
+if errorlevel 1 exit /b 1
+%compile% record-printer-test.scm
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
 
 echo ======================================== reader tests ...
 %interpret% -s reader-tests.scm
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 1811cc35..f4a80e81 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -193,6 +193,9 @@ $compile -specialize library-tests.scm
 $interpret -s records-and-setters-test.scm
 $compile records-and-setters-test.scm
 ./a.out
+$interpret -s record-printer-test.scm
+$compile record-printer-test.scm
+./a.out
 
 echo "======================================== reader tests ..."
 $interpret -s reader-tests.scm
diff --git a/types.db b/types.db
index 06514b28..4d94ac16 100644
--- a/types.db
+++ b/types.db
@@ -1005,6 +1005,9 @@
 ;; TODO: Add nonspecializing type specific entries, to help flow analysis?
 (chicken.base#quotient&modulo (#(procedure #:clean #:enforce #:foldable) chicken.base#quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float)))
 
+(chicken.base#record-printer (#(procedure) chicken.base#record-printer (*) (or false procedure)))
+(chicken.base#set-record-printer! (#(procedure) chicken.base#set-record-printer! (* procedure)) undefined))
+
 (chicken.base#alist-ref
  (forall (a b c d)
          (#(procedure #:clean #:foldable) chicken.base#alist-ref
-- 
2.22.0