X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=057df860ef44939d9a3fbc87d47f9fcd1667c483;hb=0b96758f3645dff3e681d82cc97ddab1faae27ac;hp=cff78d0eeab33fdad22eab92e1b0db88aea3118a;hpb=5c0190fbca4852096b30b4ed53394e762b9e6cd4;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index cff78d0..057df86 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -75,26 +75,26 @@
   #!+sb-doc
   "Bind the reader and printer control variables to values that enable READ
    to reliably read the results of PRINT. These values are:
-       *PACKAGE*			the COMMON-LISP-USER package
-       *PRINT-ARRAY*			T
-       *PRINT-BASE*			10
-       *PRINT-CASE*			:UPCASE
-       *PRINT-CIRCLE*			NIL
-       *PRINT-ESCAPE*			T
-       *PRINT-GENSYM*			T
-       *PRINT-LENGTH*			NIL
-       *PRINT-LEVEL*			NIL
-       *PRINT-LINES*			NIL
-       *PRINT-MISER-WIDTH*		NIL
-       *PRINT-PRETTY*			NIL
-       *PRINT-RADIX*			NIL
-       *PRINT-READABLY*			T
-       *PRINT-RIGHT-MARGIN*		NIL
-       *READ-BASE*			10
-       *READ-DEFAULT-FLOAT-FORMAT* 	SINGLE-FLOAT
-       *READ-EVAL*			T
-       *READ-SUPPRESS*			NIL
-       *READTABLE*			the standard readtable"
+       *PACKAGE*                        the COMMON-LISP-USER package
+       *PRINT-ARRAY*                    T
+       *PRINT-BASE*                     10
+       *PRINT-CASE*                     :UPCASE
+       *PRINT-CIRCLE*                   NIL
+       *PRINT-ESCAPE*                   T
+       *PRINT-GENSYM*                   T
+       *PRINT-LENGTH*                   NIL
+       *PRINT-LEVEL*                    NIL
+       *PRINT-LINES*                    NIL
+       *PRINT-MISER-WIDTH*              NIL
+       *PRINT-PRETTY*                   NIL
+       *PRINT-RADIX*                    NIL
+       *PRINT-READABLY*                 T
+       *PRINT-RIGHT-MARGIN*             NIL
+       *READ-BASE*                      10
+       *READ-DEFAULT-FLOAT-FORMAT*      SINGLE-FLOAT
+       *READ-EVAL*                      T
+       *READ-SUPPRESS*                  NIL
+       *READTABLE*                      the standard readtable"
   `(%with-standard-io-syntax (lambda () ,@body)))
 
 (defun %with-standard-io-syntax (function)
@@ -360,7 +360,7 @@
      ;; Someone forgot to initiate circularity detection.
      (let ((*print-circle* nil))
        (error "trying to use CHECK-FOR-CIRCULARITY when ~
-	       circularity checking isn't initiated")))
+               circularity checking isn't initiated")))
     ((t)
      ;; It's a second (or later) reference to the object while we are
      ;; just looking. So don't bother groveling it again.
@@ -615,10 +615,10 @@
 ;;; character has. At characters have at least one bit set, so we can
 ;;; search for any character with a positive test.
 (defvar *character-attributes*
-  (make-array char-code-limit
+  (make-array 160 ; FIXME
 	      :element-type '(unsigned-byte 16)
 	      :initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
 	       *character-attributes*))
 
 ;;; constants which are a bit-mask for each interesting character attribute
@@ -672,17 +672,17 @@
   (set-bit #\/ slash-attribute)
 
   ;; Mark anything not explicitly allowed as funny.
-  (dotimes (i char-code-limit)
+  (dotimes (i 160) ; FIXME
     (when (zerop (aref *character-attributes* i))
       (setf (aref *character-attributes* i) funny-attribute))))
 
 ;;; For each character, the value of the corresponding element is the
 ;;; lowest base in which that character is a digit.
 (defvar *digit-bases*
-  (make-array char-code-limit
+  (make-array 128 ; FIXME
 	      :element-type '(unsigned-byte 8)
 	      :initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
 	       *digit-bases*))
 (dotimes (i 36)
   (let ((char (digit-char i 36)))
@@ -698,7 +698,11 @@
 		   ,(if at-end '(go TEST-SIGN) '(return nil)))
 		 (setq current (schar name index)
 		       code (char-code current)
-		       bits (aref attributes code))
+		       bits (cond ; FIXME
+                              ((< code 160) (aref attributes code))
+                              ((upper-case-p current) uppercase-attribute)
+                              ((lower-case-p current) lowercase-attribute)
+                              (t other-attribute)))
 		 (incf index)
 		 (go ,tag)))
 	     (test (&rest attributes)
@@ -713,7 +717,8 @@
 					attributes))
 			     bits)))))
 	     (digitp ()
-	       `(< (the fixnum (aref bases code)) base)))
+               `(and (< code 128) ; FIXME
+                     (< (the fixnum (aref bases code)) base))))
 
     (prog ((len (length name))
 	   (attributes *character-attributes*)
@@ -740,7 +745,13 @@
 			  letter-attribute)))
 	(do ((i (1- index) (1+ i)))
 	    ((= i len) (return-from symbol-quotep nil))
-	  (unless (zerop (logand (aref attributes (char-code (schar name i)))
+	  (unless (zerop (logand (let* ((char (schar name i))
+					(code (char-code char)))
+				   (cond 
+				     ((< code 160) (aref attributes code))
+				     ((upper-case-p char) uppercase-attribute)
+				     ((lower-case-p char) lowercase-attribute)
+				     (t other-attribute)))
 				 mask))
 	    (return-from symbol-quotep t))))