diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index cbb6dd660..8e7e2ef6c 100644 --- 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 ace6503eb..62e72740f 100644 --- 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 0be9aa3b0..2294ef2db 100644 --- 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 ()