From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 Jan 2018 04:12:20 +0000 (-0800)
Subject: Eliminate predicate-description.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~359
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a35a8d9e299039573c8f6de17ed887aeed701d7d;p=mit-scheme.git

Eliminate predicate-description.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 84e1cfa37..d8f30aeb3 100644
--- 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 b48851765..67cd2ebe9 100644
--- 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))
 
-(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 57b52c920..4d6755998 100644
--- 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