mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

Add `*current-warning-prefix*'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2011-02-13 19:13:36 +01:00
parent eb7a16a9f8
commit a4060f6710
4 changed files with 105 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/scripts/compile.scm
View file

@ -168,11 +168,12 @@ Report bugs to <~A>.~%"
(for-each (lambda (file)
(format #t "wrote `~A'\n"
(with-fluids ((*current-warning-prefix* ""))
(compile-file file
#:output-file output-file
#:from from
#:to to
#:opts compile-opts)))
#:opts compile-opts))))
input-files)))
(define main compile)

63
module/system/base/message.scm
View file

@ -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,38 +79,50 @@
(map (lambda (args)
(apply make-warning-type args))
(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)
(format port "warning: unknown warning type `~A'~%"
(emit port "warning: unknown warning type `~A'~%"
name)))
(unused-variable
"report unused variables"
,(lambda (port loc name)
(format port "~A: warning: unused variable `~A'~%"
(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'~%"
(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'~%"
(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
(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))))
@ -121,49 +142,49 @@
(cond ((eq? min 'any)
(if (eq? max 'any)
"any number" ;; can't happen
(format #f "up to ~a" max)))
(emit #f "up to ~a" max)))
((eq? max 'any)
(format #f "at least ~a" min))
(emit #f "at least ~a" min))
((= min max) (number->string min))
(else
(format #f "~a to ~a" min max))))
(emit #f "~a to ~a" min max))))
(match rest
(('wrong-format-arg-count fmt min max actual)
(format port
(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~%"
(emit port "~A: warning: ~S: unterminated iteration~%"
loc (escape-newlines fmt)))
(('syntax-error 'unterminated-conditional fmt)
(format port "~A: warning: ~S: unterminated conditional~%"
(emit port "~A: warning: ~S: unterminated conditional~%"
loc (escape-newlines fmt)))
(('syntax-error 'unexpected-semicolon fmt)
(format port "~A: warning: ~S: unexpected `~~;'~%"
(emit port "~A: warning: ~S: unexpected `~~;'~%"
loc (escape-newlines fmt)))
(('syntax-error 'unexpected-conditional-termination fmt)
(format port "~A: warning: ~S: unexpected `~~]'~%"
(emit port "~A: warning: ~S: unexpected `~~]'~%"
loc (escape-newlines fmt)))
(('wrong-port wrong-port)
(format port
(emit port
"~A: warning: ~S: wrong port argument~%"
loc wrong-port))
(('wrong-format-string fmt)
(format port
(emit port
"~A: warning: ~S: wrong format string~%"
loc fmt))
(('non-literal-format-string)
(format port
(emit port
"~A: warning: non-literal format string~%"
loc))
(('wrong-num-args count)
(format port
(emit port
"~A: warning: wrong number of arguments to `format'~%"
loc))
(else
(format port "~A: `format' warning~%" loc))))))))
(emit port "~A: `format' warning~%" loc)))))))))
(define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found."

6
module/system/repl/common.scm
View file

@ -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)))
(with-fluids ((*current-warning-prefix* "")) ; XXX: Keep ";;; "?
(compile form #:from from #:to 'objcode #:opts opts
#:env (current-module))))
#:env (current-module)))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))

7
test-suite/tests/tree-il.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
;;;; 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
@ -591,8 +591,9 @@
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
(with-fluid* *current-warning-port* port
thunk)
(with-fluids ((*current-warning-port* port)
(*current-warning-prefix* ""))
(thunk))
(let ((warnings (get-output-string port)))
(string-tokenize warnings
(char-set-complement (char-set #\newline))))))