Eliminate predicate-description.

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 84e1cfa373a47236c3f35e0da7193e5e3987fa5a..d8f30aeb387df5c6753ead9fdd03bc1660d6b702 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -396,6 +396,14 @@ USA.
                                             (predicate-description predicate))
                              caller))
 
+(define (predicate-description predicate)
+  (if (predicate? predicate)
+      (predicate-name predicate)
+      (call-with-output-string
+       (lambda (port)
+         (write-string "object satisfying " port)
+         (write predicate port)))))
+
 ;;;; Miscellany
 
 (define (object-constant? object)

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index b488517657d7f8def1ad434d77d1436ba7add96e..67cd2ebe975af4477da8faeba37525462235c006 100644 (file)
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -45,8 +45,7 @@ USA.
     (guarantee keyword-list? keylist 'register-predicate!)
     (let ((tag
           (make-tag name predicate 'register-predicate!
-                    (get-keyword-value keylist 'extra)
-                    (get-keyword-value keylist 'description))))
+                    (get-keyword-value keylist 'extra))))
       (for-each (lambda (superset)
                  (set-tag<=! tag (predicate->tag superset)))
                (get-keyword-values keylist '<=))
@@ -55,12 +54,6 @@ USA.
 (define (predicate-name predicate)
   (tag-name (predicate->tag predicate 'predicate-name)))
 
-(define (predicate-description predicate)
-  (let ((tag (get-predicate-tag predicate #f)))
-    (if tag
-        (tag-description tag)
-        (string-append "object satisfying " (object->description predicate)))))
-
 (define (set-predicate<=! predicate superset)
   (set-tag<=! (predicate->tag predicate 'set-predicate<=!)
               (predicate->tag superset 'set-predicate<=!)))
@@ -71,20 +64,15 @@ USA.
         (error:not-a predicate? predicate caller))
     tag))
 \f
-(define (make-tag name predicate caller #!optional extra description)
+(define (make-tag name predicate caller #!optional extra)
   (guarantee tag-name? name caller)
   (guarantee unary-procedure? predicate caller)
   (if (predicate? predicate)
       (error "Can't assign multiple tags to the same predicate:" predicate))
-  (if (not (default-object? description))
-      (guarantee string? description caller))
   (let ((tag
         (%make-tag name
                    predicate
                    (if (default-object? extra) #f extra)
-                   (if (default-object? description)
-                       (delay (object->description name))
-                       (delay description))
                    (%make-weak-set))))
     (set-predicate-tag! predicate tag)
     tag))
@@ -99,18 +87,12 @@ USA.
                        (tag-name? elt)))
                  (cdr object)))))
 
-(define (object->description object)
-  (call-with-output-string
-    (lambda (port)
-      (write object port))))
-
 (define-record-type <tag>
-    (%make-tag name predicate extra description supersets)
+    (%make-tag name predicate extra supersets)
     tag?
   (name tag-name)
   (predicate tag->predicate)
   (extra tag-extra)
-  (description %tag-description)
   (supersets %tag-supersets))
 
 (define-unparser-method tag?
@@ -118,9 +100,6 @@ USA.
     (lambda (tag)
       (list (tag-name tag)))))
 
-(define (tag-description tag)
-  (force (%tag-description tag)))
-
 (define (tag-supersets tag)
   (%weak-set->list (%tag-supersets tag)))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 57b52c920d18250e89756d97141537cd6ac83b7f..4d6755998d2f71842daffcb936ed01661fdac741 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1842,7 +1842,6 @@ USA.
   (files "predicate-metadata")
   (parent (runtime))
   (export ()
-         predicate-description
          predicate-name
          set-predicate<=!)
   (export (runtime)
@@ -1852,7 +1851,6 @@ USA.
          predicate->tag
          set-tag<=!
          tag->predicate
-         tag-description
          tag-extra
          tag-name
          tag-supersets