X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=36d42277fffa7267b76b25badfa555be48cd2f8c;hb=d1858723258b286448f0c1584c096e6ea82451d6;hp=5a1fa680e384743c16298815f5e644c48f533346;hpb=d28663900d0b597a34a73f42589b802d9336f6d8;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 5a1fa68..36d4227 100644
--- 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))
 
@@ -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)
@@ -311,8 +317,9 @@
 		    (end-1 (+ sb!vm:vector-data-offset
 			      (floor (1- length) sb!vm:n-word-bits))))
 		   ((= i end-1)
-		    (let* ((extra (mod length sb!vm:n-word-bits))
-			   (mask (1- (ash 1 extra)))
+		    (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+			   (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+				      (- extra sb!vm:n-word-bits)))
 			   (numx
 			    (logand
 			     (ash mask
@@ -329,8 +336,7 @@
 				     (:big-endian
 				      '(- sb!vm:n-word-bits extra))))
 			     (%raw-bits y i))))
-		      (declare (type (mod #.sb!vm:n-word-bits)
-                                     extra)
+		      (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
 			       (type sb!vm:word mask numx numy))
 		      (= numx numy)))
 		(declare (type index i end-1))
@@ -351,15 +357,16 @@
                        (truncate (truly-the index (1- length))
                                  sb!vm:n-word-bits))))
             ((= index end-1)
-             (let* ((extra (mod length sb!vm:n-word-bits))
-		    (mask (1- (ash 1 extra)))
+             (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+		    (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+			       (- extra sb!vm:n-word-bits)))
 		    (bits (logand (ash mask
 				       ,(ecase sb!c:*backend-byte-order*
 					       (:little-endian 0)
 					       (:big-endian
 						'(- sb!vm:n-word-bits extra))))
 				  (%raw-bits sequence index))))
-               (declare (type (mod #.sb!vm:n-word-bits) extra))
+               (declare (type (integer 1 #.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...
@@ -482,26 +489,39 @@
 
 
 ;;;; modular functions
-(define-good-modular-fun logand)
-(define-good-modular-fun logior)
+(define-good-modular-fun logand :unsigned)
+(define-good-modular-fun logior :unsigned)
 ;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
 
 (macrolet
-    ((def (name width)
+    ((def (name class width)
+       (let ((type (ecase class
+                     (:unsigned 'unsigned-byte)
+                     (:signed 'signed-byte))))
 	 `(progn
-	    (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
+	    (defknown ,name (integer (integer 0)) (,type ,width)
 		      (foldable flushable movable))
-	    (define-modular-fun-optimizer ash ((integer count) :width width)
+	    (define-modular-fun-optimizer ash ((integer count) ,class :width width)
 	      (when (and (<= width ,width)
-			 (constant-lvar-p count) ;?
-			 (plusp (lvar-value count)))
-		(cut-to-width integer width)
+			 (or (and (constant-lvar-p count)
+				  (plusp (lvar-value count)))
+			     (csubtypep (lvar-type count)
+					(specifier-type '(and unsigned-byte fixnum)))))
+		(cut-to-width integer ,class width)
 		',name))
-	    (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
-  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-  (def sb!vm::ash-left-mod32 32)
-  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-  (def sb!vm::ash-left-mod64 64))
+            (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+                  `(ash ,',width))))))
+  ;; 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))
+  (progn
+    #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
+    (def sb!vm::ash-left-mod32 :unsigned 32))
+  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
+  (progn
+    #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61)
+    (def sb!vm::ash-left-mod64 :unsigned 64)))
 
 
 ;;;; word-wise logical operations