From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Jan 2018 19:33:02 +0000 (-0500)
Subject: Implement define-unparser-method and define-pp-describer as deferred actions.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~406
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0d5ee21586bbf5aada279a0858d99ce98bf8f0a5;p=mit-scheme.git

Implement define-unparser-method and define-pp-describer as deferred actions.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 0b24943a0..0f6222fb2 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -73,55 +73,6 @@ USA.
    (fix:and limit-mask (get-interrupt-enables))
    procedure))
 
-;;;; Printing
-
-(define (unparser-method? object)
-  (and (procedure? object)
-       (procedure-arity-valid? object 2)))
-
-(define (general-unparser-method procedure)
-  (lambda (state object)
-    (with-current-unparser-state state
-      (lambda (port)
-	(if (get-param:unparse-with-maximum-readability?)
-	    (begin
-	      (write-string "#@" port)
-	      (write (object-hash object) port))
-	    (procedure object port))))))
-
-(define (bracketed-unparser-method procedure)
-  (general-unparser-method
-   (lambda (object port)
-     (write-string "#[" port)
-     (procedure object port)
-     (write-char #\] port))))
-
-(define (standard-unparser-method name procedure)
-  (bracketed-unparser-method
-   (lambda (object port)
-     (display (if (procedure? name)
-		  (name object)
-		  name)
-	      port)
-     (write-char #\space port)
-     (write (object-hash object) port)
-     (if procedure (procedure object port)))))
-
-(define (simple-unparser-method name get-parts)
-  (standard-unparser-method name
-    (and get-parts
-	 (lambda (object port)
-	   (for-each (lambda (object)
-		       (write-char #\space port)
-		       (write object port))
-		     (get-parts object))))))
-
-(define (simple-parser-method procedure)
-  (lambda (objects lose)
-    (or (and (pair? (cdr objects))
-	     (procedure (cddr objects)))
-	(lose))))
-
 ;;;; Boot-time initializers
 
 (define (init-boot-inits!)
@@ -199,6 +150,65 @@ USA.
 (define saved-boot-inits '())
 (define boot-action-groups '())
 
+;;;; Printing
+
+(define (define-unparser-method predicate unparser)
+  (defer-boot-action 'unparser-methods
+    (lambda ()
+      (define-unparser-method predicate unparser))))
+
+(define (define-pp-describer predicate describer)
+  (defer-boot-action 'pp-describers
+    (lambda ()
+      (define-pp-describer predicate describer))))
+
+(define (unparser-method? object)
+  (and (procedure? object)
+       (procedure-arity-valid? object 2)))
+
+(define (general-unparser-method procedure)
+  (lambda (state object)
+    (with-current-unparser-state state
+      (lambda (port)
+	(if (get-param:unparse-with-maximum-readability?)
+	    (begin
+	      (write-string "#@" port)
+	      (write (object-hash object) port))
+	    (procedure object port))))))
+
+(define (bracketed-unparser-method procedure)
+  (general-unparser-method
+   (lambda (object port)
+     (write-string "#[" port)
+     (procedure object port)
+     (write-char #\] port))))
+
+(define (standard-unparser-method name procedure)
+  (bracketed-unparser-method
+   (lambda (object port)
+     (display (if (procedure? name)
+		  (name object)
+		  name)
+	      port)
+     (write-char #\space port)
+     (write (object-hash object) port)
+     (if procedure (procedure object port)))))
+
+(define (simple-unparser-method name get-parts)
+  (standard-unparser-method name
+    (and get-parts
+	 (lambda (object port)
+	   (for-each (lambda (object)
+		       (write-char #\space port)
+		       (write object port))
+		     (get-parts object))))))
+
+(define (simple-parser-method procedure)
+  (lambda (objects lose)
+    (or (and (pair? (cdr objects))
+	     (procedure (cddr objects)))
+	(lose))))
+
 ;;;; Miscellany
 
 (define (object-constant? object)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e2deda884..5fa235215 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -139,6 +139,8 @@ USA.
 	  bytes-per-object
 	  default-object
 	  default-object?
+	  define-pp-describer
+	  define-unparser-method
 	  gc-space-status
 	  general-unparser-method
 	  interrupt-bit/after-gc