;;;; character support
;;; In our implementation there are really only BASE-CHARs.
+#+nil
(define-source-transform characterp (obj)
`(base-char-p ,obj))
\f
(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) *)
`(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))))))
(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))))
'((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)
(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))
+ (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
(mask (1- (ash 1 extra)))
(numx
(logand
(: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))
(truncate (truly-the index (1- length))
sb!vm:n-word-bits))))
((= index end-1)
- (let* ((extra (mod length sb!vm:n-word-bits))
+ (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
(mask (1- (ash 1 extra)))
(bits (logand (ash mask
,(ecase sb!c:*backend-byte-order*
(: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...
(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))
\f
;;;; 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)))
\f
;;;; word-wise logical operations