X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=bd61b58af968212f8c00da0b43cef54935fb3c36;hb=602c9b1f15e2d96e4b79a3341a734b5eb8e02093;hp=3d821ad0fa16da28601a0500fea0468ab02301ae;hpb=479ef26343b45753fc019b6535d3aa0ee54cb324;p=sbcl.git

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 3d821ad..bd61b58 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -1203,3 +1203,116 @@
 		 (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 (position close directives))
+		      (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)))
+			((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)))))))