~ chicken-core (chicken-5) fc4ffafc16788bddf58bc48c6d784afc83d5b63b

commit fc4ffafc16788bddf58bc48c6d784afc83d5b63b
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Aug 13 21:53:35 2019 +1200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Sep 15 13:23:49 2019 +1200

    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).
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/DEPRECATED b/DEPRECATED
index d3d8d2b7..40756ce2 100644
--- a/DEPRECATED
+++ b/DEPRECATED
@@ -7,6 +7,9 @@ Deprecated functions and variables
   C_i_check_exact_2 have been deprecated (see also #1631).
 - "C_u_i_zerop" has been turned into an inline operation and is
   deprecated in favor of "C_u_i_zerop2".
+- 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 11043081..5642c85b 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,9 @@
   - There is now a srfi-88 module which contains just the three
     procedures from the (chicken keyword) module defined by the SRFI.
   - A feature identifier named "srfi-88" is now registered.
+  - 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-syntax.scm b/chicken-syntax.scm
index 86aa74c7..e943222d 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1040,7 +1040,7 @@
 ;;; Record printing:
 
 (##sys#extend-macro-environment
- 'define-record-printer '()
+ 'define-record-printer '() ;; DEPRECATED
  (##sys#er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'define-record-printer form '(_ _ . _))
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 2b5f4ef6..29b85878 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,27 @@ 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)
+    (##sys#check-symbol type 'record-printer)
+    (let ((a (assq type ##sys#record-printers)))
+      (and a (cdr a)))))
+
+(set! chicken.base#set-record-printer!
+  (lambda (type proc)
+    (##sys#check-symbol type 'set-record-printer!)
+    (##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 2c85d71c..5b581747 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 9f882dda..a9268e2e 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 #:enforce) chicken.base#record-printer (symbol) (or false procedure)))
+(chicken.base#set-record-printer! (#(procedure #:enforce) chicken.base#set-record-printer! (symbol procedure) undefined))
+
 (chicken.base#alist-ref
  (forall (a b c d)
          (#(procedure #:clean #:foldable) chicken.base#alist-ref