sbcl casify diff

sbcl-casify.diff

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 92fbb3e76..be4e0037d 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -568,8 +568,8 @@ variable: an unreadable object representing the error is printed instead.")
                        code (char-code current)
                        bits (cond ; FIXME
                               ((< code 160) (aref attributes code))
-                              ((upper-case-p current) uppercase-attribute)
-                              ((lower-case-p current) lowercase-attribute)
+                              ((and (typep current 'standard-char) (upper-case-p current)) uppercase-attribute)
+                              ((and (typep current 'standard-char) (lower-case-p current)) lowercase-attribute)
                               (t other-attribute)))
                  (incf index)
                  (go ,tag)))
@@ -617,8 +617,8 @@ variable: an unreadable object representing the error is printed instead.")
                                         (code (char-code char)))
                                    (cond
                                      ((< code 160) (aref attributes code))
-                                     ((upper-case-p char) uppercase-attribute)
-                                     ((lower-case-p char) lowercase-attribute)
+                                     ((and (typep char 'standard-char) (upper-case-p char)) uppercase-attribute)
+                                     ((and (typep char 'standard-char) (lower-case-p char)) lowercase-attribute)
                                      (t other-attribute)))
                                  mask))
             (return-from symbol-quotep t))))
@@ -735,7 +735,8 @@ variable: an unreadable object representing the error is printed instead.")
   (declare (simple-string pname) (ignore readtable))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
-      (write-char (char-downcase char) stream))))
+      (write-char (if (typep char 'standard-char) (char-downcase char) char)
+                  stream))))
 
 ;;; called when:
 ;;; READTABLE-CASE      *PRINT-CASE*
@@ -744,7 +745,7 @@ variable: an unreadable object representing the error is printed instead.")
   (declare (simple-string pname) (ignore readtable))
   (dotimes (index (length pname))
     (let ((char (schar pname index)))
-      (write-char (char-upcase char) stream))))
+      (write-char (if (typep char 'standard-char) (char-upcase char) char) stream))))
 
 ;;; called when:
 ;;; READTABLE-CASE      *PRINT-CASE*
diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index cf3ec8225..f81019bde 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -1171,7 +1171,9 @@ standard Lisp readtable when NIL."
       (let ((buffer (token-buf-string token-buf)))
         (dotimes (i (token-buf-fill-ptr token-buf))
           (declare (optimize (sb-c::insert-array-bounds-checks 0)))
-          (setf (schar buffer i) (char-upcase (schar buffer i))))))
+          (let ((ch (schar buffer i)))
+            (when (casify? ch)
+              (setf (schar buffer i) (char-upcase (schar buffer i))))))))
      ((eq case :preserve))
      (t
       (macrolet ((skip-esc (&body body)
@@ -1184,7 +1186,8 @@ standard Lisp readtable when NIL."
                                (optimize (sb-c::insert-array-bounds-checks 0)))
                       (if (< esc i)
                           (let ((ch (schar buffer i)))
-                            ,@body)
+                            (when (casify? ch)
+                              ,@body))
                           (progn
                             (aver (= esc i))
                             (setq esc (if (zerop (fill-pointer escapes))
@@ -1209,6 +1212,11 @@ standard Lisp readtable when NIL."
                (cond (all-lower (raise-em))
                      (all-upper (lower-em))))))))))))
 
+(defun casify? (ch)
+  "Return true if CH is eligible for case conversion."
+  ;; Broad kludge to inhibit unwanted case-conversion of greek letters.
+  (typep ch 'standard-char))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *reader-package* nil))
 (declaim (type (or null package) *reader-package*)