0.8.16.26:

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 8f1739f..9c832e3 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2321,7 +2321,29 @@
         (specifier-type `(integer ,lo-res ,hi-res))))))
 
 (defoptimizer (code-char derive-type) ((code))
-  (specifier-type 'base-char))
+  (let ((type (lvar-type code)))
+    ;; FIXME: unions of integral ranges?  It ought to be easier to do
+    ;; this, given that CHARACTER-SET is basically an integral range
+    ;; type.  -- CSR, 2004-10-04
+    (when (numeric-type-p type)
+      (let* ((lo (numeric-type-low type))
+             (hi (numeric-type-high type))
+             (type (specifier-type `(character-set ((,lo . ,hi))))))
+        (cond
+          ;; KLUDGE: when running on the host, we lose a slight amount
+          ;; of precision so that we don't have to "unparse" types
+          ;; that formally we can't, such as (CHARACTER-SET ((0
+          ;; . 0))).  -- CSR, 2004-10-06
+          #+sb-xc-host
+          ((csubtypep type (specifier-type 'standard-char)) type)
+          #+sb-xc-host
+          ((csubtypep type (specifier-type 'base-char))
+           (specifier-type 'base-char))
+          #+sb-xc-host
+          ((csubtypep type (specifier-type 'extended-char))
+           (specifier-type 'extended-char))
+          (t #+sb-xc-host (specifier-type 'character)
+             #-sb-xc-host type))))))
 
 (defoptimizer (values derive-type) ((&rest values))
   (make-values-type :required (mapcar #'lvar-type values)))
@@ -2925,21 +2947,31 @@
      (or (zerop sum)
         (when (eql sum #x20)
           (let ((sum (+ ac bc)))
-            (and (> sum 161) (< sum 213)))))))
+             (or (and (> sum 161) (< sum 213))
+                 (and (> sum 415) (< sum 461))
+                 (and (> sum 463) (< sum 477))))))))
 
 (deftransform char-upcase ((x) (base-char))
   "open code"
   '(let ((n-code (char-code x)))
-     (if (and (> n-code #o140) ; Octal 141 is #\a.
-             (< n-code #o173)) ; Octal 172 is #\z.
+     (if (or (and (> n-code #o140)     ; Octal 141 is #\a.
+                  (< n-code #o173))    ; Octal 172 is #\z.
+             (and (> n-code #o337)
+                  (< n-code #o367))
+             (and (> n-code #o367)
+                  (< n-code #o377)))
         (code-char (logxor #x20 n-code))
         x)))
 
 (deftransform char-downcase ((x) (base-char))
   "open code"
   '(let ((n-code (char-code x)))
-     (if (and (> n-code 64)    ; 65 is #\A.
-             (< n-code 91))    ; 90 is #\Z.
+     (if (or (and (> n-code 64)                ; 65 is #\A.
+                  (< n-code 91))        ; 90 is #\Z.
+             (and (> n-code 191)
+                  (< n-code 215))
+             (and (> n-code 215)
+                  (< n-code 223)))
         (code-char (logxor #x20 n-code))
         x)))
 \f
@@ -2962,21 +2994,18 @@
 ;;; then the result is definitely false.
 (deftransform simple-equality-transform ((x y) * *
                                         :defun-only t)
-  (cond ((same-leaf-ref-p x y)
-        t)
-       ((not (types-equal-or-intersect (lvar-type x)
-                                       (lvar-type y)))
+  (cond
+    ((same-leaf-ref-p x y) t)
+    ((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
         nil)
-       (t
-        (give-up-ir1-transform))))
+    (t (give-up-ir1-transform))))
 
 (macrolet ((def (x)
              `(%deftransform ',x '(function * *) #'simple-equality-transform)))
   (def eq)
-  (def char=)
-  (def equal))
+  (def char=))
 
-;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
+;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
 ;;; -- If both args are characters, convert to CHAR=. This is better than
 ;;;    just converting to EQ, since CHAR= may have special compilation
@@ -2995,8 +3024,8 @@
        (y-type (lvar-type y))
        (char-type (specifier-type 'character))
        (number-type (specifier-type 'number)))
-    (cond ((same-leaf-ref-p x y)
-          t)
+    (cond
+      ((same-leaf-ref-p x y) t)
          ((not (types-equal-or-intersect x-type y-type))
           nil)
          ((and (csubtypep x-type char-type)
@@ -3013,6 +3042,25 @@
          (t
           (give-up-ir1-transform)))))
 
+;;; similarly to the EQL transform above, we attempt to constant-fold
+;;; or convert to a simpler predicate: mostly we have to be careful
+;;; with strings.
+(deftransform equal ((x y) * *)
+  "convert to simpler equality predicate"
+  (let ((x-type (lvar-type x))
+       (y-type (lvar-type y))
+       (string-type (specifier-type 'string)))
+    (cond
+      ((same-leaf-ref-p x y) t)
+      ((and (csubtypep x-type string-type)
+           (csubtypep y-type string-type))
+       '(string= x y))
+      ((and (or (not (types-equal-or-intersect x-type string-type))
+               (not (types-equal-or-intersect y-type string-type)))
+           (not (types-equal-or-intersect x-type y-type)))
+       nil)
+      (t (give-up-ir1-transform)))))
+
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.
 (deftransform = ((x y) * *)