From 60273407f92fdfe36c3ec09decfd92746bbb4f5e Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 26 Jan 2012 00:35:46 +0100 Subject: [PATCH] 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/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. --- module/language/scheme/spec.scm | 9 +++- module/language/tree-il/analyze.scm | 47 +++++++++++++++-- module/system/base/message.scm | 6 ++- test-suite/tests/tree-il.test | 81 ++++++++++++++++++++--------- 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 ($ _ (? 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 (($ _ '_) 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 (($ src ($ _ 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)))))) + (($ src ($ _ '(ice-9 format) 'format) args) + (check-format-args args (or src (find pair? locs)))) + (($ src ($ _ '(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")))))))) -- 2.20.1