From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 11 Feb 2017 22:39:47 +0000 (-0800)
Subject: Clean up char->digit and digit->char.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~136
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cea9230a49dc9239dc5a30efbc1a20c82f1bf732;p=mit-scheme.git

Clean up char->digit and digit->char.
---

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 88f456e72..0f13d3d94 100644
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -177,11 +177,6 @@ USA.
   (and (char-numeric? char)
        (ucd-nv-value char)))
 
-(define-deferred 0-code (char->integer #\0))
-;; Next two codes are offset by 10 to speed up CHAR->DIGIT.
-(define-deferred upper-a-code (fix:- (char->integer #\A) 10))
-(define-deferred lower-a-code (fix:- (char->integer #\a) 10))
-
 (define (radix? object)
   (and (index-fixnum? object)
        (fix:<= 2 object)
@@ -190,35 +185,37 @@ USA.
 (define-guarantee radix "radix")
 
 (define (digit->char digit #!optional radix)
-  (guarantee-limited-index-fixnum digit
-				  (if (default-object? radix)
-				      10
-				      (begin
-					(guarantee-radix radix 'DIGIT->CHAR)
-					radix))
-				  'DIGIT->CHAR)
+  (let ((radix
+	 (if (default-object? radix)
+	     10
+	     (begin
+	       (guarantee radix? radix 'digit->char)
+	       radix))))
+    (guarantee index-fixnum? digit 'digit->char)
+    (if (not (fix:< digit radix))
+	(error:bad-range-argument digit 'digit->char)))
   (string-ref "0123456789abcdefghijklmnopqrstuvwxyz" digit))
 
 (define (char->digit char #!optional radix)
-  (let ((code (char->integer char))
-	(radix
-	 (cond ((default-object? radix)
-		10)
-	       ((and (fix:fixnum? radix)
-		     (fix:<= 2 radix) (fix:<= radix 36))
-		radix)
-	       (else
-		(error:wrong-type-argument radix "radix" 'CHAR->DIGIT)))))
-    (let ((n (fix:- code 0-code)))
-      (if (and (fix:<= 0 n) (fix:< n radix))
-	  n
-	  (let ((n (fix:- code upper-a-code)))
-	    (if (and (fix:<= 10 n) (fix:< n radix))
-		n
-		(let ((n (fix:- code lower-a-code)))
-		  (if (and (fix:<= 10 n) (fix:< n radix))
-		      n
-		      #f))))))))
+  (let ((radix
+	 (if (default-object? radix)
+	     10
+	     (begin
+	       (guarantee radix? radix 'CHAR->DIGIT)
+	       radix)))
+	(digit (digit-value char)))
+    (if digit
+	(and (fix:< digit radix)
+	     digit)
+	(and (fix:> radix 10)
+	     (let ((code (char->integer char)))
+	       (let ((n (fix:- code (fix:- (char->integer #\A) 10))))
+		 (if (and (fix:<= 10 n) (fix:< n radix))
+		     n
+		     (let ((n (fix:- code (fix:- (char->integer #\a) 10))))
+		       (if (and (fix:<= 10 n) (fix:< n radix))
+			   n
+			   #f)))))))))
 
 ;;;; Character names
 
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index eb2b8dd95..06082e347 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -253,6 +253,7 @@ USA.
 			'<= exact-nonnegative-integer?)
    (register-predicate! non-positive-fixnum? 'non-positive-fixnum
 			'<= fix:fixnum?)
+   (register-predicate! radix? 'radix '<= index-fixnum?)
 
    (register-predicate! flo:flonum? 'flonum '<= real?)