From 2ce0d24b6307634ddf111ba902241edef95445df Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 31 Aug 2004 16:31:43 +0000
Subject: [PATCH] Catch uses of ~<...~:;...~> form of ~<...~> in the same
 format string as ~W, ~_, ~<...~:>, ~I, or ~:T.

This should signal an error, according to CLHS 22.3.5.2.
---
 code/format.lisp | 46 +++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 43 insertions(+), 3 deletions(-)

diff --git a/code/format.lisp b/code/format.lisp
index aa1b9c603..d6e8d20bc 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.54 2004/08/31 12:48:20 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.55 2004/08/31 16:31:43 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -78,16 +78,56 @@
   (declare (simple-string string))
   (let ((index 0)
 	(end (length string))
-	(result nil))
+	(result nil)
+	(in-block nil)
+	(pprint nil)
+	(semi nil)
+	(justification-semi 0))
     (loop
       (let ((next-directive (or (position #\~ string :start index) end)))
 	(when (> next-directive index)
 	  (push (subseq string index next-directive) result))
 	(when (= next-directive end)
 	  (return))
-	(let ((directive (parse-directive string next-directive)))
+	(let* ((directive (parse-directive string next-directive))
+	       (directive-char (format-directive-character directive)))
+	  ;; We are looking for illegal combinations of format
+	  ;; directives in the control string.  See the last paragraph
+	  ;; of CLHS 22.3.5.2: "an error is also signaled if the
+	  ;; ~<...~:;...~> form of ~<...~> is used in the same format
+	  ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T."
+	  (cond ((char= #\< directive-char)
+		 ;; Found a justification or logical block
+		 (setf in-block t))
+		((and in-block (char= #\; directive-char))
+		 ;; Found a semi colon in a justification or logical block
+		 (setf semi t))
+		((char= #\> directive-char)
+		 ;; End of justification or logical block.  Figure out which. 
+		 (setf in-block nil)
+		 (cond ((format-directive-colonp directive)
+			;; A logical-block directive.  Note that fact, and also
+			;; note that we don't care if we found any ~;
+			;; directives in the block.
+			(setf pprint t)
+			(setf semi nil))
+		       (semi
+			;; A justification block with a ~; directive in it.
+			(incf justification-semi))))
+		((and (not in-block)
+		      (or (and (char= #\T directive-char) (format-directive-colonp directive))
+			  (char= #\W directive-char)
+			  (char= #\_ directive-char)
+			  (char= #\I directive-char)))
+		 (setf pprint t)))
 	  (push directive result)
 	  (setf index (format-directive-end directive)))))
+    (when (and pprint (plusp justification-semi))
+      (error 'format-error
+	     :complaint "A justification directive cannot be in the same format string~%~
+                         as ~~W, ~~I, ~~:T, or a logical-block directive."
+	     :control-string string
+	     :offset 0))
     (nreverse result)))
 
 (defun parse-directive (string start)
-- 
GitLab