Add warnings for unsupported `simple-format' options.

* module/language/tree-il/analyze.scm
  (format-analysis)[check-simple-format-args]: New procedure.  Use it.
  Add support for applications of <module-ref>.

* module/system/base/message.scm (%warning-types): Handle the `format
  simple-format' warning.

* module/language/scheme/spec.scm (scheme)[make-default-environment]:
  Use `simple-format' as the default `format'.

* test-suite/tests/tree-il.test ("warnings")["format"]: Explicitly use
  (@ (ice-9 format) format) where needed.
  ("simple-format"): New test prefix.

4 files changed, 112 insertions, 31 deletions

diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 0df4171ff..e4cf55c4c 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,6 +1,6 @@
 ;;; Guile Scheme specification
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -53,4 +53,11 @@
                     ;; compile-time changes to `current-reader' are
                     ;; limited to the current compilation unit.
                     (module-define! m 'current-reader (make-fluid))
+
+                    ;; Default to `simple-format', as is the case until
+                    ;; (ice-9 format) is loaded.  This allows
+                    ;; compile-time warnings to be emitted when using
+                    ;; unsupported options.
+                    (module-set! m 'format simple-format)
+
                     m)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 047019049..efe03789f 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (system base syntax)
@@ -1397,6 +1398,36 @@ accurate information is missing from a given `tree-il' element."
          (else
           (warning 'format loc 'wrong-num-args (length args)))))
 
+     (define (check-simple-format-args args loc)
+       ;; Check the arguments to the `simple-format' procedure, which is
+       ;; less capable than that of (ice-9 format).
+
+       (define allowed-chars
+         '(#\A #\S #\a #\s #\~ #\%))
+
+       (define (format-chars fmt)
+         (let loop ((chars  (string->list fmt))
+                    (result '()))
+           (match chars
+             (()
+              (reverse result))
+             ((#\~ opt rest ...)
+              (loop rest (cons opt result)))
+             ((_ rest ...)
+              (loop rest result)))))
+
+       (match args
+         ((port ($ <const> _ (? string? fmt)) _ ...)
+          (let ((opts (format-chars fmt)))
+            (or (every (cut memq <> allowed-chars) opts)
+                (begin
+                  (warning 'format loc 'simple-format fmt
+                           (find (negate (cut memq <> allowed-chars)) opts))
+                  #f))))
+         ((port (($ <const> _ '_) fmt) args ...)
+          (check-simple-format-args `(,port ,fmt ,args) loc))
+         (_ #t)))
+
      (define (resolve-toplevel name)
        (and (module? env)
             (false-if-exception (module-ref env name))))
@@ -1404,9 +1435,19 @@ accurate information is missing from a given `tree-il' element."
      (match x
        (($ <application> src ($ <toplevel-ref> _ name) args)
         (let ((proc (resolve-toplevel name)))
-          (and (or (eq? proc format)
-                   (eq? proc (@ (ice-9 format) format)))
-               (check-format-args args (or src (find pair? locs))))))
+          (if (or (and (eq? proc (@ (guile) simple-format))
+                       (check-simple-format-args args
+                                                 (or src (find pair? locs))))
+                  (eq? proc (@ (ice-9 format) format)))
+              (check-format-args args (or src (find pair? locs))))))
+       (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+        (check-format-args args (or src (find pair? locs))))
+       (($ <application> src ($ <module-ref> _ '(guile)
+                                (or 'format 'simple-format))
+           args)
+        (and (check-simple-format-args args
+                                       (or src (find pair? locs)))
+             (check-format-args args (or src (find pair? locs)))))
        (_ #t))
      #t)
 
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 75e14ea1e..8cf285afd 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -1,6 +1,6 @@
 ;;; User interface messages
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 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
@@ -150,6 +150,10 @@
                         (emit #f "~a to ~a" min max))))
 
                (match rest
+                 (('simple-format fmt opt)
+                  (emit port
+                        "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%"
+                        loc (escape-newlines fmt) opt))
                  (('wrong-format-arg-count fmt min max actual)
                   (emit port
                         "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index bb56c23cd..37cd386fe 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -2187,7 +2187,8 @@
      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format some-port "~&~3_~~ ~\n~12they~%")
+                 (compile '((@ (ice-9 format) format) some-port
+                            "~&~3_~~ ~\n~12they~%")
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
@@ -2214,7 +2215,8 @@
      (pass-if "two missing arguments"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "foo ~10,2f and bar ~S~%")
+                   (compile '((@ (ice-9 format) format) #f
+                              "foo ~10,2f and bar ~S~%")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2245,7 +2247,7 @@
        (pass-if "literals"
         (null? (call-with-warnings
                 (lambda ()
-                  (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
+                  (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
                                     'a 1 3.14)
                            #:opts %opts-w-format
                            #:to 'assembly)))))
@@ -2253,7 +2255,7 @@
        (pass-if "literals with selector"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
+                     (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
                                        1 'dont-ignore-me)
                               #:opts %opts-w-format
                               #:to 'assembly)))))
@@ -2264,7 +2266,7 @@
        (pass-if "escapes (exact count)"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[~a~;~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2274,7 +2276,7 @@
        (pass-if "escapes with selector"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~1[chbouib~;~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2284,7 +2286,7 @@
        (pass-if "escapes, range"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2294,7 +2296,7 @@
        (pass-if "@"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~@[temperature=~d~]")
+                     (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2304,7 +2306,7 @@
        (pass-if "nested"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
+                     (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2314,7 +2316,7 @@
        (pass-if "unterminated"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[unterminated")
+                     (compile '((@ (ice-9 format) format) #f "~[unterminated")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2324,7 +2326,7 @@
        (pass-if "unexpected ~;"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "foo~;bar")
+                     (compile '((@ (ice-9 format) format) #f "foo~;bar")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2334,7 +2336,7 @@
        (pass-if "unexpected ~]"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "foo~]")
+                     (compile '((@ (ice-9 format) format) #f "foo~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2344,7 +2346,7 @@
      (pass-if "~{...~}"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~A ~{~S~} ~A"
+                 (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
                                    'hello '("ladies" "and")
                                    'gentlemen)
                           #:opts %opts-w-format
@@ -2353,7 +2355,7 @@
      (pass-if "~{...~}, too many args"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~{~S~}" 1 2 3)
+                   (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2363,14 +2365,14 @@
      (pass-if "~@{...~}"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~@{~S~}" 1 2 3)
+                 (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "~@{...~}, too few args"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~A ~@{~S~}")
+                   (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2380,7 +2382,7 @@
      (pass-if "unterminated ~{...~}"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~{")
+                   (compile '((@ (ice-9 format) format) #f "~{")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2390,14 +2392,14 @@
      (pass-if "~(...~)"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
+                 (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "~v"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~v_foo")
+                   (compile '((@ (ice-9 format) format) #f "~v_foo")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2406,7 +2408,7 @@
      (pass-if "~v:@y"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~v:@y" 1 123)
+                 (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
@@ -2414,7 +2416,7 @@
      (pass-if "~*"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~2*~a" 'a 'b)
+                   (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2424,14 +2426,14 @@
      (pass-if "~?"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~?" "~d ~d" '(1 2))
+                 (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "complex 1"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f
+                   (compile '((@ (ice-9 format) format) #f
                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
                                      1 2 3 4 5 6)
                             #:opts %opts-w-format
@@ -2443,7 +2445,7 @@
      (pass-if "complex 2"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f
+                   (compile '((@ (ice-9 format) format) #f
                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
                                      1 2 3 4)
                             #:opts %opts-w-format
@@ -2455,7 +2457,7 @@
      (pass-if "complex 3"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
+                   (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2482,4 +2484,31 @@
                  (compile '(let ((format chbouib))
                              (format #t "not ~A a format string"))
                           #:opts %opts-w-format
-                          #:to 'assembly)))))))
+                          #:to 'assembly)))))
+
+     (with-test-prefix "simple-format"
+
+       (pass-if "good"
+         (null? (call-with-warnings
+                 (lambda ()
+                   (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+
+       (pass-if "wrong number of args"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "wrong number")))))
+
+       (pass-if "unsupported"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t "foo ~x~%" 16)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format option"))))))))