From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 10 Sep 2012 22:08:25 +0000 (+0300)
Subject: fix bug in SYMBOL-VALUE CAS expansion for constant arguments
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=31a5540ef1bbe9bb9d31330beb3151d4f93287f4;p=sbcl.git

fix bug in SYMBOL-VALUE CAS expansion for constant arguments
---

diff --git a/NEWS b/NEWS
index a858d46..ce74270 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,8 @@ changes relative to sbcl-1.0.58:
   * bug fix: SB-BSD-SOCKETS:SOCKET-RECEIVE with a UDP socket now works
     correctly when the received datagram is larger than the provided buffer.
     (lp#1023438, thanks to Robert Uhl)
+  * bug fix: SB-EXT:GET-CAS-EXPANSION returned a bogus read-form when given
+    a SYMBOL-VALUE form with a constant symbol argument.
   * documentation: a section on random number generation has been added to the
     manual. (lp#656839)
 
diff --git a/src/code/late-cas.lisp b/src/code/late-cas.lisp
index dd912dc..0ae2ca3 100644
--- a/src/code/late-cas.lisp
+++ b/src/code/late-cas.lisp
@@ -28,7 +28,7 @@
                           ',cname ,old (the ,(info :variable :type cname) ,new))
                         slow)
                     slow))
-              `(symbol-global-value ,tmp)))))
+              `(symbol-global-value ,(or tmp `',cname))))))
 
 (define-cas-expander svref (vector index)
   (with-unique-names (v i old new)
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index f51559f..da4e2c9 100644
--- a/tests/compare-and-swap.impure.lisp
+++ b/tests/compare-and-swap.impure.lisp
@@ -394,3 +394,21 @@
     (assert (eq t (cas (thing b) nil :oops)))
     (assert (eq t (thing a)))
     (assert (eq t (thing b)))))
+
+;;; SYMBOL-VALUE with a constant argument used to return a bogus read-form
+(with-test (:name :symbol-value-cas-expansion)
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion `(symbol-value t))
+    (assert (not vars))
+    (assert (not vals))
+    (assert (eq t (eval read-form))))
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion `(symbol-value *))
+    (let ((* :foo))
+      (assert (eq :foo
+                  (eval `(let (,@(mapcar 'list vars vals))
+                      ,read-form)))))
+    (let ((* :bar))
+      (assert (eq :bar
+                  (eval `(let (,@(mapcar 'list vars vals))
+                      ,read-form)))))))