(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)
+ (declare (ignore 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)))))))
;;;; or T and the control string is a function (i.e. FORMATTER), then
;;;; convert the call to FORMAT to just a FUNCALL of that function.
+(defun check-format-args (string args)
+ (declare (type string string))
+ (unless (typep string 'simple-string)
+ (setq string (coerce string 'simple-string)))
+ (multiple-value-bind (min max)
+ (handler-case (sb!format:%compiler-walk-format-string string args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min
+ (let ((nargs (length args)))
+ (cond
+ ((< nargs min)
+ (compiler-warn "Too few arguments (~D) to FORMAT ~S: ~
+ requires at least ~D."
+ nargs string min))
+ ((> nargs max)
+ (;; to get warned about probably bogus code at
+ ;; cross-compile time.
+ #+sb-xc-host compiler-warn
+ ;; ANSI saith that too many arguments doesn't cause a
+ ;; run-time error.
+ #-sb-xc-host compiler-style-warn
+ "Too many arguments (~D) to FORMAT ~S: uses at most ~D."
+ nargs string max)))))))
+
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
- :policy (> speed space))
- (unless (constant-continuation-p control)
- (give-up-ir1-transform "The control string is not a constant."))
- (let ((arg-names (make-gensym-list (length args))))
- `(lambda (dest control ,@arg-names)
- (declare (ignore control))
- (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+ :node node)
+
+ (cond
+ ((policy node (> speed space))
+ (unless (constant-continuation-p control)
+ (give-up-ir1-transform "The control string is not a constant."))
+ (check-format-args (continuation-value control) args)
+ (let ((arg-names (make-gensym-list (length args))))
+ `(lambda (dest control ,@arg-names)
+ (declare (ignore control))
+ (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+ (t (when (constant-continuation-p control)
+ (check-format-args (continuation-value control) args))
+ (give-up-ir1-transform))))
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
projects / sbcl.git / commitdiff