diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-07-31 00:06:59 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-07-31 00:49:22 +0200 |
commit | 2e4c3227ce1374dd53abd3c7c5797cc64329de91 (patch) | |
tree | 2feba0d7095f83b390bf0da5370b1260d0f391fb | |
parent | f4aa0f104b3347c21093b837046022fb7bb6a2ff (diff) | |
download | guile-2e4c3227ce1374dd53abd3c7c5797cc64329de91.tar.gz |
Add `(system base message)', a simple warning framework.
* module/Makefile.am (SOURCES): Add `system/base/message.scm'.
* module/scripts/compile.scm (%options): Add `--warn'.
(parse-args): Update default value for `warnings'.
(show-warning-help): New procedure.
(compile)[compile-opts]: Add `#:warnings'.
Update help message.
* module/system/base/compile.scm (compile): Sanity-check the requested
warnings.
* module/system/base/message.scm: New file.
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/scripts/compile.scm | 34 | ||||
-rw-r--r-- | module/system/base/compile.scm | 11 | ||||
-rw-r--r-- | module/system/base/message.scm | 102 |
4 files changed, 146 insertions, 2 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index a904a8f8e..2971fc6b5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -34,6 +34,7 @@ SOURCES = \ ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ + system/base/message.scm \ \ language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 311e35bad..89d35bcb5 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -30,9 +30,11 @@ (define-module (scripts compile) #:use-module ((system base compile) #:select (compile-file)) + #:use-module (system base message) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:use-module (srfi srfi-37) + #:use-module (ice-9 format) #:export (compile)) @@ -58,6 +60,17 @@ (fail "`-o' option cannot be specified more than once") (alist-cons 'output-file arg result)))) + (option '(#\W "warn") #t #f + (lambda (opt name arg result) + (if (string=? arg "help") + (begin + (show-warning-help) + (exit 0)) + (let ((warnings (assoc-ref result 'warnings))) + (alist-cons 'warnings + (cons (string->symbol arg) warnings) + (alist-delete 'warnings result)))))) + (option '(#\O "optimize") #f #f (lambda (opt name arg result) (alist-cons 'optimize? #t result))) @@ -86,13 +99,27 @@ options." ;; default option values '((input-files) - (load-path)))) + (load-path) + (warnings unsupported-warning)))) + +(define (show-warning-help) + (format #t "The available warning types are:~%~%") + (for-each (lambda (wt) + (format #t " ~22A ~A~%" + (format #f "`~A'" (warning-type-name wt)) + (warning-type-description wt))) + %warning-types) + (format #t "~%")) (define (compile . args) (let* ((options (parse-args args)) (help? (assoc-ref options 'help?)) - (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '())) + (compile-opts (let ((o `(#:warnings + ,(assoc-ref options 'warnings)))) + (if (assoc-ref options 'optimize?) + (cons #:O o) + o))) (from (or (assoc-ref options 'from) 'scheme)) (to (or (assoc-ref options 'to) 'objcode)) (input-files (assoc-ref options 'input-files)) @@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object. -L, --load-path=DIR add DIR to the front of the module load path -o, --output=OFILE write output to OFILE + -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help' + for a list of available warnings + -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `objcode' diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7e26609b9..8470f39e2 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -21,6 +21,7 @@ (define-module (system base compile) #:use-module (system base syntax) #:use-module (system base language) + #:use-module (system base message) #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho #:use-module (ice-9 regex) #:use-module (ice-9 optargs) @@ -213,6 +214,16 @@ (from (current-language)) (to 'value) (opts '())) + + (let ((warnings (memq #:warnings opts))) + (if (pair? warnings) + (let ((warnings (cadr warnings))) + ;; Sanity-check the requested warnings. + (for-each (lambda (w) + (or (lookup-warning-type w) + (warning 'unsupported-warning #f w))) + warnings)))) + (receive (exp env cenv) (compile-fold (compile-passes from to opts) x env opts) exp)) diff --git a/module/system/base/message.scm b/module/system/base/message.scm new file mode 100644 index 000000000..6b68c5639 --- /dev/null +++ b/module/system/base/message.scm @@ -0,0 +1,102 @@ +;;; User interface messages + +;; Copyright (C) 2009 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 +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This module provide a simple interface to send messages to the user. +;;; TODO: Internationalize messages. +;;; +;;; Code: + +(define-module (system base message) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (*current-warning-port* warning + + warning-type? warning-type-name warning-type-description + warning-type-printer lookup-warning-type + + %warning-types)) + + +;;; +;;; Source location +;;; + +(define (location-string loc) + (if (pair? loc) + (format #f "~a:~a:~a" + (or (assoc-ref loc 'filename) "<stdin>") + (1+ (assoc-ref loc 'line)) + (assoc-ref loc 'column)) + "<unknown-location>")) + + +;;; +;;; Warnings +;;; + +(define *current-warning-port* + ;; The port where warnings are sent. + (make-fluid)) + +(fluid-set! *current-warning-port* (current-error-port)) + +(define-record-type <warning-type> + (make-warning-type name description printer) + warning-type? + (name warning-type-name) + (description warning-type-description) + (printer warning-type-printer)) + +(define %warning-types + ;; List of know warning types. + (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'~%" + name))) + + (unused-variable + "report unused variables" + ,(lambda (port loc name) + (format port "~A: warning: unused variable `~A'~%" + loc name)))))) + +(define (lookup-warning-type name) + "Return the warning type NAME or `#f' if not found." + (find (lambda (wt) + (eq? name (warning-type-name wt))) + %warning-types)) + +(define (warning type location . args) + "Emit a warning of type TYPE for source location LOCATION (a source +property alist) using the data in ARGS." + (let ((wt (lookup-warning-type type)) + (port (fluid-ref *current-warning-port*))) + (if (warning-type? wt) + (apply (warning-type-printer wt) + port (location-string location) + args) + (format port "~A: unknown warning type `~A': ~A~%" + (location-string location) type args)))) + +;;; message.scm ends here |