From 2489ac3021325890a98886110ab3055fa990a850 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Tue, 28 Jan 2003 11:53:31 +0000 Subject: [PATCH] 0.7.12.8: * Fixed bug 231b (SETQ ignored free type declarations); * some stylistic changes. --- BUGS | 11 +++++++++++ src/compiler/ir1-translators.lisp | 10 ++++++---- src/compiler/ir1opt.lisp | 4 ++-- src/compiler/ir1tran.lisp | 2 +- src/compiler/locall.lisp | 4 ++-- tests/compiler-1.impure-cload.lisp | 18 ++++++++++++++---- version.lisp-expr | 2 +- 7 files changed, 37 insertions(+), 14 deletions(-) diff --git a/BUGS b/BUGS index a8ec1da..aace2a0 100644 --- a/BUGS +++ b/BUGS @@ -1169,6 +1169,17 @@ WORKAROUND: 229: (subtypep 'function '(function)) => nil, t. +231: "SETQ does not correctly check the type of a variable being set" + b. + (defun foo (x z) + (declare (type integer x)) + (locally (declare (type (real 1) x)) + (setq x z)) + (list x z)) + (foo 0 0) => (0 0). + + (fixed in 0.7.12.8) + 233: bugs in constraint propagation a. (defun foo (x) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 46c3dee..30e27c8 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -35,6 +35,8 @@ (node (make-if :test pred :consequent then-block :alternative else-block))) + ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the + ;; order of the following two forms is important (setf (continuation-dest pred) node) (ir1-convert start pred test) (link-node-to-previous-continuation node pred) @@ -813,7 +815,10 @@ (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation))) (ir1-convert start dest value) - (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*)) + (assert-continuation-type dest + (or (lexenv-find var type-restrictions) + (leaf-type var)) + (lexenv-policy *lexenv*)) (let ((res (make-set :var var :value dest))) (setf (continuation-dest dest) res) (setf (leaf-ever-used var) t) @@ -958,9 +963,6 @@ fun `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol)) - (lexenv-policy *lexenv*)) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 02b8340..e6609c7 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -580,7 +580,7 @@ ;;; all functions in the tail set to be equivalent, this amounts to ;;; bringing the entire tail set up to date. We iterate over the ;;; returns for all the functions in the tail set, reanalyzing them -;;; all (not treating Node specially.) +;;; all (not treating NODE specially.) ;;; ;;; When we are done, we check whether the new type is different from ;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize @@ -1680,7 +1680,7 @@ (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) (collect ((res vals)) - (loop as cont = (make-continuation use) + (loop for cont = (make-continuation use) and prev = node-prev then cont repeat (- nvars nvals) do (reference-constant prev cont nil) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 23405d4..e081c85 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1703,7 +1703,7 @@ `((let ,(temps) ,@(body) (%funcall ,(optional-dispatch-main-entry res) - . ,(arg-vals)))) ; FIXME: What is the '.'? ,@? + ,@(arg-vals)))) (arg-vars) :debug-name (debug-namify "~S processing" '&more)))) (setf (optional-dispatch-more-entry res) ep)))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index e55c0be..a2abf54 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -537,8 +537,8 @@ (with-ir1-environment-from-node call (ir1-convert-lambda `(lambda ,vars - (declare (ignorable . ,ignores)) - (%funcall ,entry . ,args)) + (declare (ignorable ,@ignores)) + (%funcall ,entry ,@args)) :debug-name (debug-namify "hairy function entry ~S" (continuation-fun-name (basic-combination-fun call))))))) diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 4d5b104..a608dc8 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -177,19 +177,29 @@ (safe-format t "~&baz ~S (~A) ~S" condition condition result))))))) ;;; bug 231: SETQ did not check the type of the variable being set -(defun bug231-1 (x) +(defun bug231a-1 (x) (declare (optimize safety) (type (integer 0 8) x)) (incf x)) -(assert (raises-error? (bug231-1 8) type-error)) +(assert (raises-error? (bug231a-1 8) type-error)) -(defun bug231-2 (x) +(defun bug231a-2 (x) (declare (optimize safety) (type (integer 0 8) x)) (list (lambda (y) (setq x y)) (lambda () x))) -(destructuring-bind (set get) (bug231-2 0) +(destructuring-bind (set get) (bug231a-2 0) (funcall set 8) (assert (eql (funcall get) 8)) (assert (raises-error? (funcall set 9) type-error)) (assert (eql (funcall get) 8))) +(defun bug231b (x z) + (declare (optimize safety) (type integer x)) + (locally + (declare (type (real 1) x)) + (setq x z)) + (list x z)) +(assert (raises-error? (bug231b nil 1) type-error)) +(assert (raises-error? (bug231b 0 1.5) type-error)) +(assert (raises-error? (bug231b 0 0) type-error)) + (sb-ext:quit :unix-status 104) ; success diff --git a/version.lisp-expr b/version.lisp-expr index f5ad5c8..d006fc0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.12.7" +"0.7.12.8" -- 1.7.10.4