** (also, while working on INLINE anyway, it might be easy
to flush the old MAYBE-INLINE cruft entirely,
including e.g. on the man page)
+* test file reworking
+ ** non-x86 ports now pass irrat.pure.lisp
+ ** sparc and ppc now pass bit-vector.impure-cload.lisp
* faster bootstrapping (both make.sh and slam.sh)
** added mechanisms for automatically finding dead code, and
used them to remove dead code
"UNSUPPORTED-OPERATOR"
;; ..and DEFTYPEs..
- "INDEX"
-
+ "INDEX" "LOAD/STORE-INDEX"
+ "UNSIGNED-BYTE-WITH-A-BITE-OUT"
;; ..and type predicates
"INSTANCEP"
"DOUBLE-FLOATP"
(defun hairy-data-vector-ref (array index)
(with-array-data ((vector array) (index index) (end))
- (declare (ignore end) (optimize (safety 3)))
+ (declare (ignore end))
(etypecase vector .
#.(mapcar (lambda (type)
(let ((atype `(simple-array ,type (*))))
(defun hairy-data-vector-set (array index new-value)
(with-array-data ((vector array) (index index) (end))
- (declare (ignore end) (optimize (safety 3)))
+ (declare (ignore end) (optimize))
(etypecase vector .
#.(mapcar (lambda (type)
(let ((atype `(simple-array ,type (*))))
;;; index leaving the loop range)
(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
+;;; A couple of VM-related types that are currently used only on the
+;;; alpha platform. -- CSR, 2002-06-24
+(def!type unsigned-byte-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 1))
+ (let ((bound (ash 1 s)))
+ `(integer 0 ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(def!type load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 16)
+ (* min-offset sb!vm:n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset sb!vm:n-word-bytes))
+ scale)))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary, so we use the value that falls
;;; through when we just let the low-level consing code initialize
(:temporary (:scs (non-descriptor-reg)) temp)
(:policy :fast-safe))
-(deftype integer-with-a-bite-out (s bite)
- (cond ((eq s '*) 'integer)
- ((and (integerp s) (> s 1))
- (let ((bound (ash 1 s)))
- `(integer 0 ,(- bound bite 1))))
- (t
- (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
-
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg))
(y :scs (any-reg)))
(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
(:args (x :scs (any-reg)))
- (:arg-types tagged-num (:constant (integer-with-a-bite-out 6 4)))
+ (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 6 4)))
(:info target not-p y))
(define-vop (fast-conditional/signed fast-conditional)
(define-vop (fast-conditional-c/signed fast-conditional/signed)
(:args (x :scs (signed-reg)))
- (:arg-types signed-num (:constant (integer-with-a-bite-out 8 1)))
+ (:arg-types signed-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
(:info target not-p y))
(define-vop (fast-conditional/unsigned fast-conditional)
(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
(:args (x :scs (unsigned-reg)))
- (:arg-types unsigned-num (:constant (integer-with-a-bite-out 8 1)))
+ (:arg-types unsigned-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
(:info target not-p y))
\f
;;;; memory accessor vop generators
-(deftype load/store-index (scale lowtag min-offset
- &optional (max-offset min-offset))
- `(integer ,(- (truncate (+ (ash 1 16)
- (* min-offset n-word-bytes)
- (- lowtag))
- scale))
- ,(truncate (- (+ (1- (ash 1 16)) lowtag)
- (* max-offset n-word-bytes))
- scale)))
-
(defmacro define-full-reffer (name type offset lowtag scs el-type
&optional translate)
`(progn
(dolist (sb *backend-sb-list*)
(unless (eq (sb-kind sb) :non-packed)
(let ((size (sb-size sb)))
- (fill nil (finite-sb-always-live sb))
+ (fill (finite-sb-always-live sb) nil)
(setf (finite-sb-always-live sb)
(make-array size
:initial-element
;; until runtime.
#+sb-xc (make-array 0 :element-type 'bit)))
- (fill nil (finite-sb-conflicts sb))
+ (fill (finite-sb-conflicts sb) nil)
(setf (finite-sb-conflicts sb)
(make-array size :initial-element '#()))
- (fill nil (finite-sb-live-tns sb))
+ (fill (finite-sb-live-tns sb) nil)
(setf (finite-sb-live-tns sb)
(make-array size :initial-element nil))))))
(values))
(:affected)
(:policy :fast-safe))
-(deftype integer-with-a-bite-out (s bite)
- (cond ((eq s '*) 'integer)
- ((and (integerp s) (> s 1))
- (let ((bound (ash 1 (1- s))))
- `(integer ,(- bound) ,(- bound bite 1))))
- (t
- (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
-
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg zero))
(y :scs (any-reg zero)))
(:affected)
(:policy :fast-safe))
-(deftype integer-with-a-bite-out (s bite)
- (cond ((eq s '*) 'integer)
- ((and (integerp s) (> s 1))
- (let ((bound (ash 1 (1- s))))
- `(integer ,(- bound) ,(- bound bite 1))))
- (t
- (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
-
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg zero))
(y :scs (any-reg zero)))
(let ((testcases '(;; Bug 126, confusion between high-level default string
;; initial element #\SPACE and low-level default array
;; element #\NULL, is gone.
- (#\null (make-array 11 :element-type 'character))
- (#\space (make-string 11 :initial-element #\space))
+ (#\null (make-array 11 :element-type 'character) simple-string)
+ (#\space (make-string 11 :initial-element #\space) string)
(#\* (make-string 11 :initial-element #\*))
(#\null (make-string 11))
(#\null (make-string 11 :initial-element #\null))
(#\x (make-string 11 :initial-element #\x))
;; And the other tweaks made when fixing bug 126 didn't
;; mess things up too badly either.
- (0 (make-array 11))
+ (0 (make-array 11) simple-vector)
(nil (make-array 11 :initial-element nil))
(12 (make-array 11 :initial-element 12))
- (0 (make-array 11 :element-type '(unsigned-byte 4)))
+ (0 (make-array 11 :element-type '(unsigned-byte 4)) (simple-array (unsigned-byte 4) (*)))
(12 (make-array 11
:element-type '(unsigned-byte 4)
:initial-element 12)))))
(dolist (testcase testcases)
- (destructuring-bind (expected-result form) testcase
+ (destructuring-bind (expected-result form &optional type) testcase
(unless (eql expected-result (aref (eval form) 3))
(error "expected ~S in EVAL ~S" expected-result form))
(unless (eql expected-result
(aref (funcall (compile nil `(lambda () ,form))) 3))
- (error "expected ~S in FUNCALL COMPILE ~S" expected-result form)))))
+ (error "expected ~S in FUNCALL COMPILE ~S" expected-result form))
+ ;; also do some testing of compilation and verification that
+ ;; errors are thrown appropriately.
+ (unless (eql expected-result
+ (funcall (compile nil `(lambda () (aref ,form 3)))))
+ (error "expected ~S in COMPILED-AREF ~S" expected-result form))
+ (when type
+ (unless (eql expected-result
+ (funcall (compile nil `(lambda () (let ((x ,form))
+ (declare (type ,type x))
+ (aref x 3))))))
+ (error "expected ~S in COMPILED-DECLARED-AREF ~S" expected-result form)))
+ (when (ignore-errors (aref (eval form) 12))
+ (error "error not thrown in EVAL ~S" form))
+ (when (ignore-errors (aref (funcall (compile nil `(lambda () ,form))) 12))
+ (error "error not thrown in FUNCALL COMPILE ~S"))
+ (when (ignore-errors (funcall (compile nil `(lambda () (aref ,form 12)))))
+ (error "error not thrown in COMPILED-AREF ~S" form))
+ (when type
+ (when (ignore-errors (funcall
+ (compile nil `(lambda () (let ((x ,form))
+ (declare (type ,type x))
+ (aref x 12))))))
+ (error "error not thrown in COMPILED-DECLARED-AREF ~S" form))))))
+
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.5"
+"0.7.5.1"
projects / sbcl.git / commitdiff