From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 2 Nov 2018 03:29:37 +0000 (-0700)
Subject: Fix printing of promises.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~125
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5d08aa4ff7ac43f054b5a4043fcd697fb67a4119;p=mit-scheme.git

Fix printing of promises.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index d06b5a6f3..c73ab8d73 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -481,6 +481,13 @@ USA.
 		     (system-pair-set-cdr! p (system-pair-cdr p*))
 		     (set-cell-contents! promise* p))))))
 	  (%force promise)))))
+
+(define-print-method promise?
+  (standard-print-method 'promise
+    (lambda (promise)
+      (if (promise-forced? promise)
+	  (list '(evaluated) (promise-value promise))
+	  (list '(unevaluated))))))
 
 ;;;; Miscellany
 
@@ -491,10 +498,10 @@ USA.
   object
   #f)
 
-(define (default-object? object)
+(define-integrable (default-object? object)
   (eq? object #!default))
 
-(define (default-object)
+(define-integrable (default-object)
   #!default)
 
 (define (gc-space-status)
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index d745f70f5..013e68734 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -373,7 +373,6 @@ USA.
 	       (positive-fixnum ,print-number)
 	       (primitive ,print-primitive-procedure)
 	       (procedure ,print-compound-procedure)
-	       (promise ,print-promise)
 	       (ratnum ,print-number)
 	       (record ,print-record)
 	       (return-address ,print-return-address)
@@ -988,19 +987,6 @@ USA.
          (*print-readable-hash entity context))
         (else (plain 'entity))))
 
-(define (print-promise promise context)
-  (*print-with-brackets 'promise promise context
-    (if (promise-forced? promise)
-	(lambda (context*)
-	  (*print-string " (evaluated) " context*)
-	  (print-object (promise-value promise) context*))
-	(lambda (context*)
-	  (*print-string " (unevaluated)" context*)
-	  (if (get-param:print-with-datum?)
-	      (begin
-		(*print-char #\space context*)
-		(*print-datum promise context*)))))))
-
 (define (print-tagged-object object context)
   (*print-with-brackets 'tagged-object object context
     (lambda (context*)