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.

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		\

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'
 

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))

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