[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-78-g5a
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-78-g5a79300 |
|
Date: |
Sun, 13 Feb 2011 18:22:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=5a79300f8596c4dc3ff71e9faa587531f76798f7
The branch, master has been updated
via 5a79300f8596c4dc3ff71e9faa587531f76798f7 (commit)
via a4060f671073337e9dc5df64398972913bd71a52 (commit)
from eb7a16a9f802524f062ec48cf749da0253a1bbc5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5a79300f8596c4dc3ff71e9faa587531f76798f7
Author: Ludovic Courtès <address@hidden>
Date: Sun Feb 13 19:18:02 2011 +0100
Add `%auto-compilation-options', used by `compile-file' when auto-compiling.
* module/ice-9/boot-9.scm (%auto-compilation-options): New variable.
(load-in-vicinity): Honor it.
* libguile/load.c (kw_opts, sym_compile_file,
sym_auto_compilation_options): New variables.
(do_try_auto_compile): Honor %AUTO-COMPILATION-OPTIONS.
* module/system/repl/common.scm (repl-default-options): Have
`compile-options' default to %AUTO-COMPILATION-OPTIONS.
commit a4060f671073337e9dc5df64398972913bd71a52
Author: Ludovic Courtès <address@hidden>
Date: Sun Feb 13 19:13:36 2011 +0100
Add `*current-warning-prefix*'.
* 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.
-----------------------------------------------------------------------
Summary of changes:
libguile/load.c | 28 ++++++-
module/ice-9/boot-9.scm | 8 ++-
module/scripts/compile.scm | 11 ++--
module/system/base/message.scm | 157 +++++++++++++++++++++++-----------------
module/system/repl/common.scm | 10 ++-
test-suite/tests/tree-il.test | 13 ++--
6 files changed, 139 insertions(+), 88 deletions(-)
diff --git a/libguile/load.c b/libguile/load.c
index 082bebb..c2380b9 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -668,6 +668,10 @@ compiled_is_fresh (SCM full_filename, SCM
compiled_filename)
}
SCM_KEYWORD (kw_env, "env");
+SCM_KEYWORD (kw_opts, "opts");
+
+SCM_SYMBOL (sym_compile_file, "compile-file");
+SCM_SYMBOL (sym_auto_compilation_options, "%auto-compilation-options");
static SCM
do_try_auto_compile (void *data)
@@ -680,14 +684,30 @@ do_try_auto_compile (void *data)
scm_newline (scm_current_error_port ());
comp_mod = scm_c_resolve_module ("system base compile");
- compile_file = scm_module_variable
- (comp_mod, scm_from_latin1_symbol ("compile-file"));
+ compile_file = scm_module_variable (comp_mod, sym_compile_file);
if (scm_is_true (compile_file))
{
/* Auto-compile in the context of the current module. */
- SCM res = scm_call_3 (scm_variable_ref (compile_file), source,
- kw_env, scm_current_module ());
+ SCM res, opts;
+ SCM args[5];
+
+ opts = scm_module_variable (scm_the_root_module (),
+ sym_auto_compilation_options);
+ if (SCM_VARIABLEP (opts))
+ opts = SCM_VARIABLE_REF (opts);
+ else
+ opts = SCM_EOL;
+
+ args[0] = source;
+ args[1] = kw_opts;
+ args[2] = opts;
+ args[3] = kw_env;
+ args[4] = scm_current_module ();
+
+ /* Assume `*current-warning-prefix*' has an appropriate value. */
+ res = scm_call_n (scm_variable_ref (compile_file), args, 5);
+
scm_puts (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 89be440..0f89dce 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3259,6 +3259,10 @@ module '(ice-9 q) '(make-q q-length))}."
;;; source location.
;;;
+(define %auto-compilation-options
+ ;; Default `compile-file' option when auto-compiling.
+ '(#:warnings (unbound-variable arity-mismatch)))
+
(define* (load-in-vicinity dir path #:optional reader)
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
@@ -3303,10 +3307,12 @@ module '(ice-9 q) '(make-q q-length))}."
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
(format (current-error-port) ";;; compiling ~a\n" name)
- (let ((cfn ((module-ref
+ (let ((cfn
+ ((module-ref
(resolve-interface '(system base compile))
'compile-file)
name
+ #:opts %auto-compilation-options
#:env (current-module))))
(format (current-error-port) ";;; compiled ~a\n" cfn)
cfn))
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 9763d1d..f9d6cca 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -168,11 +168,12 @@ Report bugs to <~A>.~%"
(for-each (lambda (file)
(format #t "wrote `~A'\n"
- (compile-file file
- #:output-file output-file
- #:from from
- #:to to
- #:opts compile-opts)))
+ (with-fluids ((*current-warning-prefix* ""))
+ (compile-file file
+ #:output-file output-file
+ #:from from
+ #:to to
+ #:opts compile-opts))))
input-files)))
(define main compile)
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 62e7274..95468ca 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -1,6 +1,6 @@
;;; 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
;;; modify it under the terms of the GNU Lesser General Public
@@ -27,7 +27,9 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#: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-printer lookup-warning-type
@@ -58,6 +60,13 @@
(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>
(make-warning-type name description printer)
warning-type?
@@ -70,100 +79,112 @@
(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'~%"
+ (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"
+ "warn about unknown warning types"
+ ,(lambda (port unused name)
+ (emit port "warning: unknown warning type `~A'~%"
name)))
- (unused-variable
- "report unused variables"
- ,(lambda (port loc name)
- (format port "~A: warning: unused variable `~A'~%"
+ (unused-variable
+ "report unused variables"
+ ,(lambda (port loc name)
+ (emit port "~A: warning: unused variable `~A'~%"
loc name)))
- (unused-toplevel
- "report unused local top-level variables"
- ,(lambda (port loc name)
- (format port "~A: warning: possibly unused local top-level
variable `~A'~%"
+ (unused-toplevel
+ "report unused local top-level variables"
+ ,(lambda (port loc name)
+ (emit port "~A: warning: possibly unused local top-level
variable `~A'~%"
loc name)))
- (unbound-variable
- "report possibly unbound variables"
- ,(lambda (port loc name)
- (format port "~A: warning: possibly unbound variable `~A'~%"
+ (unbound-variable
+ "report possibly unbound variables"
+ ,(lambda (port loc name)
+ (emit port "~A: warning: possibly unbound variable `~A'~%"
loc name)))
- (arity-mismatch
- "report procedure arity mismatches (wrong number of arguments)"
- ,(lambda (port loc name certain?)
- (if certain?
- (format port
+ (arity-mismatch
+ "report procedure arity mismatches (wrong number of arguments)"
+ ,(lambda (port loc name certain?)
+ (if certain?
+ (emit port
"~A: warning: wrong number of arguments to `~A'~%"
loc name)
- (format port
+ (emit port
"~A: warning: possibly wrong number of arguments to
`~A'~%"
loc name))))
- (format
- "report wrong number of arguments to `format'"
- ,(lambda (port loc . rest)
- (define (escape-newlines str)
- (list->string
- (string-fold-right (lambda (c r)
- (if (eq? c #\newline)
- (append '(#\\ #\n) r)
- (cons c r)))
- '()
- str)))
-
- (define (range min max)
- (cond ((eq? min 'any)
- (if (eq? max 'any)
- "any number" ;; can't happen
- (format #f "up to ~a" max)))
- ((eq? max 'any)
- (format #f "at least ~a" min))
- ((= min max) (number->string min))
- (else
- (format #f "~a to ~a" min max))))
-
- (match rest
- (('wrong-format-arg-count fmt min max actual)
- (format port
+ (format
+ "report wrong number of arguments to `format'"
+ ,(lambda (port loc . rest)
+ (define (escape-newlines str)
+ (list->string
+ (string-fold-right (lambda (c r)
+ (if (eq? c #\newline)
+ (append '(#\\ #\n) r)
+ (cons c r)))
+ '()
+ str)))
+
+ (define (range min max)
+ (cond ((eq? min 'any)
+ (if (eq? max 'any)
+ "any number" ;; can't happen
+ (emit #f "up to ~a" max)))
+ ((eq? max 'any)
+ (emit #f "at least ~a" min))
+ ((= min max) (number->string min))
+ (else
+ (emit #f "~a to ~a" min max))))
+
+ (match rest
+ (('wrong-format-arg-count fmt min max actual)
+ (emit port
"~A: warning: ~S: wrong number of `format' arguments:
expected ~A, got ~A~%"
loc (escape-newlines fmt)
(range min max) actual))
- (('syntax-error 'unterminated-iteration fmt)
- (format port "~A: warning: ~S: unterminated iteration~%"
+ (('syntax-error 'unterminated-iteration fmt)
+ (emit port "~A: warning: ~S: unterminated iteration~%"
loc (escape-newlines fmt)))
- (('syntax-error 'unterminated-conditional fmt)
- (format port "~A: warning: ~S: unterminated conditional~%"
+ (('syntax-error 'unterminated-conditional fmt)
+ (emit port "~A: warning: ~S: unterminated conditional~%"
loc (escape-newlines fmt)))
- (('syntax-error 'unexpected-semicolon fmt)
- (format port "~A: warning: ~S: unexpected `~~;'~%"
+ (('syntax-error 'unexpected-semicolon fmt)
+ (emit port "~A: warning: ~S: unexpected `~~;'~%"
loc (escape-newlines fmt)))
- (('syntax-error 'unexpected-conditional-termination fmt)
- (format port "~A: warning: ~S: unexpected `~~]'~%"
+ (('syntax-error 'unexpected-conditional-termination fmt)
+ (emit port "~A: warning: ~S: unexpected `~~]'~%"
loc (escape-newlines fmt)))
- (('wrong-port wrong-port)
- (format port
+ (('wrong-port wrong-port)
+ (emit port
"~A: warning: ~S: wrong port argument~%"
loc wrong-port))
- (('wrong-format-string fmt)
- (format port
+ (('wrong-format-string fmt)
+ (emit port
"~A: warning: ~S: wrong format string~%"
loc fmt))
- (('non-literal-format-string)
- (format port
+ (('non-literal-format-string)
+ (emit port
"~A: warning: non-literal format string~%"
loc))
- (('wrong-num-args count)
- (format port
+ (('wrong-num-args count)
+ (emit port
"~A: warning: wrong number of arguments to `format'~%"
loc))
- (else
- (format port "~A: `format' warning~%" loc))))))))
+ (else
+ (emit port "~A: `format' warning~%" loc)))))))))
(define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found."
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 5405bb8..70232ab 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,6 @@
;;; 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
;;; modify it under the terms of the GNU Lesser General Public
@@ -22,6 +22,7 @@
#:use-module (system base syntax)
#:use-module (system base compile)
#:use-module (system base language)
+ #:use-module (system base message)
#:use-module (system vm program)
#:use-module (ice-9 control)
#:use-module (ice-9 history)
@@ -106,7 +107,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(define repl-default-options
(copy-tree
- `((compile-options (#:warnings (unbound-variable arity-mismatch)) #f)
+ `((compile-options ,%auto-compilation-options #f)
(trace #f #f)
(interp #f #f)
(prompt #f ,(lambda (prompt)
@@ -158,8 +159,9 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(define (repl-compile repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (compile form #:from from #:to 'objcode #:opts opts
- #:env (current-module))))
+ (with-fluids ((*current-warning-prefix* "")) ; XXX: Keep ";;; "?
+ (compile form #:from from #:to 'objcode #:opts opts
+ #:env (current-module)))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index e28506f..76c825d 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,18 +1,18 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <address@hidden> --- 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
;;;; 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
@@ -591,8 +591,9 @@
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
- (with-fluid* *current-warning-port* port
- thunk)
+ (with-fluids ((*current-warning-port* port)
+ (*current-warning-prefix* ""))
+ (thunk))
(let ((warnings (get-output-string port)))
(string-tokenize warnings
(char-set-complement (char-set #\newline))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-15-78-g5a79300,
Ludovic Courtès <=