[Sbcl-commits] master: Fix CAS SYMBOL-VALUE for locally special variables.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  fa52f5ce506a4df5fa6b493dd33e1feab874f4a9 (commit)
      from  1825189a64330369f10be389ee62469860ed72d8 (commit)

- Log -----------------------------------------------------------------
commit fa52f5ce506a4df5fa6b493dd33e1feab874f4a9
Author: Stas Boukarev <sta...@gm...>
Date:   Mon Jun 30 20:52:40 2014 +0400

    Fix CAS SYMBOL-VALUE for locally special variables.
    
    The case-form of the expansion was wrong, and the read-form used
    SYMBOL-GLOBAL-VALUE.
    
    Fixes lp#1098355.
---
 NEWS                               |    2 ++
 src/code/late-cas.lisp             |   36 ++++++++++++++++++------------------
 src/code/symbol.lisp               |    4 ++--
 src/compiler/fndb.lisp             |    2 ++
 tests/compare-and-swap.impure.lisp |   18 ++++++++++++++++++
 5 files changed, 42 insertions(+), 20 deletions(-)

diff --git a/NEWS b/NEWS
index 3833769..5b44028 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.2.1:
   * bug fix: #\Bell and #\Bel now read to different characters. (lp#1319452).
+  * bug fix: CAS SYMBOL-VALUE on locally special variables didn't work.
+    (lp#1098355)
 
 changes in sbcl-1.2.1 relative to sbcl-1.2.0:
   * enhancement: GENCGC is enabled on ARM.
diff --git a/src/code/late-cas.lisp b/src/code/late-cas.lisp
index 0ae2ca3..c0cdd88 100644
--- a/src/code/late-cas.lisp
+++ b/src/code/late-cas.lisp
@@ -11,24 +11,24 @@
       (if (sb!xc:constantp name env)
           (values nil nil (constant-form-value name env))
           (values (gensymify name) name nil))
-    (with-unique-names (old new)
-      (values (when tmp (list tmp))
-              (when val (list val))
-              old
-              new
-              (let ((slow
-                      `(locally
-                           (declare (symbol ,tmp))
-                         (about-to-modify-symbol-value ,tmp 'compare-and-swap ,new)
-                         (%compare-and-swap-symbol-value ,tmp ,old ,new))))
-                (if cname
-                    (if (member (info :variable :kind cname) '(:special :global))
-                        ;; We can generate the type-check reasonably.
-                        `(%compare-and-swap-symbol-value
-                          ',cname ,old (the ,(info :variable :type cname) ,new))
-                        slow)
-                    slow))
-              `(symbol-global-value ,(or tmp `',cname))))))
+    (let ((symbol (or tmp `',cname)))
+      (with-unique-names (old new)
+        (values (when tmp (list tmp))
+                (when val (list val))
+                old
+                new
+                (let ((slow
+                        `(progn
+                           (about-to-modify-symbol-value ,symbol 'compare-and-swap ,new)
+                           (%compare-and-swap-symbol-value ,symbol ,old ,new))))
+                  (if cname
+                      (if (member (info :variable :kind cname) '(:special :global))
+                          ;; We can generate the type-check reasonably.
+                          `(%compare-and-swap-symbol-value
+                            ',cname ,old (the ,(info :variable :type cname) ,new))
+                          slow)
+                      slow))
+                `(symbol-value ,symbol))))))
 
 (define-cas-expander svref (vector index)
   (with-unique-names (v i old new)
diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 575723a..4ebbb7f 100644
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -482,5 +482,5 @@ distinct from the global value. Can also be SETF."
                        :format-control "~@<Cannot ~@? to ~S, not of type ~S.~:@>"
                        :format-arguments (list (describe-action) symbol new-value spec)
                        :datum new-value
-                       :expected-type spec))))))))
-  (values))
+                       :expected-type spec)))))))
+    nil))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 358288e..72cb1c5 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -98,6 +98,8 @@
 ;;; This is not FLUSHABLE, since it's required to signal an error if
 ;;; unbound.
 (defknown (symbol-value) (symbol) t ())
+(defknown about-to-modify-symbol-value (symbol t &optional t t) null
+  (explicit-check))
 ;;; From CLHS, "If the symbol is globally defined as a macro or a
 ;;; special operator, an object of implementation-dependent nature and
 ;;; identity is returned. If the symbol is not globally defined as
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index e16e0cb..7246b24 100644
--- a/tests/compare-and-swap.impure.lisp
+++ b/tests/compare-and-swap.impure.lisp
@@ -449,3 +449,21 @@
                                       (sleep 0.00001))))))
       (assert (not y))
       (assert (eql n (length x))))))
+
+(with-test (:name :local-special-symbol-value)
+  (assert
+   (= (funcall (compile nil
+                        `(lambda ()
+                           (let ((x 10))
+                             (declare (special x))
+                             (cas (symbol-value 'x) 10 12)
+                             x))))
+      12))
+  (assert
+   (= (funcall
+       (compile nil
+                `(lambda ()
+                   (let ((x (list 1)))
+                     (declare (special x))
+                     (atomic-pop (symbol-value 'x))))))
+      1)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL