X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=88ff77725758e1ab665781a2cf7d0f2dc346279f;hb=70c579379283da66f97906a0d62c8a5fc34e4dab;hp=27d2b3ab87b4566be66314ec92d11f71949ad583;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 27d2b3a..88ff777 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -9,33 +9,37 @@
 
 (in-package "SB!FORMAT")
 
-(define-condition format-error (error)
+(define-condition format-error (error reference-condition)
   ((complaint :reader format-error-complaint :initarg :complaint)
-   (arguments :reader format-error-arguments :initarg :arguments :initform nil)
+   (args :reader format-error-args :initarg :args :initform nil)
    (control-string :reader format-error-control-string
 		   :initarg :control-string
 		   :initform *default-format-error-control-string*)
    (offset :reader format-error-offset :initarg :offset
 	   :initform *default-format-error-offset*)
+   (second-relative :reader format-error-second-relative
+                    :initarg :second-relative :initform nil)
    (print-banner :reader format-error-print-banner :initarg :print-banner
 		 :initform t))
-  (:report %print-format-error))
+  (:report %print-format-error)
+  (:default-initargs :references nil))
 
 (defun %print-format-error (condition stream)
   (format stream
-	  "~:[~;error in format: ~]~
-		 ~?~@[~%  ~A~%  ~V@T^~]"
+	  "~:[~*~;error in ~S: ~]~?~@[~%  ~A~%  ~V@T^~@[~V@T^~]~]"
 	  (format-error-print-banner condition)
+          'format
 	  (format-error-complaint condition)
-	  (format-error-arguments condition)
+	  (format-error-args condition)
 	  (format-error-control-string condition)
-	  (format-error-offset condition)))
+	  (format-error-offset condition)
+          (format-error-second-relative condition)))
 
 (def!struct format-directive
   (string (missing-arg) :type simple-string)
   (start (missing-arg) :type (and unsigned-byte fixnum))
   (end (missing-arg) :type (and unsigned-byte fixnum))
-  (character (missing-arg) :type base-char)
+  (character (missing-arg) :type character)
   (colonp nil :type (member t nil))
   (atsignp nil :type (member t nil))
   (params nil :type list))
@@ -52,16 +56,59 @@
   (declare (simple-string string))
   (let ((index 0)
 	(end (length string))
-	(result nil))
+	(result nil)
+        ;; FIXME: consider rewriting this 22.3.5.2-related processing
+        ;; using specials to maintain state and doing the logic inside
+        ;; the directive expanders themselves.
+        (block)
+        (pprint)
+        (semicolon)
+        (justification-semicolon))
     (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))
