From 1f8c06114e81e521865b3836fce9d293f6f88417 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). Signed-off-by: Peter Bex --- DEPRECATED | 3 +++ NEWS | 3 +++ chicken-syntax.scm | 2 +- chicken.base.import.scm | 2 ++ distribution/manifest | 1 + library.scm | 30 ++++++++++++++++++++++++------ manual/Module (chicken base) | 19 +++++++++++++------ tests/record-printer-test.scm | 29 +++++++++++++++++++++++++++++ tests/runtests.bat | 6 ++++++ tests/runtests.sh | 3 +++ types.db | 3 +++ 11 files changed, 88 insertions(+), 13 deletions(-) create mode 100644 tests/record-printer-test.scm 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 7d216375..b2a11a8f 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-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 bc0ef42c..a6f35899 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 +(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 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 -- 2.20.1