0.9.1.7: "fix" SB-SPROF on non-gencgc platforms

[sbcl.git] / src / code / late-format.lisp

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 4cb042a..88ff777 100644 (file)
--- 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))))))))
 \f
 ;;;; format directive for pluralization
 
@@ -790,9 +792,10 @@
                 (error 'format-error
                        :complaint
                        "must specify exactly two sections"))
-            (expand-bind-defaults ((index (expand-next-arg))) params
+            (expand-bind-defaults ((index nil)) params
               (setf *only-simple-args* nil)
-              (let ((clauses nil))
+              (let ((clauses nil)
+                     (case `(or ,index ,(expand-next-arg))))
                 (when last-semi-with-colon-p
                   (push `(t ,@(expand-directive-list (pop sublists)))
                         clauses))
@@ -801,7 +804,7 @@
                     (push `(,(decf count)
                             ,@(expand-directive-list sublist))
                           clauses)))
-                `(case ,index ,@clauses)))))
+                `(case ,case ,@clauses)))))
      remaining)))
 
 (defun parse-conditional-directive (directives)
@@ -834,7 +837,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 +908,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 +949,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 +973,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 #\} ()