diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-02-13 19:13:36 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-02-13 19:13:36 +0100 |
commit | a4060f671073337e9dc5df64398972913bd71a52 (patch) | |
tree | b3db20df35b1697600b4b1a7789ef39fd3b45741 /module | |
parent | eb7a16a9f802524f062ec48cf749da0253a1bbc5 (diff) | |
download | guile-a4060f671073337e9dc5df64398972913bd71a52.tar.gz |
Add `*current-warning-prefix*'.
* module/system/base/message.scm (*current-warning-prefix*): New
variable.
(%warning-types): Honor `*current-warning-prefix*'.
* module/scripts/compile.scm (compile): Use an empty
`*current-warning-prefix*'.
* module/system/repl/common.scm (repl-compile): Likewise.
* test-suite/tests/tree-il.test (call-with-warnings): Likewise.
Diffstat (limited to 'module')
-rw-r--r-- | module/scripts/compile.scm | 11 | ||||
-rw-r--r-- | module/system/base/message.scm | 157 | ||||
-rw-r--r-- | module/system/repl/common.scm | 8 |
3 files changed, 100 insertions, 76 deletions
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 9763d1d6e..f9d6cca99 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -168,11 +168,12 @@ Report bugs to <~A>.~%" (for-each (lambda (file) (format #t "wrote `~A'\n" - (compile-file file - #:output-file output-file - #:from from - #:to to - #:opts compile-opts))) + (with-fluids ((*current-warning-prefix* "")) + (compile-file file + #:output-file output-file + #:from from + #:to to + #:opts compile-opts)))) input-files))) (define main compile) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 62e72740f..95468ca9a 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -1,6 +1,6 @@ ;;; User interface messages -;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011 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 @@ -27,7 +27,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (ice-9 match) - #:export (*current-warning-port* warning + #:export (*current-warning-port* + *current-warning-prefix* + warning warning-type? warning-type-name warning-type-description warning-type-printer lookup-warning-type @@ -58,6 +60,13 @@ (fluid-set! *current-warning-port* (current-error-port)) +(define *current-warning-prefix* + ;; Prefix string when emitting a warning. + (make-fluid)) + +(fluid-set! *current-warning-prefix* ";;; ") + + (define-record-type <warning-type> (make-warning-type name description printer) warning-type? @@ -70,100 +79,112 @@ (map (lambda (args) (apply make-warning-type args)) - `((unsupported-warning ;; a "meta warning" - "warn about unknown warning types" - ,(lambda (port unused name) - (format port "warning: unknown warning type `~A'~%" + (let-syntax ((emit + (lambda (s) + (syntax-case s () + ((_ port fmt args ...) + (string? (syntax->datum #'fmt)) + (with-syntax ((fmt + (string-append "~a" + (syntax->datum + #'fmt)))) + #'(format port fmt + (fluid-ref *current-warning-prefix*) + args ...))))))) + `((unsupported-warning ;; a "meta warning" + "warn about unknown warning types" + ,(lambda (port unused name) + (emit port "warning: unknown warning type `~A'~%" name))) - (unused-variable - "report unused variables" - ,(lambda (port loc name) - (format port "~A: warning: unused variable `~A'~%" + (unused-variable + "report unused variables" + ,(lambda (port loc name) + (emit port "~A: warning: unused variable `~A'~%" loc name))) - (unused-toplevel - "report unused local top-level variables" - ,(lambda (port loc name) - (format port "~A: warning: possibly unused local top-level variable `~A'~%" + (unused-toplevel + "report unused local top-level variables" + ,(lambda (port loc name) + (emit port "~A: warning: possibly unused local top-level variable `~A'~%" loc name))) - (unbound-variable - "report possibly unbound variables" - ,(lambda (port loc name) - (format port "~A: warning: possibly unbound variable `~A'~%" + (unbound-variable + "report possibly unbound variables" + ,(lambda (port loc name) + (emit port "~A: warning: possibly unbound variable `~A'~%" loc name))) - (arity-mismatch - "report procedure arity mismatches (wrong number of arguments)" - ,(lambda (port loc name certain?) - (if certain? - (format port + (arity-mismatch + "report procedure arity mismatches (wrong number of arguments)" + ,(lambda (port loc name certain?) + (if certain? + (emit port "~A: warning: wrong number of arguments to `~A'~%" loc name) - (format port + (emit port "~A: warning: possibly wrong number of arguments to `~A'~%" loc name)))) - (format - "report wrong number of arguments to `format'" - ,(lambda (port loc . rest) - (define (escape-newlines str) - (list->string - (string-fold-right (lambda (c r) - (if (eq? c #\newline) - (append '(#\\ #\n) r) - (cons c r))) - '() - str))) - - (define (range min max) - (cond ((eq? min 'any) - (if (eq? max 'any) - "any number" ;; can't happen - (format #f "up to ~a" max))) - ((eq? max 'any) - (format #f "at least ~a" min)) - ((= min max) (number->string min)) - (else - (format #f "~a to ~a" min max)))) - - (match rest - (('wrong-format-arg-count fmt min max actual) - (format port + (format + "report wrong number of arguments to `format'" + ,(lambda (port loc . rest) + (define (escape-newlines str) + (list->string + (string-fold-right (lambda (c r) + (if (eq? c #\newline) + (append '(#\\ #\n) r) + (cons c r))) + '() + str))) + + (define (range min max) + (cond ((eq? min 'any) + (if (eq? max 'any) + "any number" ;; can't happen + (emit #f "up to ~a" max))) + ((eq? max 'any) + (emit #f "at least ~a" min)) + ((= min max) (number->string min)) + (else + (emit #f "~a to ~a" min max)))) + + (match rest + (('wrong-format-arg-count fmt min max actual) + (emit port "~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~%" + (('syntax-error 'unterminated-iteration fmt) + (emit port "~A: warning: ~S: unterminated iteration~%" loc (escape-newlines fmt))) - (('syntax-error 'unterminated-conditional fmt) - (format port "~A: warning: ~S: unterminated conditional~%" + (('syntax-error 'unterminated-conditional fmt) + (emit port "~A: warning: ~S: unterminated conditional~%" loc (escape-newlines fmt))) - (('syntax-error 'unexpected-semicolon fmt) - (format port "~A: warning: ~S: unexpected `~~;'~%" + (('syntax-error 'unexpected-semicolon fmt) + (emit port "~A: warning: ~S: unexpected `~~;'~%" loc (escape-newlines fmt))) - (('syntax-error 'unexpected-conditional-termination fmt) - (format port "~A: warning: ~S: unexpected `~~]'~%" + (('syntax-error 'unexpected-conditional-termination fmt) + (emit port "~A: warning: ~S: unexpected `~~]'~%" loc (escape-newlines fmt))) - (('wrong-port wrong-port) - (format port + (('wrong-port wrong-port) + (emit port "~A: warning: ~S: wrong port argument~%" loc wrong-port)) - (('wrong-format-string fmt) - (format port + (('wrong-format-string fmt) + (emit port "~A: warning: ~S: wrong format string~%" loc fmt)) - (('non-literal-format-string) - (format port + (('non-literal-format-string) + (emit port "~A: warning: non-literal format string~%" loc)) - (('wrong-num-args count) - (format port + (('wrong-num-args count) + (emit port "~A: warning: wrong number of arguments to `format'~%" loc)) - (else - (format port "~A: `format' warning~%" loc)))))))) + (else + (emit port "~A: `format' warning~%" loc))))))))) (define (lookup-warning-type name) "Return the warning type NAME or `#f' if not found." diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 5405bb8b2..0e7cb6905 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -1,6 +1,6 @@ ;;; Repl common routines -;; Copyright (C) 2001, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008, 2009, 2010, 2011 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 @@ -22,6 +22,7 @@ #:use-module (system base syntax) #:use-module (system base compile) #:use-module (system base language) + #:use-module (system base message) #:use-module (system vm program) #:use-module (ice-9 control) #:use-module (ice-9 history) @@ -158,8 +159,9 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.") (define (repl-compile repl form) (let ((from (repl-language repl)) (opts (repl-compile-options repl))) - (compile form #:from from #:to 'objcode #:opts opts - #:env (current-module)))) + (with-fluids ((*current-warning-prefix* "")) ; XXX: Keep ";;; "? + (compile form #:from from #:to 'objcode #:opts opts + #:env (current-module))))) (define (repl-parse repl form) (let ((parser (language-parser (repl-language repl)))) |