From 0b96758f3645dff3e681d82cc97ddab1faae27ac Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Sun, 31 Oct 2004 10:34:47 +0000
Subject: [PATCH] 0.8.16.20: 	A couple more BASE-CHAR-CODE-LIMIT-related
 fixes: 	... legal format directives are all
 base-chars; 	... define the BASE-CHAR type in terms of
 the limit constant. 	Also add remaining test cases to the
 test suite, just to get them 	out of the way.

---
 src/code/deftypes-for-target.lisp |    3 ++-
 src/code/early-format.lisp        |    4 ++--
 tests/compiler.test.sh            |    6 ++++++
 tests/seq.impure.lisp             |   27 ++++++++++++++++++++++++---
 version.lisp-expr                 |    2 +-
 5 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp
index 14614cc..26a0f49 100644
--- a/src/code/deftypes-for-target.lisp
+++ b/src/code/deftypes-for-target.lisp
@@ -60,7 +60,8 @@
 
 (sb!xc:deftype atom () '(not cons))
 
-(sb!xc:deftype base-char () 'character)
+(sb!xc:deftype base-char ()
+  '(character-set ((0 . #.(1- base-char-code-limit)))))
 
 (sb!xc:deftype extended-char ()
   #!+sb-doc
diff --git a/src/code/early-format.lisp b/src/code/early-format.lisp
index 06baecd..7dbc663 100644
--- a/src/code/early-format.lisp
+++ b/src/code/early-format.lisp
@@ -18,9 +18,9 @@
 	  #-sb-xc-host (code-char tab-char-code)))
 
 (defvar *format-directive-expanders*
-  (make-array char-code-limit :initial-element nil))
+  (make-array base-char-code-limit :initial-element nil))
 (defvar *format-directive-interpreters*
-  (make-array char-code-limit :initial-element nil))
+  (make-array base-char-code-limit :initial-element nil))
 
 (defvar *default-format-error-control-string* nil)
 (defvar *default-format-error-offset* nil)
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index de4512d..6e20f95 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -286,6 +286,12 @@ cat > $tmpfilename <<EOF
 EOF
 expect_failed_compile $tmpfilename
 
+# This should be clean
+cat > $tmpfilename <<EOF
+(defvar *string* (make-string 10 :element-type 'base-char))
+EOF
+expect_clean_compile $tmpfilename
+
 # This should style-warn (but not warn or otherwise fail) as the call
 # to FORMAT has too many arguments, which is bad style but not
 # otherwise fatal.
diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 7517a31..33f128a 100644
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -362,24 +362,45 @@
 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
 ;;; an absolute age trying to compile it.
 (defmacro sequence-bounding-indices-test (&body body)
-  `(locally
+  `(progn
+    (locally
     ;; See Issues 332 [and 333(!)] in the CLHS
     (declare (optimize (safety 3)))
     (let ((string (make-array 10
 			      :fill-pointer 5
 			      :initial-element #\a
 			      :element-type 'base-char)))
+	,(car body)
+	(format t "... BASE-CHAR")
+	(finish-output)
+	(flet ((reset ()
+		 (setf (fill-pointer string) 10)
+		 (fill string #\a)
+		 (setf (fill-pointer string) 5)))
+	  (declare (ignorable #'reset))
+	  ,@(cdr body))))
+    (locally
+      ;; See Issues 332 [and 333(!)] in the CLHS
+      (declare (optimize (safety 3)))
+      (let ((string (make-array 10
+				:fill-pointer 5
+				:initial-element #\a
+				:element-type 'character)))
+	,(car body)
+	(format t "... CHARACTER")
+	(finish-output)
       (flet ((reset ()
 	       (setf (fill-pointer string) 10)
 	       (fill string #\a)
 	       (setf (fill-pointer string) 5)))
 	(declare (ignorable #'reset))
-	,@body))))
+	  ,@(cdr body))))))
+
 (declaim (notinline opaque-identity))
 (defun opaque-identity (x) x)
 ;;; Accessor SUBSEQ
 (sequence-bounding-indices-test
- (format t "~&/Accessor SUBSEQ~%")
+ (format t "~&/Accessor SUBSEQ") 
  (assert (string= (subseq string 0 5) "aaaaa"))
  (assert (raises-error? (subseq string 0 6)))
  (assert (raises-error? (subseq string (opaque-identity -1) 5)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 1ffc130..0a35692 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.19"
+"0.8.16.20"
-- 
1.7.10.4