Add warnings for obvious syntax errors in format strings.

* module/language/tree-il/analyze.scm (&syntax-error): New variable.
  (format-string-argument-count): Throw to &SYNTAX-ERROR when a syntax
  error in a format string is encountered.
  (format-analysis): Catch &SYNTAX-ERROR and convert as a warning of the
  appropriate type.

* module/system/base/message.scm (%warning-types)[format]: Handle
  `syntax-error' warnings.

* test-suite/tests/tree-il.test
  ("warnings")["conditionals"]("unterminated", "unexpected ~;",
  "unexpected ~]"): New tests.
  ["unterminated ~{...~}"]: New test.

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index cbb6dd6..8e7e2ef 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1201,6 +1201,10 @@ accurate information is missing from a given `tree-il' element."
 ;;; `format' argument analysis.
 ;;;
 
+(define &syntax-error
+  ;; The `throw' key for syntax errors.
+  (gensym "format-string-syntax-error"))
+
 (define (format-string-argument-count fmt)
   ;; Return the minimum and maxium number of arguments that should
   ;; follow format string FMT (or, ahem, a good estimate thereof) or
@@ -1212,7 +1216,7 @@ accurate information is missing from a given `tree-il' element."
     (let loop ((chars  chars)
                (tilde? #f))
       (if (null? chars)
-          chars ;; syntax error?
+          (throw &syntax-error 'unterminated-iteration)
           (if tilde?
               (if (eq? (car chars) end)
                   (cdr chars)
@@ -1240,7 +1244,7 @@ accurate information is missing from a given `tree-il' element."
              (max-count 0))
     (if (null? chars)
         (if end-group
-            (values #f #f) ;; syntax error
+            (throw &syntax-error 'unterminated-conditional)
             (values min-count max-count))
         (case state
           ((tilde)
@@ -1286,19 +1290,21 @@ accurate information is missing from a given `tree-il' element."
                                               (if (null? maxs)
                                                   0
                                                   (apply max maxs))))))
-                              (values #f #f)))))
+                              (values 'any 'any))))) ;; XXX: approximation
                     0 0))
              ((#\;)
-              (loop (cdr chars) 'literal '()
-                    (cons (cons min-count max-count) conditions)
-                    end-group
-                    0 0))
+              (if end-group
+                  (loop (cdr chars) 'literal '()
+                        (cons (cons min-count max-count) conditions)
+                        end-group
+                        0 0)
+                  (throw &syntax-error 'unexpected-semicolon)))
              ((#\])
               (if end-group
                   (end-group (cdr chars)
                              (reverse (cons (cons min-count max-count)
                                             conditions)))
-                  (values #f #f))) ;; syntax error
+                  (throw &syntax-error 'unexpected-conditional-termination)))
              ((#\{)     (if (memq #\@ params)
                             (values min-count 'any)
                             (loop (drop-group (cdr chars) #\})
@@ -1350,13 +1356,17 @@ accurate information is missing from a given `tree-il' element."
           (let ((fmt   (const-exp fmt))
                 (count (length rest)))
             (if (string? fmt)
-                (let-values (((min max)
-                              (format-string-argument-count fmt)))
-                  (and min max
-                       (or (and (or (eq? min 'any) (>= count min))
-                                (or (eq? max 'any) (<= count max)))
-                           (warning 'format loc 'wrong-format-arg-count
-                                    fmt min max count))))
+                (catch &syntax-error
+                  (lambda ()
+                    (let-values (((min max)
+                                  (format-string-argument-count fmt)))
+                      (and min max
+                           (or (and (or (eq? min 'any) (>= count min))
+                                    (or (eq? max 'any) (<= count max)))
+                               (warning 'format loc 'wrong-format-arg-count
+                                        fmt min max count)))))
+                  (lambda (_ key)
+                    (warning 'format loc 'syntax-error key fmt)))
                 (warning 'format loc 'wrong-format-string fmt))))
          ((,port ,fmt . ,rest)
           (warning 'format loc 'non-literal-format-string))

diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index ace6503..62e7274 100644 (file)
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -134,6 +134,18 @@
                         "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
                         loc (escape-newlines fmt)
                         (range min max) actual))
+               (('syntax-error 'unterminated-iteration fmt)
+                (format port "~A: warning: ~S: unterminated iteration~%"
+                        loc (escape-newlines fmt)))
+               (('syntax-error 'unterminated-conditional fmt)
+                (format port "~A: warning: ~S: unterminated conditional~%"
+                        loc (escape-newlines fmt)))
+               (('syntax-error 'unexpected-semicolon fmt)
+                (format port "~A: warning: ~S: unexpected `~~;'~%"
+                        loc (escape-newlines fmt)))
+               (('syntax-error 'unexpected-conditional-termination fmt)
+                (format port "~A: warning: ~S: unexpected `~~]'~%"
+                        loc (escape-newlines fmt)))
                (('wrong-port wrong-port)
                 (format port
                         "~A: warning: ~S: wrong port argument~%"

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 0be9aa3..2294ef2 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1261,13 +1261,35 @@
                 (number? (string-contains (car w)
                                           "expected 2 to 4, got 0")))))
 
-       (pass-if "invalid syntax"
-         ;; Syntax errors should be gracefully handled.
-         (null? (call-with-warnings
-                 (lambda ()
-                   (compile '(format #f "~[unterminated")
-                            #:opts %opts-w-format
-                            #:to 'assembly))))))
+       (pass-if "unterminated"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(format #f "~[unterminated")
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w)
+                                          "unterminated conditional")))))
+
+       (pass-if "unexpected ~;"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(format #f "foo~;bar")
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w)
+                                          "unexpected")))))
+
+       (pass-if "unexpected ~]"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(format #f "foo~]")
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w)
+                                          "unexpected"))))))
 
      (pass-if "~{...~}"
        (null? (call-with-warnings
@@ -1305,6 +1327,16 @@
               (number? (string-contains (car w)
                                         "expected at least 1, got 0")))))
 
+     (pass-if "unterminated ~{...~}"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(format #f "~{")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "unterminated")))))
+
      (pass-if "~(...~)"
        (null? (call-with-warnings
                (lambda ()