From 7b8eb24427562ae9e3ffe77e0a98899b9786e2b1 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 10 Mar 2013 20:15:53 +0400
Subject: [PATCH] format: Signal an error for ~<~@>

CLHS doesn't allow @ to appear in the closing directive of ~<~>.

Patch by Jan Moringen.
Fixes lp#1153148
---
 NEWS                        |    2 ++
 src/code/late-format.lisp   |   12 +++++++++++-
 src/code/target-format.lisp |   12 +++++++++++-
 src/pcl/env.lisp            |    6 +++---
 tests/print.impure.lisp     |    4 ++++
 5 files changed, 31 insertions(+), 5 deletions(-)

diff --git a/NEWS b/NEWS
index 6937c27..a69cd9f 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,8 @@ changes relative to sbcl-1.1.5:
    (regression since 1.0.42.11-bis)
   * bug fix: clear-output calls the correct gray stream routine,
     sb-gray:stream-clear-output. (lp#1153257)
+  * bug fix: an error is signalled for an invalid format modifier: ~<~@>.
+    (lp#1153148)
 
 changes in sbcl-1.1.5 relative to sbcl-1.1.4:
   * minor incompatible change: SB-SPROF:WITH-PROFILING no longer loops
diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 7777866..4f4c6b1 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -1049,7 +1049,7 @@
   (multiple-value-bind (segments first-semi close remaining)
       (parse-format-justification directives)
     (values
-     (if (format-directive-colonp close)
+     (if (format-directive-colonp close) ; logical block vs. justification
          (multiple-value-bind (prefix per-line-p insides suffix)
              (parse-format-logical-block segments colonp first-semi
                                          close params string end)
@@ -1063,6 +1063,16 @@
                     :complaint "~D illegal directive~:P found inside justification block"
                     :args (list count)
                     :references (list '(:ansi-cl :section (22 3 5 2)))))
+           ;; ANSI does not explicitly say that an error should be
+           ;; signalled, but the @ modifier is not explicitly allowed
+           ;; for ~> either.
+           (when (format-directive-atsignp close)
+             (error 'format-error
+                    :complaint "@ modifier not allowed in close ~
+                    directive of justification ~
+                    block (i.e. ~~<...~~@>."
+                    :offset (1- (format-directive-end close))
+                    :references (list '(:ansi-cl :section (22 3 6 2)))))
            (expand-format-justification segments colonp atsignp
                                         first-semi params)))
      remaining)))
diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index f8ab91f..3406f9b 100644
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -1100,7 +1100,7 @@
   (multiple-value-bind (segments first-semi close remaining)
       (parse-format-justification directives)
     (setf args
-          (if (format-directive-colonp close)
+          (if (format-directive-colonp close) ; logical block vs. justification
               (multiple-value-bind (prefix per-line-p insides suffix)
                   (parse-format-logical-block segments colonp first-semi
                                               close params string end)
@@ -1115,6 +1115,16 @@
                          :complaint "~D illegal directive~:P found inside justification block"
                          :args (list count)
                          :references (list '(:ansi-cl :section (22 3 5 2)))))
+                ;; ANSI does not explicitly say that an error should
+                ;; be signalled, but the @ modifier is not explicitly
+                ;; allowed for ~> either.
+                (when (format-directive-atsignp close)
+                  (error 'format-error
+                         :complaint "@ modifier not allowed in close ~
+                         directive of justification ~
+                         block (i.e. ~~<...~~@>."
+                         :offset (1- (format-directive-end close))
+                         :references (list '(:ansi-cl :section (22 3 6 2)))))
                 (interpret-format-justification stream orig-args args
                                                 segments colonp atsignp
                                                 first-semi params))))
diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index f1cf98f..61ee08c 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -176,17 +176,17 @@
 
 (defmethod make-load-form ((object structure-object) &optional env)
   (declare (ignore env))
-  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+  (error "~@<don't know how to dump ~S (default ~S method called).~>"
          object 'make-load-form))
 
 (defmethod make-load-form ((object standard-object) &optional env)
   (declare (ignore env))
-  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+  (error "~@<don't know how to dump ~S (default ~S method called).~>"
          object 'make-load-form))
 
 (defmethod make-load-form ((object condition) &optional env)
   (declare (ignore env))
-  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+  (error "~@<don't know how to dump ~S (default ~S method called).~>"
          object 'make-load-form))
 
 (defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 3464c1c..ad0953d 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -103,6 +103,10 @@
 (assert (raises-error? (format nil "~<~<~A~:>~>" '(foo))))
 (assert (string= (format nil "~<~<~A~>~>" 'foo) "FOO"))
 
+(with-test (:name (:format :justification-atsign-check))
+  (assert (raises-error? (format nil "~<~@>")))
+  (assert (raises-error? (eval '(format nil "~<~@>")))))
+
 ;;; Check that arrays that we print while *PRINT-READABLY* is true are
 ;;; in fact generating similar objects.
 (assert (equal (array-dimensions
-- 
1.7.10.4