summaryrefslogtreecommitdiff
path: root/module/language/tree-il/analyze.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/analyze.scm')
-rw-r--r--module/language/tree-il/analyze.scm49
1 files changed, 45 insertions, 4 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index f75c9f16a..04687a8c9 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)
@@ -1392,7 +1393,7 @@ accurate information is missing from a given `tree-il' element."
((,port ,fmt . ,rest)
(if (and (const? port)
(not (boolean? (const-exp port))))
- (warn 'format loc 'wrong-port (const-exp port)))
+ (warning 'format loc 'wrong-port (const-exp port)))
;; Warn on non-literal format strings, unless they refer to a
;; lexical variable named "fmt".
(if (record-case fmt
@@ -1403,6 +1404,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))))
@@ -1410,9 +1441,19 @@ accurate information is missing from a given `tree-il' element."
(match x
(($ <call> 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))))))
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (check-format-args args (or src (find pair? locs))))
+ (($ <call> 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)