summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-07-31 00:06:59 +0200
committerLudovic Courtès <ludo@gnu.org>2009-07-31 00:49:22 +0200
commit2e4c3227ce1374dd53abd3c7c5797cc64329de91 (patch)
tree2feba0d7095f83b390bf0da5370b1260d0f391fb
parentf4aa0f104b3347c21093b837046022fb7bb6a2ff (diff)
downloadguile-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.am1
-rw-r--r--module/scripts/compile.scm34
-rw-r--r--module/system/base/compile.scm11
-rw-r--r--module/system/base/message.scm102
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