+               (char (format-directive-character directive)))
+          ;; this processing is required by CLHS 22.3.5.2
+          (cond
+            ((char= char #\<) (push directive block))
+            ((and block (char= char #\;) (format-directive-colonp directive))
+             (setf semicolon directive))
+            ((char= char #\>)
+             (aver block)
+             (cond
+               ((format-directive-colonp directive)
+                (unless pprint
+                  (setf pprint (car block)))
+                (setf semicolon nil))
+               (semicolon
+                (unless justification-semicolon
+                  (setf justification-semicolon semicolon))))
+             (pop block))
+            ;; block cases are handled by the #\< expander/interpreter
+            ((not block)
+             (case char
+               ((#\W #\I #\_) (unless pprint (setf pprint directive)))
+               (#\T (when (and (format-directive-colonp directive)
+                               (not pprint))
+                      (setf pprint directive))))))
 	  (push directive result)
 	  (setf index (format-directive-end directive)))))
+    (when (and pprint justification-semicolon)
+      (let ((pprint-offset (1- (format-directive-end pprint)))
+            (justification-offset
+             (1- (format-directive-end justification-semicolon))))
+        (error 'format-error
+               :complaint "misuse of justification and pprint directives"
+               :control-string string
+               :offset (min pprint-offset justification-offset)
+               :second-relative (- (max pprint-offset justification-offset)
+                                   (min pprint-offset justification-offset)
+                                   1)
+               :references (list '(:ansi-cl :section (22 3 5 2))))))
     (nreverse result)))
 
 (defun parse-directive (string start)
@@ -70,13 +117,21 @@
     (flet ((get-char ()
 	     (if (= posn end)
 		 (error 'format-error
-			:complaint "String ended before directive was found."
+			:complaint "string ended before directive was found"
 			:control-string string
 			:offset start)
-		 (schar string posn))))
+		 (schar string posn)))
+	   (check-ordering ()
+	     (when (or colonp atsignp)
+	       (error 'format-error
+		      :complaint "parameters found after #\\: or #\\@ modifier"
+		      :control-string string
+		      :offset posn
+                      :references (list '(:ansi-cl :section (22 3)))))))
       (loop
 	(let ((char (get-char)))
 	  (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
+		 (check-ordering)
 		 (multiple-value-bind (param new-posn)
 		     (parse-integer string :start posn :junk-allowed t)
 		   (push (cons posn param) params)
@@ -87,7 +142,9 @@
 		      (decf posn))
 		     (t
 		      (return)))))
-		((or (char= char #\v) (char= char #\V))
+		((or (char= char #\v)
+		     (char= char #\V))
+		 (check-ordering)
 		 (push (cons posn :arg) params)
 		 (incf posn)
 		 (case (get-char)
@@ -97,6 +154,7 @@
 		   (t
 		    (return))))
 		((char= char #\#)
+		 (check-ordering)
 		 (push (cons posn :remaining) params)
 		 (incf posn)
 		 (case (get-char)
@@ -106,29 +164,36 @@
 		   (t
 		    (return))))
 		((char= char #\')
+		 (check-ordering)
 		 (incf posn)
 		 (push (cons posn (get-char)) params)
 		 (incf posn)
 		 (unless (char= (get-char) #\,)
 		   (decf posn)))
 		((char= char #\,)
+		 (check-ordering)
 		 (push (cons posn nil) params))
 		((char= char #\:)
 		 (if colonp
 		     (error 'format-error
 			    :complaint "too many colons supplied"
 			    :control-string string
-			    :offset posn)
+			    :offset posn
+                            :references (list '(:ansi-cl :section (22 3))))
 		     (setf colonp t)))
 		((char= char #\@)
 		 (if atsignp
 		     (error 'format-error
 			    :complaint "too many #\\@ characters supplied"
 			    :control-string string
-			    :offset posn)
+			    :offset posn
+                            :references (list '(:ansi-cl :section (22 3))))
 		     (setf atsignp t)))
 		(t
-		 (when (char= (schar string (1- posn)) #\,)
+		 (when (and (char= (schar string (1- posn)) #\,)
+			    (or (< posn 2)
+				(char/= (schar string (- posn 2)) #\')))
+		   (check-ordering)
 		   (push (cons (1- posn) nil) params))
 		 (return))))
 	(incf posn))
@@ -205,14 +270,19 @@
   (etypecase directive
     (format-directive
      (let ((expander
-	    (aref *format-directive-expanders*
-		  (char-code (format-directive-character directive))))
+            (let ((char (format-directive-character directive)))
+              (typecase char
+                (base-char
+                 (aref *format-directive-expanders* (char-code char)))
+                (character nil))))
 	   (*default-format-error-offset*
 	    (1- (format-directive-end directive))))
+       (declare (type (or null function) expander))
        (if expander
 	   (funcall expander directive more-directives)
 	   (error 'format-error
-		  :complaint "unknown directive"))))
+		  :complaint "unknown directive ~@[(character: ~A)~]"
+		  :args (list (char-name (format-directive-character directive)))))))
     (simple-string
      (values `(write-string ,directive stream)
 	     more-directives))))
@@ -264,7 +334,7 @@
 			      'format-error
 			      :complaint
 			      "too many parameters, expected no more than ~W"
-			      :arguments (list ,(length specs))
+			      :args (list ,(length specs))
 			      :offset (caar ,params)))
 		       ,,@body)))
 	`(progn
@@ -312,7 +382,7 @@
        (values (progn ,@body-without-decls)
 	       ,directives))))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 (defun %set-format-directive-expander (char fn)
   (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
@@ -423,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
 
@@ -618,8 +690,8 @@
 		 (setf args (nthcdr ,posn orig-args))
 		 (error 'format-error
 			:complaint "Index ~W out of bounds. Should have been ~
-				    between 0 and ~W."
-			:arguments (list ,posn (length orig-args))
+                                    between 0 and ~W."
+			:args (list ,posn (length orig-args))
 			:offset ,(1- end)))))
       (if colonp
 	  (expand-bind-defaults ((n 1)) params
@@ -635,9 +707,8 @@
 			(error 'format-error
 			       :complaint
 			       "Index ~W is out of bounds; should have been ~
-				between 0 and ~W."
-			       :arguments
-			       (list new-posn (length orig-args))
+                                between 0 and ~W."
+			       :args (list new-posn (length orig-args))
 			       :offset ,(1- end)))))))
 	  (if params
 	      (expand-bind-defaults ((n 1)) params
@@ -655,14 +726,14 @@
   (expand-bind-defaults () params
     `(handler-bind
 	 ((format-error
-	   #'(lambda (condition)
-	       (error 'format-error
-		      :complaint
-		      "~A~%while processing indirect format string:"
-		      :arguments (list condition)
-		      :print-banner nil
-		      :control-string ,string
-		      :offset ,(1- end)))))
+	   (lambda (condition)
+	     (error 'format-error
+		    :complaint
+		    "~A~%while processing indirect format string:"
+		    :args (list condition)
+		    :print-banner nil
+		    :control-string ,string
+		    :offset ,(1- end)))))
        ,(if atsignp
 	    (if *orig-args-available*
 		`(setf args (%format stream ,(expand-next-arg) orig-args args))
@@ -721,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))
@@ -732,7 +804,7 @@
 		     (push `(,(decf count)
 			     ,@(expand-directive-list sublist))
 			   clauses)))
-		 `(case ,index ,@clauses)))))
+		 `(case ,case ,@clauses)))))
      remaining)))
 
 (defun parse-conditional-directive (directives)
@@ -765,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))
@@ -836,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))))
@@ -867,20 +936,20 @@
 		 (if *orig-args-available*
 		     `((handler-bind
 			   ((format-error
-			     #'(lambda (condition)
-				 (error 'format-error
-					:complaint
-			"~A~%while processing indirect format string:"
-					:arguments (list condition)
-					:print-banner nil
-					:control-string ,string
-					:offset ,(1- end)))))
+			     (lambda (condition)
+			       (error 'format-error
+				      :complaint
+			      "~A~%while processing indirect format string:"
+				      :args (list condition)
+				      :print-banner nil
+				      :control-string ,string
+				      :offset ,(1- end)))))
 			 (setf args
 			       (%format stream inside-string orig-args args))))
 		     (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
@@ -904,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 #\} ()
@@ -936,6 +1006,23 @@
 
 ;;;; format directives and support functions for justification
 
+(defparameter *illegal-inside-justification*
+  (mapcar (lambda (x) (parse-directive x 0))
+	  '("~W" "~:W" "~@W" "~:@W"
+	    "~_" "~:_" "~@_" "~:@_"
+	    "~:>" "~:@>"
+	    "~I" "~:I" "~@I" "~:@I"
+	    "~:T" "~:@T")))
+
+(defun illegal-inside-justification-p (directive)
+  (member directive *illegal-inside-justification*
+	  :test (lambda (x y)
+		  (and (format-directive-p x)
+		       (format-directive-p y)
+		       (eql (format-directive-character x) (format-directive-character y))
+		       (eql (format-directive-colonp x) (format-directive-colonp y))
+		       (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
+
 (def-complex-format-directive #\< (colonp atsignp params string end directives)
   (multiple-value-bind (segments first-semi close remaining)
       (parse-format-justification directives)
@@ -946,8 +1033,16 @@
 					 close params string end)
 	   (expand-format-logical-block prefix per-line-p insides
 					suffix atsignp))
-	 (expand-format-justification segments colonp atsignp
-				      first-semi params))
+	 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
+	   (when (> count 0)
+	     ;; ANSI specifies that "an error is signalled" in this
+	     ;; situation.
+	     (error 'format-error
+		    :complaint "~D illegal directive~:P found inside justification block"
+		    :args (list count)
+                    :references (list '(:ansi-cl :section (22 3 5 2)))))
+	   (expand-format-justification segments colonp atsignp
+                                        first-semi params)))
      remaining)))
 
 (def-complex-format-directive #\> ()
@@ -962,16 +1057,18 @@
 	   :offset (caar params)))
   (multiple-value-bind (prefix insides suffix)
       (multiple-value-bind (prefix-default suffix-default)
-	  (if colonp (values "(" ")") (values nil ""))
+	  (if colonp (values "(" ")") (values "" ""))
 	(flet ((extract-string (list prefix-p)
 		 (let ((directive (find-if #'format-directive-p list)))
 		   (if directive
 		       (error 'format-error
 			      :complaint
-			      "cannot include format directives inside the ~
-			       ~:[suffix~;prefix~] segment of ~~<...~~:>"
-			      :arguments (list prefix-p)
-			      :offset (1- (format-directive-end directive)))
+                              "cannot include format directives inside the ~
+                               ~:[suffix~;prefix~] segment of ~~<...~~:>"
+			      :args (list prefix-p)
+			      :offset (1- (format-directive-end directive))
+                              :references
+                              (list '(:ansi-cl :section (22 3 5 2))))
 		       (apply #'concatenate 'string list)))))
 	(case (length segments)
 	  (0 (values prefix-default nil suffix-default))
@@ -996,19 +1093,39 @@
 	    insides
 	    suffix)))
 
-(defun add-fill-style-newlines (list string offset)
-  (if list
-      (let ((directive (car list)))
-	(if (simple-string-p directive)
-	    (nconc (add-fill-style-newlines-aux directive string offset)
-		   (add-fill-style-newlines (cdr list)
-					    string
-					    (+ offset (length directive))))
-	    (cons directive
-		  (add-fill-style-newlines (cdr list)
-					   string
-					   (format-directive-end directive)))))
-      nil))
+(defun add-fill-style-newlines (list string offset &optional last-directive)
+  (cond
+    (list
+     (let ((directive (car list)))
+       (cond
+	 ((simple-string-p directive)
+	  (let* ((non-space (position #\Space directive :test #'char/=))
+		 (newlinep (and last-directive
+				(char=
+				 (format-directive-character last-directive)
+				 #\Newline))))
+	    (cond
+	      ((and newlinep non-space)
+	       (nconc
+		(list (subseq directive 0 non-space))
+		(add-fill-style-newlines-aux
+		 (subseq directive non-space) string (+ offset non-space))
+		(add-fill-style-newlines
+		 (cdr list) string (+ offset (length directive)))))
+	      (newlinep
+	       (cons directive
+		     (add-fill-style-newlines
+		      (cdr list) string (+ offset (length directive)))))
+	      (t
+	       (nconc (add-fill-style-newlines-aux directive string offset)
+		      (add-fill-style-newlines
+		       (cdr list) string (+ offset (length directive))))))))
+	 (t
+	  (cons directive
+		(add-fill-style-newlines
+		 (cdr list) string
+		 (format-directive-end directive) directive))))))
+    (t nil)))
 
 (defun add-fill-style-newlines-aux (literal string offset)
   (let ((end (length literal))
@@ -1079,7 +1196,8 @@
 	 (block nil
 	   ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
 		   (*only-simple-args* nil)
-		   (*orig-args-available* t))
+		   (*orig-args-available*
+		    (if atsignp *orig-args-available* t)))
 	       (expand-directive-list insides)))))))
 
 (defun expand-format-justification (segments colonp atsignp first-semi params)
@@ -1104,10 +1222,10 @@
 		       (line-len '(or (sb!impl::line-length stream) 72)))
 		      (format-directive-params first-semi)
 		    `(setf extra-space ,extra line-len ,line-len))))
-	   ,@(mapcar #'(lambda (segment)
-			 `(push (with-output-to-string (stream)
-				  ,@(expand-directive-list segment))
-				segments))
+	   ,@(mapcar (lambda (segment)
+		       `(push (with-output-to-string (stream)
+				,@(expand-directive-list segment))
+			      segments))
 		     segments))
 	 (format-justification stream
 			       ,@(if newline-segment-p
@@ -1146,8 +1264,8 @@
 				  ;; subseq expansion.
 				  (subseq foo (1+ slash) (1- end)))))
 	   (first-colon (position #\: name))
-	   (last-colon (if first-colon (position #\: name :from-end t)))
-	   (package-name (if last-colon
+	   (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
+	   (package-name (if first-colon
 			     (subseq name 0 first-colon)
 			     "COMMON-LISP-USER"))
 	   (package (find-package package-name)))
@@ -1156,8 +1274,127 @@
 	;; FIND-UNDELETED-PACKAGE-OR-LOSE?
 	(error 'format-error
 	       :complaint "no package named ~S"
-	       :arguments (list package-name)))
-      (intern (if first-colon
-		  (subseq name (1+ first-colon))
-		  name)
+	       :args (list package-name)))
+      (intern (cond
+		((and second-colon (= second-colon (1+ first-colon)))
+		 (subseq name (1+ second-colon)))
+		(first-colon
+		 (subseq name (1+ first-colon)))
+		(t name))
 	      package))))
+
+;;; compile-time checking for argument mismatch.  This code is
+;;; inspired by that of Gerd Moellmann, and comes decorated with
+;;; FIXMEs:
+(defun %compiler-walk-format-string (string args)
+  (declare (type simple-string string))
+  (let ((*default-format-error-control-string* string))
+    (macrolet ((incf-both (&optional (increment 1))
+		 `(progn
+		   (incf min ,increment)
+		   (incf max ,increment)))
+	       (walk-complex-directive (function)
+		 `(multiple-value-bind (min-inc max-inc remaining)
+		   (,function directive directives args)
+		   (incf min min-inc)
+		   (incf max max-inc)
+		   (setq directives remaining))))
+      ;; FIXME: these functions take a list of arguments as well as
+      ;; the directive stream.  This is to enable possibly some
+      ;; limited type checking on FORMAT's arguments, as well as
+      ;; simple argument count mismatch checking: when the minimum and
+      ;; maximum argument counts are the same at a given point, we
+      ;; know which argument is going to be used for a given
+      ;; directive, and some (annotated below) require arguments of
+      ;; particular types.
+      (labels
+	  ((walk-justification (justification directives args)
+	     (declare (ignore args))
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end justification))))
+	       (multiple-value-bind (segments first-semi close remaining)
+		   (parse-format-justification directives)
+		 (declare (ignore segments first-semi))
+		 (cond
+		   ((not (format-directive-colonp close))
+		    (values 0 0 directives))
+		   ((format-directive-atsignp justification)
+		    (values 0 sb!xc:call-arguments-limit directives))
+		   ;; FIXME: here we could assert that the
+		   ;; corresponding argument was a list.
+		   (t (values 1 1 remaining))))))
+	   (walk-conditional (conditional directives args)
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end conditional))))
+	       (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+		   (parse-conditional-directive directives)
+		 (declare (ignore last-semi-with-colon-p))
+		 (let ((sub-max
+			(loop for s in sublists
+			      maximize (nth-value
+					1 (walk-directive-list s args)))))
+		   (cond
+		     ((format-directive-atsignp conditional)
+		      (values 1 (max 1 sub-max) remaining))
+		     ((loop for p in (format-directive-params conditional)
+			    thereis (or (integerp (cdr p))
+					(memq (cdr p) '(:remaining :arg))))
+		      (values 0 sub-max remaining))
+		     ;; FIXME: if not COLONP, then the next argument
+		     ;; must be a number.
+		     (t (values 1 (1+ sub-max) remaining)))))))
+	   (walk-iteration (iteration directives args)
+	     (declare (ignore args))
+	     (let ((*default-format-error-offset*
+		    (1- (format-directive-end iteration))))
+	       (let* ((close (find-directive directives #\} nil))
+		      (posn (or (position close directives)
+                                (error 'format-error
+                                       :complaint "no corresponding close brace")))
+		      (remaining (nthcdr (1+ posn) directives)))
+		 ;; FIXME: if POSN is zero, the next argument must be
+		 ;; a format control (either a function or a string).
+		 (if (format-directive-atsignp iteration)
+		     (values (if (zerop posn) 1 0)
+			     sb!xc:call-arguments-limit
+			     remaining)
+		     ;; FIXME: the argument corresponding to this
+		     ;; directive must be a list.
+		     (let ((nreq (if (zerop posn) 2 1)))
+		       (values nreq nreq remaining))))))
+	   (walk-directive-list (directives args)
+	     (let ((min 0) (max 0))
+	       (loop
+		(let ((directive (pop directives)))
+		  (when (null directive)
+		    (return (values min (min max sb!xc:call-arguments-limit))))
+		  (when (format-directive-p directive)
+		    (incf-both (count :arg (format-directive-params directive)
+				      :key #'cdr))
+		    (let ((c (format-directive-character directive)))
+		      (cond
+			((find c "ABCDEFGORSWX$/")
+			 (incf-both))
+			((char= c #\P)
+			 (unless (format-directive-colonp directive)
+			   (incf-both)))
+			((or (find c "IT%&|_();>~") (char= c #\Newline)))
+                        ;; FIXME: check correspondence of ~( and ~)
+			((char= c #\<)
+			 (walk-complex-directive walk-justification))
+			((char= c #\[)
+			 (walk-complex-directive walk-conditional))
+			((char= c #\{)
+			 (walk-complex-directive walk-iteration))
+			((char= c #\?)
+			 ;; FIXME: the argument corresponding to this
+			 ;; directive must be a format control.
+			 (cond
+			   ((format-directive-atsignp directive)
+			    (incf min)
+			    (setq max sb!xc:call-arguments-limit))
+			   (t (incf-both 2))))
+			(t (throw 'give-up-format-string-walk nil))))))))))
+	(catch 'give-up-format-string-walk
+	  (let ((directives (tokenize-control-string string)))
+	    (walk-directive-list directives args)))))))