0.7.12.8:

        * Fixed bug 231b (SETQ ignored free type declarations);
        * some stylistic changes.

diff --git a/BUGS b/BUGS
index a8ec1da..aace2a0 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"