From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 17 Jan 2017 21:19:18 +0000 (-0800)
Subject: Change register-predicate! to accept multiple '<= args.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~120
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8bff0b38dbf8bbe7e20d789c273161bc63381c0f;p=mit-scheme.git

Change register-predicate! to accept multiple '<= args.
---

diff --git a/src/runtime/binary-port.scm b/src/runtime/binary-port.scm
index d752c0ad5..8073081b0 100644
--- a/src/runtime/binary-port.scm
+++ b/src/runtime/binary-port.scm
@@ -84,7 +84,8 @@ USA.
    (register-predicate! binary-output-port? 'binary-output-port
 			'<= binary-port?)
    (register-predicate! binary-i/o-port? 'binary-i/o-port
-			'<= (list binary-input-port? binary-output-port?))))
+			'<= binary-input-port?
+			'<= binary-output-port?)))
 
 (set-record-type-unparser-method! <binary-port>
   (standard-unparser-method
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 03103aa06..e338fc4a1 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -48,14 +48,11 @@ USA.
          (make-tag predicate
                    name
                    (get-keyword-value keylist 'extra)
-                   (get-keyword-value keylist 'description)))
-        (superset (get-keyword-value keylist '<=)))
-    (if (not (default-object? superset))
-	(for-each (lambda (superset)
-		    (set-tag<=! tag (predicate->tag superset)))
-		  (if (list? superset)
-		      superset
-		      (list superset))))))
+                   (get-keyword-value keylist 'description))))
+    (for-each (lambda (superset)
+		(set-tag<=! tag (predicate->tag superset)))
+	      (get-keyword-values keylist '<=))
+    tag))
 
 (define (predicate->tag predicate #!optional caller)
   (let ((tag (get-predicate-tag predicate #f)))
@@ -252,13 +249,16 @@ USA.
 
    (register-predicate! fix:fixnum? 'fixnum '<= exact-integer?)
    (register-predicate! index-fixnum? 'index-fixnum
-			'<= (list fix:fixnum? exact-nonnegative-integer?))
+			'<= fix:fixnum?
+			'<= exact-nonnegative-integer?)
    (register-predicate! byte? 'byte '<= index-fixnum?)
    (register-predicate! negative-fixnum? 'negative-fixnum '<= fix:fixnum?)
    (register-predicate! positive-fixnum? 'positive-fixnum
-			'<= (list fix:fixnum? exact-positive-integer?))
+			'<= fix:fixnum?
+			'<= exact-positive-integer?)
    (register-predicate! non-negative-fixnum? 'non-negative-fixnum
-			'<= (list fix:fixnum? exact-nonnegative-integer?))
+			'<= fix:fixnum?
+			'<= exact-nonnegative-integer?)
    (register-predicate! non-positive-fixnum? 'non-positive-fixnum
 			'<= fix:fixnum?)
 
@@ -269,7 +269,9 @@ USA.
    (register-predicate! keyword-list? 'keyword-list '<= list?)
    (register-predicate! list-of-unique-symbols? 'list-of-unique-symbols
 			'<= list?)
-   (register-predicate! non-empty-list? 'non-empty-list '<= (list list? pair?))
+   (register-predicate! non-empty-list? 'non-empty-list
+			'<= list?
+			'<= pair?)
    (register-predicate! unique-keyword-list? 'unique-keyword-list
 			'<= keyword-list?)