X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=d758b0dee341bf873ac1de0d0be08b2815c253e5;hb=cb79d726de3e18c660f84c58a43f00d22b459037;hp=4cb042a696277eaa5db87c899b3c6ad45ad14b36;hpb=988afd9d54ba6c8a915544822658824ab6ae0d6c;p=sbcl.git

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 4cb042a..d758b0d 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -493,21 +493,23 @@
   (expand-format-integer 16 colonp atsignp params))
 
 (def-format-directive #\R (colonp atsignp params)
-  (if params
-      (expand-bind-defaults
-	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-	   (commainterval 3))
-	  params
-	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
-			       ,base ,mincol
-			       ,padchar ,commachar ,commainterval))
-      (if atsignp
-	  (if colonp
-	      `(format-print-old-roman stream ,(expand-next-arg))
-	      `(format-print-roman stream ,(expand-next-arg)))
-	  (if colonp
-	      `(format-print-ordinal stream ,(expand-next-arg))
-	      `(format-print-cardinal stream ,(expand-next-arg))))))
+  (expand-bind-defaults
+      ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+       (commainterval 3))
+      params
+    (let ((n-arg (gensym))) 
+      `(let ((,n-arg ,(expand-next-arg)))
+         (if ,base
+             (format-print-integer stream ,n-arg ,colonp ,atsignp
+      	   	                   ,base ,mincol
+      		                   ,padchar ,commachar ,commainterval)
+             ,(if atsignp
+                  (if colonp
+                      `(format-print-old-roman stream ,n-arg)
+                      `(format-print-roman stream ,n-arg))
+                  (if colonp
+                      `(format-print-ordinal stream ,n-arg)
+	              `(format-print-cardinal stream ,n-arg))))))))
 
 ;;;; format directive for pluralization
 
@@ -834,7 +836,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))
@@ -905,18 +907,15 @@
   (when (and colonp (not *up-up-and-out-allowed*))
     (error 'format-error
 	   :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
-  `(when ,(case (length params)
-	    (0 (if colonp
-		   '(null outside-args)
-		   (progn
-		     (setf *only-simple-args* nil)
-		     '(null args))))
-	    (1 (expand-bind-defaults ((count 0)) params
-		 `(zerop ,count)))
-	    (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
-		 `(= ,arg1 ,arg2)))
-	    (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
-		 `(<= ,arg1 ,arg2 ,arg3))))
+  `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
+            `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
+                   (,arg2 (eql ,arg1 ,arg2))
+                   (,arg1 (eql ,arg1 0))
+                   (t ,(if colonp
+                           '(null outside-args)
+                           (progn
+                             (setf *only-simple-args* nil)
+                             '(null args))))))
      ,(if colonp
 	  '(return-from outside-loop nil)
 	  '(return))))
@@ -949,7 +948,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
@@ -973,30 +972,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)
-		 `(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)
+                 `(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 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-directive #\} ()