>From a9c71a2dcab99f5b3359fd42e442162d97c82bcf Mon Sep 17 00:00:00 2001 From: Evan Hanson 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 +(record-printer NAME)
-(define-record-printer (NAME RECORDVAR PORTVAR) BODY ...)
-(define-record-printer NAME PROCEDURE) +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! + +(set-record-printer! NAME PROCEDURE)
+(set! (record-printer NAME) 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? "#" (conc (make-kons 1 2)))) + +;; custom printer + +(set-record-printer! kons + (lambda (k p) + (fprintf p "#" (kons-x k) (kons-y k)))) + +(assert (equal? "#" (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