The branch "master" has been updated in SBCL:
via afbad5dccd85bfbcbe70598782eab30ac05f2fdf (commit)
from 32c95570fd8253caca74ed16cde242b9ed3d08ab (commit)
- Log -----------------------------------------------------------------
commit afbad5dccd85bfbcbe70598782eab30ac05f2fdf
Author: Nikodemus Siivola <nikodemus@...>
Date: Wed Aug 24 14:52:38 2011 +0300
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)))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|