Fix printing of promises.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index d06b5a6f3dfe1c603379b007d6f1e431927cb01b..c73ab8d7320c6e60e6593bcdd586ccb46607f676 100644 (file)
--- 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))))))
 \f
 ;;;; 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 d745f70f58cd4c13162ed88a11aa772075d8e49a..013e687340fe22f6ec3fd9949055de96da0f27a8 100644 (file)
--- 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*)