From efb7317381c54e1a28f6c1c179a4fb8d58fdc7eb Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Mon, 26 May 2003 08:17:13 +0000 Subject: [PATCH] 0.8.0.4: Fixed bug 249: local functions did not check type of unused arguments. --- BUGS | 9 --------- src/code/float.lisp | 21 +++++++-------------- src/compiler/array-tran.lisp | 3 ++- src/compiler/ir1opt.lisp | 36 +++++++++++++++++++----------------- src/compiler/locall.lisp | 19 ++++++++----------- src/compiler/x86/type-vops.lisp | 8 ++++++++ tests/compiler.impure.lisp | 7 +++++++ version.lisp-expr | 2 +- 8 files changed, 52 insertions(+), 53 deletions(-) diff --git a/BUGS b/BUGS index 0715f86..ab130b0 100644 --- a/BUGS +++ b/BUGS @@ -1212,15 +1212,6 @@ WORKAROUND: (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. diff --git a/src/code/float.lisp b/src/code/float.lisp index 91bafe6..be7a92c 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -45,7 +45,7 @@ (make-long-float (logior (ash sign 15) exp) (ldb (byte 32 32) sig) (ldb (byte 32 0) sig))) - + ) ; EVAL-WHEN ;;;; float parameters @@ -283,8 +283,8 @@ (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))) @@ -311,17 +311,10 @@ #!+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) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 9b77313..e7f96e9 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -58,7 +58,8 @@ 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. diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2e8c17f..8b25671 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -197,26 +197,28 @@ ;;; 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 diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 3e4ceaf..bf6c409 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -34,17 +34,14 @@ ;;; 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)) diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 43617fd..5c3fb79 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -170,6 +170,14 @@ ;;;; 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. diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 71cce35..4f44164 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -828,6 +828,13 @@ (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)) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index 88c9a2f..83a38f2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4