mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +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) (for-each (lambda (file)
(format #t "wrote `~A'\n" (format #t "wrote `~A'\n"
(with-fluids ((*current-warning-prefix* ""))
(compile-file file (compile-file file
#:output-file output-file #:output-file output-file
#:from from #:from from
#:to to #:to to
#:opts compile-opts))) #:opts compile-opts))))
input-files))) input-files)))
(define main compile) (define main compile)

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

@ -1,6 +1,6 @@
;;; User interface messages ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -27,7 +27,9 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (ice-9 match) #: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? warning-type-name warning-type-description
warning-type-printer lookup-warning-type warning-type-printer lookup-warning-type
@ -58,6 +60,13 @@
(fluid-set! *current-warning-port* (current-error-port)) (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> (define-record-type <warning-type>
(make-warning-type name description printer) (make-warning-type name description printer)
warning-type? warning-type?
@ -70,38 +79,50 @@
(map (lambda (args) (map (lambda (args)
(apply make-warning-type 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" `((unsupported-warning ;; a "meta warning"
"warn about unknown warning types" "warn about unknown warning types"
,(lambda (port unused name) ,(lambda (port unused name)
(format port "warning: unknown warning type `~A'~%" (emit port "warning: unknown warning type `~A'~%"
name))) name)))
(unused-variable (unused-variable
"report unused variables" "report unused variables"
,(lambda (port loc name) ,(lambda (port loc name)
(format port "~A: warning: unused variable `~A'~%" (emit port "~A: warning: unused variable `~A'~%"
loc name))) loc name)))
(unused-toplevel (unused-toplevel
"report unused local top-level variables" "report unused local top-level variables"
,(lambda (port loc name) ,(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))) loc name)))
(unbound-variable (unbound-variable
"report possibly unbound variables" "report possibly unbound variables"
,(lambda (port loc name) ,(lambda (port loc name)
(format port "~A: warning: possibly unbound variable `~A'~%" (emit port "~A: warning: possibly unbound variable `~A'~%"
loc name))) loc name)))
(arity-mismatch (arity-mismatch
"report procedure arity mismatches (wrong number of arguments)" "report procedure arity mismatches (wrong number of arguments)"
,(lambda (port loc name certain?) ,(lambda (port loc name certain?)
(if certain? (if certain?
(format port (emit port
"~A: warning: wrong number of arguments to `~A'~%" "~A: warning: wrong number of arguments to `~A'~%"
loc name) loc name)
(format port (emit port
"~A: warning: possibly wrong number of arguments to `~A'~%" "~A: warning: possibly wrong number of arguments to `~A'~%"
loc name)))) loc name))))
@ -121,49 +142,49 @@
(cond ((eq? min 'any) (cond ((eq? min 'any)
(if (eq? max 'any) (if (eq? max 'any)
"any number" ;; can't happen "any number" ;; can't happen
(format #f "up to ~a" max))) (emit #f "up to ~a" max)))
((eq? max 'any) ((eq? max 'any)
(format #f "at least ~a" min)) (emit #f "at least ~a" min))
((= min max) (number->string min)) ((= min max) (number->string min))
(else (else
(format #f "~a to ~a" min max)))) (emit #f "~a to ~a" min max))))
(match rest (match rest
(('wrong-format-arg-count fmt min max actual) (('wrong-format-arg-count fmt min max actual)
(format port (emit port
"~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%" "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
loc (escape-newlines fmt) loc (escape-newlines fmt)
(range min max) actual)) (range min max) actual))
(('syntax-error 'unterminated-iteration fmt) (('syntax-error 'unterminated-iteration fmt)
(format port "~A: warning: ~S: unterminated iteration~%" (emit port "~A: warning: ~S: unterminated iteration~%"
loc (escape-newlines fmt))) loc (escape-newlines fmt)))
(('syntax-error 'unterminated-conditional fmt) (('syntax-error 'unterminated-conditional fmt)
(format port "~A: warning: ~S: unterminated conditional~%" (emit port "~A: warning: ~S: unterminated conditional~%"
loc (escape-newlines fmt))) loc (escape-newlines fmt)))
(('syntax-error 'unexpected-semicolon fmt) (('syntax-error 'unexpected-semicolon fmt)
(format port "~A: warning: ~S: unexpected `~~;'~%" (emit port "~A: warning: ~S: unexpected `~~;'~%"
loc (escape-newlines fmt))) loc (escape-newlines fmt)))
(('syntax-error 'unexpected-conditional-termination fmt) (('syntax-error 'unexpected-conditional-termination fmt)
(format port "~A: warning: ~S: unexpected `~~]'~%" (emit port "~A: warning: ~S: unexpected `~~]'~%"
loc (escape-newlines fmt))) loc (escape-newlines fmt)))
(('wrong-port wrong-port) (('wrong-port wrong-port)
(format port (emit port
"~A: warning: ~S: wrong port argument~%" "~A: warning: ~S: wrong port argument~%"
loc wrong-port)) loc wrong-port))
(('wrong-format-string fmt) (('wrong-format-string fmt)
(format port (emit port
"~A: warning: ~S: wrong format string~%" "~A: warning: ~S: wrong format string~%"
loc fmt)) loc fmt))
(('non-literal-format-string) (('non-literal-format-string)
(format port (emit port
"~A: warning: non-literal format string~%" "~A: warning: non-literal format string~%"
loc)) loc))
(('wrong-num-args count) (('wrong-num-args count)
(format port (emit port
"~A: warning: wrong number of arguments to `format'~%" "~A: warning: wrong number of arguments to `format'~%"
loc)) loc))
(else (else
(format port "~A: `format' warning~%" loc)))))))) (emit port "~A: `format' warning~%" loc)))))))))
(define (lookup-warning-type name) (define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found." "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 ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -22,6 +22,7 @@
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (system base compile) #:use-module (system base compile)
#:use-module (system base language) #:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm program) #:use-module (system vm program)
#:use-module (ice-9 control) #:use-module (ice-9 control)
#:use-module (ice-9 history) #: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) (define (repl-compile repl form)
(let ((from (repl-language repl)) (let ((from (repl-language repl))
(opts (repl-compile-options repl))) (opts (repl-compile-options repl)))
(with-fluids ((*current-warning-prefix* "")) ; XXX: Keep ";;; "?
(compile form #:from from #:to 'objcode #:opts opts (compile form #:from from #:to 'objcode #:opts opts
#:env (current-module)))) #:env (current-module)))))
(define (repl-parse repl form) (define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl)))) (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 -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -591,8 +591,9 @@
(define (call-with-warnings thunk) (define (call-with-warnings thunk)
(let ((port (open-output-string))) (let ((port (open-output-string)))
(with-fluid* *current-warning-port* port (with-fluids ((*current-warning-port* port)
thunk) (*current-warning-prefix* ""))
(thunk))
(let ((warnings (get-output-string port))) (let ((warnings (get-output-string port)))
(string-tokenize warnings (string-tokenize warnings
(char-set-complement (char-set #\newline)))))) (char-set-complement (char-set #\newline))))))