[Sbcl-commits] master: Fix CHAR-EQUAL on base-chars on non-sb-unicode.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  0c08cc954cc0910079bdcf153cccf9a95ef11d67 (commit)
      from  2fb9cd4a2286b82e065d6c673d91e46bd7f2194d (commit)

- Log -----------------------------------------------------------------
commit 0c08cc954cc0910079bdcf153cccf9a95ef11d67
Author: Stas Boukarev <sta...@gm...>
Date:   Mon Sep 9 19:43:58 2013 +0400

    Fix CHAR-EQUAL on base-chars on non-sb-unicode.
    
    BASE-CHAR-P, called by TWO-ARG-CHAR-EQUAL, isn't properly implemented
    on non-sb-unicode, the transform by which it gets transformed into
    (typep x 'base-char) is disabled, causing an infinite loop.
    Since testing for base-char-p is usually redundant on #-sb-unicode,
    don't define it there at all. This will catch inadvertent uses.
    In the few places where it's currently used, it's can be safely
    omitted.
    
    Reported by Jan Moringen.
---
 src/code/pred.lisp                |    5 ++++-
 src/code/target-char.lisp         |   34 ++++++++++++++++++++--------------
 src/compiler/generic/vm-fndb.lisp |    3 ++-
 src/compiler/generic/vm-tran.lisp |    7 -------
 src/compiler/x86-64/insts.lisp    |    2 +-
 src/compiler/x86/insts.lisp       |    2 +-
 6 files changed, 28 insertions(+), 25 deletions(-)

diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 4a6703a..f2e2e6b 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -85,7 +85,10 @@
   (def-type-predicate-wrapper array-header-p)
   (def-type-predicate-wrapper arrayp)
   (def-type-predicate-wrapper atom)
-  (def-type-predicate-wrapper base-char-p)
+  ;; Testing for BASE-CHAR-P is usually redundant on #-sb-unicode,
+  ;; remove it there completely so that #-sb-unicode build will
+  ;; break when it's used.
+  #!+sb-unicode (def-type-predicate-wrapper base-char-p)
   (def-type-predicate-wrapper base-string-p)
   #!+sb-unicode (def-type-predicate-wrapper character-string-p)
   (def-type-predicate-wrapper bignump)
diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp
index 265a09f..7cef881 100644
--- a/src/code/target-char.lisp
+++ b/src/code/target-char.lisp
@@ -518,20 +518,26 @@ is either numeric or alphabetic."
           (char-code ,ch)))))
 
 (defun two-arg-char-equal (c1 c2)
-  (or (eq c1 c2)
-      (typecase c1
-        (base-char
-         (and (base-char-p c2)
-              (let* ((code1 (char-code c1))
-                     (code2 (char-code c2))
-                     (sum (logxor code1 code2)))
-                (when (eql sum #x20)
-                  (let ((sum (+ code1 code2)))
-                    (or (and (> sum 161) (< sum 213))
-                        (and (> sum 415) (< sum 461))
-                        (and (> sum 463) (< sum 477))))))))
-        (t
-         (= (equal-char-code c1) (equal-char-code c2))))))
+  (flet ((base-char-equal-p ()
+           (let* ((code1 (char-code c1))
+                  (code2 (char-code c2))
+                  (sum (logxor code1 code2)))
+             (when (eql sum #x20)
+               (let ((sum (+ code1 code2)))
+                 (or (and (> sum 161) (< sum 213))
+                     (and (> sum 415) (< sum 461))
+                     (and (> sum 463) (< sum 477))))))))
+    (declare (inline base-char-equal-p))
+    (or (eq c1 c2)
+        #!-sb-unicode
+        (base-char-equal-p)
+        #!+sb-unicode
+        (typecase c1
+          (base-char
+           (and (base-char-p c2)
+                (base-char-equal-p)))
+          (t
+           (= (equal-char-code c1) (equal-char-code c2)))))))
 
 (defun char-equal-constant (x char reverse-case-char)
   (declare (type character x))
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 8e7092b..67a135a 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -20,7 +20,8 @@
            complex-rational-p complex-float-p complex-single-float-p
            complex-double-float-p #!+long-float complex-long-float-p
            complex-vector-p
-           base-char-p %standard-char-p %instancep
+           #!+sb-unicode base-char-p
+           %standard-char-p %instancep
            base-string-p simple-base-string-p
            #!+sb-unicode character-string-p
            #!+sb-unicode simple-character-string-p
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 256ead3..f390c6f 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -87,13 +87,6 @@
 (define-source-transform %set-funcallable-instance-layout (x val)
   `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
 
-;;;; character support
-
-;;; In our implementation there are really only BASE-CHARs.
-#+nil
-(define-source-transform characterp (obj)
-  `(base-char-p ,obj))
-
 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
 
 (deftransform hairy-data-vector-ref ((string index) (simple-string t))
diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 554cb52..6edbb0e 100644
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -3773,7 +3773,7 @@
          (aver (integerp value))
          (cons type value))
       ((:base-char)
-         (aver (base-char-p value))
+         #!+sb-unicode (aver (base-char-p value))
          (cons :byte (char-code value)))
       ((:character)
          (aver (characterp value))
diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp
index 431a728..b79d091 100644
--- a/src/compiler/x86/insts.lisp
+++ b/src/compiler/x86/insts.lisp
@@ -2876,7 +2876,7 @@
          (aver (integerp value))
          (cons type value))
       ((:base-char)
-         (aver (base-char-p value))
+         #!+sb-unicode (aver (base-char-p value))
          (cons :byte (char-code value)))
       ((:character)
          (aver (characterp value))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL