0.8.16.25:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 9108f22..e47aec5 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -36,6 +36,7 @@
 ;;;; character support
 
 ;;; In our implementation there are really only BASE-CHARs.
+#+nil
 (define-source-transform characterp (obj)
   `(base-char-p ,obj))
 \f
@@ -48,6 +49,8 @@
        (give-up-ir1-transform)
        `(etypecase string
          ((simple-array character (*)) (data-vector-ref string index))
+          #!+sb-unicode
+         ((simple-array base-char (*)) (data-vector-ref string index))
          ((simple-array nil (*)) (data-vector-ref string index))))))
 
 (deftransform hairy-data-vector-ref ((array index) (array t) *)
@@ -98,6 +101,9 @@
        `(etypecase string
          ((simple-array character (*))
           (data-vector-set string index new-value))
+          #!+sb-unicode
+         ((simple-array base-char (*))
+          (data-vector-set string index new-value))
          ((simple-array nil (*))
           (data-vector-set string index new-value))))))
 
@@ -228,7 +234,7 @@
                                          (length bit-array-2)
                                           (length result-bit-array))
                                  (error "Argument and/or result bit arrays are not the same length:~
-                        ~%  ~S~%  ~S  ~%  ~S"
+                         ~%  ~S~%  ~S  ~%  ~S"
                                         bit-array-1
                                        bit-array-2
                                        result-bit-array))))
@@ -278,7 +284,7 @@
         '((unless (= (length bit-array)
                      (length result-bit-array))
             (error "Argument and result bit arrays are not the same length:~
-                    ~%  ~S~%  ~S"
+                     ~%  ~S~%  ~S"
                    bit-array result-bit-array))))
     (let ((length (length result-bit-array)))
       (if (= length 0)
@@ -359,7 +365,7 @@
                                               (:big-endian
                                                '(- sb!vm:n-word-bits extra))))
                                  (%raw-bits sequence index))))
-               (declare (type (mod #.sb!vm:n-word-bits)) extra)
+               (declare (type (mod #.sb!vm:n-word-bits) extra))
                (declare (type sb!vm:word mask bits))
                ;; could consider LOGNOT for the zero case instead of
                ;; doing the subtraction...
@@ -414,7 +420,7 @@
                      (dotimes (i sb!vm:n-word-bytes accum)
                        (setf accum (logior accum (ash code (* 8 i))))))
                   `(let ((code (sb!xc:char-code item)))
-                     (logior ,@(loop for i from 0 upto sb!vm:n-word-bytes
+                     (logior ,@(loop for i from 0 below sb!vm:n-word-bytes
                                      collect `(ash code ,(* 8 i))))))))
     `(let ((length (length sequence))
           (value ,value))
@@ -490,17 +496,23 @@
     ((def (name width)
         `(progn
            (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
-                     (foldable flushable movable))
+                     (foldable flushable movable))        
            (define-modular-fun-optimizer ash ((integer count) :width width)
              (when (and (<= width ,width)
-                        (constant-lvar-p count) ;?
-                        (plusp (lvar-value count)))
+                        (or (and (constant-lvar-p count)
+                                 (plusp (lvar-value count)))
+                            (csubtypep (lvar-type count)
+                                       (specifier-type '(and unsigned-byte
+                                                         fixnum)))))
                (cut-to-width integer width)
                ',name))
            (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
-  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+  ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
+  ;; don't have a true Alpha64 port yet, we'll have to stick to
+  ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
+  #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
   (def sb!vm::ash-left-mod32 32)
-  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
   (def sb!vm::ash-left-mod64 64))
 
 \f