From 8de6f83b10097be8cdc30a67c9ebc6c4cef9cc3b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Jan 2018 15:19:42 -0500
Subject: [PATCH] Reimplement bundle printers to be more like other printers.
---
src/runtime/bundle.scm | 19 ++++++++++++-------
src/runtime/runtime.pkg | 1 +
2 files changed, 13 insertions(+), 7 deletions(-)
diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 6f4ebf33e..c1fd3229d 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -131,15 +131,18 @@ USA.
(tag bundle-metadata-tag)
(alist bundle-metadata-alist))
+(define (define-bundle-printer interface printer)
+ (hash-table-set! bundle-printers (predicate->tag interface) printer))
+
(set-record-type-entity-unparser-method! <bundle-metadata>
- (bracketed-unparser-method
+ (standard-unparser-method
+ (lambda (bundle)
+ (bim-name (tag-extra (bundle-tag bundle))))
(lambda (bundle port)
- (write (bim-name (tag-extra (bundle-tag bundle))) port)
- (write-string " " port)
- (write (object-hash bundle) port)
- (let ((handler (bundle-ref bundle 'write-self #f)))
- (if handler
- (handler port))))))
+ (let ((printer
+ (hash-table-ref/default bundle-printers (bundle-tag bundle) #f)))
+ (if printer
+ (printer bundle port))))))
(define (bundle? object)
(and (entity? object)
@@ -170,9 +173,11 @@ USA.
default))))
(define the-bundle-tag)
+(define bundle-printers)
(add-boot-init!
(lambda ()
(register-predicate! bundle? 'bundle '<= entity?)
(set! the-bundle-tag (predicate->tag bundle?))
+ (set! bundle-printers (make-key-weak-eqv-hash-table))
(register-predicate! bundle-interface? 'bundle-interface '<= predicate?)
(register-predicate! clauses? 'interface-clauses)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b24fde256..e2e36ff39 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1950,6 +1950,7 @@ USA.
bundle-names
bundle-ref
bundle?
+ define-bundle-printer
make-bundle
make-bundle-interface))
--
2.25.1