From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Jan 2018 19:38:44 +0000 (-0500)
Subject: Implement real define-unparser-method.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~405
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=75f9b0c1727c45df814dda9805cef0c410e6c508;p=mit-scheme.git

Implement real define-unparser-method.
---

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 3b7dd42ca..de06b5776 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -223,10 +223,10 @@ USA.
   (guarantee output-port? port)
   (if (not (default-object? environment))
       (guarantee environment? environment))
-  (*unparse-object object
-		   (top-level-context port
-				      (if slashify? 'normal 'display)
-				      environment)))
+  (unparse-object (top-level-context port
+				     (if slashify? 'normal 'display)
+				     environment)
+		  object))
 
 (define (top-level-context port mode environment)
   (let ((context (initial-context)))
@@ -262,15 +262,28 @@ USA.
   (guarantee context? context 'unparse-string)
   (write-string string (context-port context)))
 
-(define (unparse-object context object)
-  (guarantee context? context 'unparse-object)
-  (*unparse-object object context))
-
-(define (*unparse-object object context)
-  ((vector-ref dispatch-table
-               ((ucode-primitive primitive-object-type 1) object))
-   object
-   context))
+(define unparse-object)
+(add-boot-init!
+ (lambda ()
+   (set! unparse-object
+	 (standard-predicate-dispatcher 'unparse-object 2))
+
+   (define-predicate-dispatch-default-handler unparse-object
+     (lambda (context object)
+       ((vector-ref dispatch-table
+		    ((ucode-primitive primitive-object-type 1) object))
+	object
+	context)))
+
+   (set! define-unparser-method
+	 (named-lambda (define-unparser-method predicate unparser)
+	   (define-predicate-dispatch-handler unparse-object
+	     (list context? predicate)
+	     unparser)))
+   (run-deferred-boot-actions 'unparser-methods)))
+
+(define-integrable (*unparse-object object context)
+  (unparse-object context object))
 
 (define-integrable (invoke-user-method method object context)
   (method context object))