From 2bb000b0284b86f46400ceaf270e02513ddc1971 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 14 Dec 2004 21:56:23 +0000
Subject: [PATCH] Fix some format bugs in ~{ and ~@[X~] bugs found by
 ansi-tests.  Many more bugs remain.

(Based on code in sbcl.)
---
 code/format.lisp | 37 +++++++++++++++++++------------------
 1 file changed, 19 insertions(+), 18 deletions(-)

diff --git a/code/format.lisp b/code/format.lisp
index 29a5ee87a..9177645db 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.57 2004/09/09 16:46:01 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.58 2004/12/14 21:56:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1788,7 +1788,7 @@
 	    (let ((*simple-args* *simple-args*))
 	      (values (expand-directive-list sublist)
 		      *simple-args*))
-	  (cond ((eq *simple-args* (cdr new-args))
+	  (cond ((and new-args (eq *simple-args* (cdr new-args)))
 		 (setf *simple-args* new-args)
 		 `(when ,(caar new-args)
 		    ,@guts))
@@ -1988,7 +1988,7 @@
 		     (throw 'need-orig-args nil))
 		 (let ((*up-up-and-out-allowed* colonp))
 		   (expand-directive-list (subseq directives 0 posn)))))
-	   (compute-loop-aux (count)
+	   (compute-loop (count)
 	     (when atsignp
 	       (setf *only-simple-args* nil))
 	     `(loop
@@ -2012,30 +2012,31 @@
 		,@(when closed-with-colon
 		    '((when (null args)
 			(return))))))
-	   (compute-loop ()
-	     (if params
-		 (expand-bind-defaults ((count nil)) params
-		   (compute-loop-aux count))
-		 (compute-loop-aux nil)))
-	   (compute-block ()
+	   (compute-block (count)
 	     (if colonp
 		 `(block outside-loop
-		    ,(compute-loop))
-		 (compute-loop)))
-	   (compute-bindings ()
+		    ,(compute-loop count))
+		 (compute-loop count)))
+	   (compute-bindings (count)
 	     (if atsignp
-		 (compute-block)
+		 (compute-block count)
 		 `(let* ((orig-args ,(expand-next-arg))
 			 (args orig-args))
 		    (declare (ignorable orig-args args))
 		    ,(let ((*expander-next-arg-macro* 'expander-next-arg)
 			   (*only-simple-args* nil)
 			   (*orig-args-available* t))
-		       (compute-block))))))
-	(values (if (zerop posn)
-		    `(let ((inside-string ,(expand-next-arg)))
-		       ,(compute-bindings))
-		    (compute-bindings))
+			  (compute-block count))))))
+	(values (if params
+		    (expand-bind-defaults ((count nil)) params
+		      (if (zerop posn)
+			  `(let ((inside-string ,(expand-next-arg)))
+			     ,(compute-bindings count))
+			  (compute-bindings count)))
+		    (if (zerop posn)
+			`(let ((inside-string ,(expand-next-arg)))
+			   ,(compute-bindings nil))
+			(compute-bindings nil)))
 		(nthcdr (1+ posn) directives))))))
 
 (def-complex-format-interpreter #\{
-- 
GitLab