From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 6 May 2017 21:53:35 +0000 (-0700)
Subject: Register char and char-set predicates.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~74
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=61ef22e5381fedcac04b1bfd736ba7d88f09f23e;p=mit-scheme.git

Register char and char-set predicates.
---

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 78371080e..96381169b 100644
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -91,13 +91,21 @@ USA.
 
 (define (char=-predicate char)
   (guarantee char? char 'char=-predicate)
-  (lambda (char*)
-    (char=? char* char)))
+  (let ((predicate
+	 (lambda (char*)
+	   (and (char? char*)
+		(char=? char* char)))))
+    (register-predicate! predicate `(char=-predicate ,char) '<= char?)
+    predicate))
 
 (define (char-ci=-predicate char)
   (guarantee char? char 'char-ci=-predicate)
-  (lambda (char*)
-    (char-ci=? char* char)))
+  (let ((predicate
+	 (lambda (char*)
+	   (and (char? char*)
+		(char-ci=? char* char)))))
+    (register-predicate! predicate `(char-ci=-predicate ,char) '<= char?)
+    predicate))
 
 (define-integrable (%char=? x y)
   (fix:= (char->integer x) (char->integer y)))
diff --git a/src/runtime/chrset.scm b/src/runtime/chrset.scm
index dd33e8b95..96f43acf3 100644
--- a/src/runtime/chrset.scm
+++ b/src/runtime/chrset.scm
@@ -423,10 +423,13 @@ USA.
 	      #f)))))
 
 (define (char-set-predicate char-set)
-  (guarantee char-set? char-set 'CHAR-SET-PREDICATE)
-  (lambda (char)
-    (and (bitless-char? char)
-	 (char-in-set? char char-set))))
+  (guarantee char-set? char-set 'char-set-predicate)
+  (let ((predicate
+	 (lambda (char)
+	   (and (bitless-char? char)
+		(char-in-set? char char-set)))))
+    (register-predicate! predicate 'char-set-predicate '<= char?)
+    predicate))
 
 (define (char-set=? char-set . char-sets)
   (every (lambda (char-set*)