(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))
\f
(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)))
;; 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 "~%"))
\f
(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))
-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'
(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)
(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))
--- /dev/null
+;;; 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))
+
+\f
+;;;
+;;; 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>"))
+
+\f
+;;;
+;;; 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
HCoop / bpt / guile.git / commitdiff