From afbad5dccd85bfbcbe70598782eab30ac05f2fdf Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 24 Aug 2011 14:52:38 +0300
Subject: [PATCH] be more careful about ,@<constant-atom> and
 ,.<constant-atom>

  Specifically, signal a read-time error for those things which COMMA
  special-cases when constructing a splice.

  Fixes lp#770184.
---
 NEWS                    |    2 ++
 src/code/backq.lisp     |   41 +++++++++++++++++++++++------------------
 tests/backq.impure.lisp |    7 +++++++
 3 files changed, 32 insertions(+), 18 deletions(-)

diff --git a/NEWS b/NEWS
index 8eca65d..c28c716 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,8 @@ changes relative to sbcl-1.0.50:
     AREF, CHAR, etc. (lp#826971)
   * bug fix: compiler-errors causes by integer arguments with composed of multiple
     ranges to ARRAY-IN-BOUNDS-P. (lp#826970)
+  * bug fix: ,@ and ,. now signal a read-time error for certain non-list
+    expressions. (lp#770184)
 
 changes in sbcl-1.0.51 relative to sbcl-1.0.50:
   * minor incompatible change: SB-BSD-SOCKET socket streams no longer
diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index fb9bd04..6b615f3 100644
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -97,6 +97,21 @@
          (or (eq flag *bq-at-flag*)
              (eq flag *bq-dot-flag*)))))
 
+(defun backquote-splice (method dflag a d what stream)
+  (cond (dflag
+         (values method
+                 (cond ((eq dflag method)
+                        (cons a d))
+                       (t (list a (backquotify-1 dflag d))))))
+        ((expandable-backq-expression-p a)
+         (values method (list a)))
+        ((not (and (atom a) (backq-constant-p a)))
+         ;; COMMA special cases a few constant atoms, which
+         ;; are illegal in splices.
+         (comma a))
+        (t
+         (simple-reader-error stream "Invalid splice in backquote: ~A~A" what a))))
+
 ;;; This does the expansion from table 2.
 (defun backquotify (stream code)
   (cond ((atom code)
@@ -123,23 +138,9 @@
                  (simple-reader-error stream ",. after dot in ~S" code))
                (cond
                 ((eq aflag *bq-at-flag*)
-                 (if (null dflag)
-                     (if (expandable-backq-expression-p a)
-                         (values 'append (list a))
-                         (comma a))
-                     (values 'append
-                             (cond ((eq dflag 'append)
-                                    (cons a d ))
-                                   (t (list a (backquotify-1 dflag d)))))))
+                 (backquote-splice 'append dflag a d ",@" stream))
                 ((eq aflag *bq-dot-flag*)
-                 (if (null dflag)
-                     (if (expandable-backq-expression-p a)
-                         (values 'nconc (list a))
-                         (comma a))
-                     (values 'nconc
-                             (cond ((eq dflag 'nconc)
-                                    (cons a d))
-                                   (t (list a (backquotify-1 dflag d)))))))
+                 (backquote-splice 'nconc dflag a d ",." stream))
                 ((null dflag)
                  (if (member aflag '(quote t nil))
                      (values 'quote (list a))
@@ -157,14 +158,18 @@
 
 (/show0 "backq.lisp 139")
 
+(defun backq-constant-p (x)
+  (or (numberp x) (eq x t)))
+
 ;;; This handles the <hair> cases.
 (defun comma (code)
   (cond ((atom code)
          (cond ((null code)
                 (values nil nil))
-               ((or (numberp code) (eq code t))
+               ((backq-constant-p code)
                 (values t code))
-               (t (values *bq-comma-flag* code))))
+               (t
+                (values *bq-comma-flag* code))))
         ((and (eq (car code) 'quote)
               (not (expandable-backq-expression-p (cadr code))))
          (values (car code) (cadr code)))
diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp
index 6a64703..7632c78 100644
--- a/tests/backq.impure.lisp
+++ b/tests/backq.impure.lisp
@@ -64,3 +64,10 @@
 
 (let ((s '``(,,@(list 1 2 3) 10)))
   (assert (equal (eval (eval s)) '(1 2 3 10))))
+
+(with-test (:name :comma-at-number-error)
+  (assert (eq :error
+              (handler-case
+                  (read-from-string "`(,@1)")
+                (reader-error ()
+                  :error)))))
-- 
1.7.10.4