(TYPEP 1 '(SYMBOL NIL)) says something about "unknown type
specifier".
-249:
- Local functions do not check types of unused arguments:
- (defun foo (x)
- (flet ((bar (y)
- (declare (fixnum y))
- (incf x)))
- (list (bar x) (bar x) (bar x))))
- (foo 1.0) => (2.0 3.0 4.0)
-
250:
(make-array nil :initial-element 11) causes a warning.
(make-long-float (logior (ash sign 15) exp)
(ldb (byte 32 32) sig)
(ldb (byte 32 0) sig)))
-
+
) ; EVAL-WHEN
\f
;;;; float parameters
(defun float-sign (float1 &optional (float2 (float 1 float1)))
#!+sb-doc
"Return a floating-point number that has the same sign as
- float1 and, if float2 is given, has the same absolute value
- as float2."
+ FLOAT1 and, if FLOAT2 is given, has the same absolute value
+ as FLOAT2."
(declare (float float1 float2))
(* (if (etypecase float1
(single-float (minusp (single-float-bits float1)))
#!+long-float
((long-float) sb!vm:long-float-digits)))
-(setf (fdefinition 'float-radix)
- ;; FIXME: Python flushes unused variable X in CLAMBDA, then
- ;; flushes unused reference to X in XEP together with type
- ;; check. When this is fixed, rewrite this definition in an
- ;; ordinary form. -- APD, 2002-10-21
- (lambda (x)
- #!+sb-doc
- "Return (as an integer) the radix b of its floating-point argument."
- (unless (floatp x)
- (error 'type-error :datum x :expected-type 'float))
- 2))
+(defun float-radix (x)
+ #!+sb-doc
+ "Return (as an integer) the radix b of its floating-point argument."
+ 2)
\f
;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
array
(make-array-type :complexp t
:element-type *wild-type*)
- (lexenv-policy (node-lexenv (continuation-dest array)))))
+ (lexenv-policy (node-lexenv (continuation-dest array))))
+ nil)
;;; Return true if ARG is NIL, or is a constant-continuation whose
;;; value is NIL, false otherwise.
;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
;;; error for CONT's value not to be TYPEP to TYPE. We implement it
-;;; moving uses behind a new CAST node. If we improve the assertion,
+;;; splitting off DEST a new CAST node. If we improve the assertion,
;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
-;;; assertion will be checked.
+;;; assertion will be checked. We return the new "argument"
+;;; continuation of DEST.
(defun assert-continuation-type (cont type policy)
(declare (type continuation cont) (type ctype type))
- (when (values-subtypep (continuation-derived-type cont) type)
- (return-from assert-continuation-type))
- (let* ((dest (continuation-dest cont))
- (prev-cont (node-prev dest)))
- (aver dest)
- (with-ir1-environment-from-node dest
- (let* ((cast (make-cast cont type policy))
- (checked-value (make-continuation)))
- (setf (continuation-next prev-cont) cast
- (node-prev cast) prev-cont)
- (use-continuation cast checked-value)
- (link-node-to-previous-continuation dest checked-value)
- (substitute-continuation checked-value cont)
- (setf (continuation-dest cont) cast)
- (reoptimize-continuation cont)))))
+ (if (values-subtypep (continuation-derived-type cont) type)
+ cont
+ (let* ((dest (continuation-dest cont))
+ (prev-cont (node-prev dest)))
+ (aver dest)
+ (with-ir1-environment-from-node dest
+ (let* ((cast (make-cast cont type policy))
+ (checked-value (make-continuation)))
+ (setf (continuation-next prev-cont) cast
+ (node-prev cast) prev-cont)
+ (use-continuation cast checked-value)
+ (link-node-to-previous-continuation dest checked-value)
+ (substitute-continuation checked-value cont)
+ (setf (continuation-dest cont) cast)
+ (reoptimize-continuation cont)
+ checked-value)))))
;;; Assert that CALL is to a function of the specified TYPE. It is
;;; assumed that the call is legal and has only constants in the
;;; continuations.
(defun propagate-to-args (call fun)
(declare (type combination call) (type clambda fun))
- (do ((args (basic-combination-args call) (cdr args))
- (vars (lambda-vars fun) (cdr vars)))
- ((null args))
- (let ((arg (car args))
- (var (car vars)))
- (cond ((leaf-refs var)
- (assert-continuation-type arg (leaf-type var)
- (lexenv-policy (node-lexenv call))))
- (t
- (flush-dest arg)
- (setf (car args) nil)))))
+ (loop with policy = (lexenv-policy (node-lexenv call))
+ for args on (basic-combination-args call)
+ and var in (lambda-vars fun)
+ for arg = (assert-continuation-type (car args)
+ (leaf-type var) policy)
+ do (unless (leaf-refs var)
+ (flush-dest (car args))
+ (setf (car args) nil)))
(values))
\f
;;;; other integer ranges
+(define-vop (fixnump/unsigned-byte-32 simple-type-predicate)
+ (:args (value :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:translate fixnump)
+ (:generator 5
+ (inst cmp value #.sb!xc:most-positive-fixnum)
+ (inst jmp (if not-p :a :be) target)))
+
;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
;;; exactly one digit.
(assert (eq l nil))
(assert (eq (sswo-a s) :v)))
+(defun bug249 (x)
+ (flet ((bar (y)
+ (declare (fixnum y))
+ (incf x)))
+ (list (bar x) (bar x) (bar x))))
+
+(assert (raises-error? (bug249 1.0) type-error))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.3"
+"0.8.0.4"
projects / sbcl.git / commitdiff