From 1366d9ed223c6953df491260ecaeb3b3867006b2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 26 Aug 2014 23:40:22 +0200
Subject: Handle ~p in 'format' warnings.

Fixes <http://bugs.gnu.org/18299>.
Reported by Frank Terbeck <ft@bewatermyfriend.org>.

* module/language/tree-il/analyze.scm (format-string-argument-count):
  Add case for ~p.
* test-suite/tests/tree-il.test ("warnings")["format"]("~p", "~p, too
  few arguments", "~:p", "~:@p, too many arguments", "~:@p, too few
  arguments"): New tests.

Origin: http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8ac39b38d14f47b6028030fa829f1fe7d0499f21
Added-by: Rob Browning <rlb@defaultvalue.org>
---
 module/language/tree-il/analyze.scm | 13 ++++++++++-
 test-suite/tests/tree-il.test       | 44 +++++++++++++++++++++++++++++++++++++
 2 files changed, 56 insertions(+), 1 deletion(-)

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index badce9f..ef625d4 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,6 +1,7 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
+;;   2014 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1273,6 +1274,16 @@ accurate information is missing from a given `tree-il' element."
                               conditions end-group
                               (+ 1 min-count)
                               (+ 1 max-count)))
+             ((#\p #\P) (let* ((colon?    (memq #\: params))
+                               (min-count (if colon?
+                                              (max 1 min-count)
+                                              (+ 1 min-count))))
+                          (loop (cdr chars) 'literal '()
+                                conditions end-group
+                                min-count
+                                (if colon?
+                                    (max max-count min-count)
+                                    (+ 1 max-count)))))
              ((#\[)
               (loop chars 'literal '() '()
                     (let ((selector (previous-number params))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 34bc810..f892033 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1698,6 +1698,50 @@
               (number? (string-contains (car w)
                                         "expected 3, got 2")))))
 
+     (pass-if "~p"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(((@ (ice-9 format) format) #f "thing~p" 2))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "~p, too few arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "~p")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 0")))))
+
+     (pass-if "~:p"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "~:@p, too many arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 2")))))
+
+     (pass-if "~:@p, too few arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "pupp~:@p")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 1, got 0")))))
+
      (pass-if "~?"
        (null? (call-with-warnings
                (lambda ()