From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 28 Feb 2018 06:16:05 +0000 (-0800)
Subject: Allow calling register-predicate! twice with the same args.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~226
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d15ddd23d1159285fa371c6f85fbc234bc345a81;p=mit-scheme.git

Allow calling register-predicate! twice with the same args.
---

diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index bf67390d2..da8dfc65d 100644
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -129,17 +129,24 @@ USA.
 		 'register-predicate!)))
 	   (named-lambda (register-predicate! predicate name . keylist)
 	     (guarantee keyword-list? keylist 'register-predicate!)
-	     (let ((tag (make-simple-tag name predicate)))
+	     (let ((tag
+		    (let ((tag (get-predicate-tag predicate #f)))
+		      (if tag
+			  (begin
+			    (if (not (eq? name (dispatch-tag-name tag)))
+				(error "Can't re-register predicate:"
+				       predicate name))
+			    tag)
+			  (make-simple-tag name predicate)))))
 	       (for-each (lambda (superset)
 			   (set-predicate<=! predicate superset))
 			 (get-keyword-values keylist '<=))
 	       tag))))
    (set! set-dispatch-tag<=!
 	 (named-lambda (set-dispatch-tag<=! tag superset)
-	   (if (not (add-dispatch-tag-superset tag superset))
-	       (error "Tag already has this superset:" tag superset))
 	   (if (dispatch-tag>= tag superset)
 	       (error "Not allowed to create a superset loop:" tag superset))
+	   (add-dispatch-tag-superset tag superset)
 	   (hash-table-clear! dispatch-tag<=-cache)))
    (set! set-predicate<=!
 	 (named-lambda (set-predicate<=! predicate superset)