From 2c27dd57c7ec4a8168e2668aed380594a99dda8f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 5 Dec 2011 15:43:18 +0100 Subject: [PATCH] warnings written to warning port * libguile/deprecation.c (scm_c_issue_deprecation_warning): * libguile/load.c (auto_compile_catch_handler): (scm_sys_warn_auto_compilation_enabled, scm_primitive_load_path): * module/ice-9/boot-9.scm (warn, %load-announce, duplicate-handlers) (load-in-vicinity): * module/system/base/message.scm (warning): Write to the warning port. (*current-warning-port*): Alias the warning port. --- libguile/deprecation.c | 4 ++-- libguile/load.c | 20 ++++++++++---------- module/ice-9/boot-9.scm | 18 +++++++++--------- module/system/base/message.scm | 12 +++++++----- 4 files changed, 28 insertions(+), 26 deletions(-) diff --git a/libguile/deprecation.c b/libguile/deprecation.c index be5fffc90..08227071f 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -89,8 +89,8 @@ scm_c_issue_deprecation_warning (const char *msg) fprintf (stderr, "%s\n", msg); else { - scm_puts (msg, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); + scm_puts (msg, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); } } } diff --git a/libguile/load.c b/libguile/load.c index 66e3cc40a..a40031898 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -738,18 +738,18 @@ auto_compile_catch_handler (void *data, SCM tag, SCM throw_args) oport = scm_open_output_string (); scm_print_exception (oport, SCM_BOOL_F, tag, throw_args); - scm_puts (";;; WARNING: compilation of ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); - scm_puts (" failed:\n", scm_current_error_port ()); + scm_puts (";;; WARNING: compilation of ", scm_current_warning_port ()); + scm_display (source, scm_current_warning_port ()); + scm_puts (" failed:\n", scm_current_warning_port ()); lines = scm_string_split (scm_get_output_string (oport), SCM_MAKE_CHAR ('\n')); for (; scm_is_pair (lines); lines = scm_cdr (lines)) if (scm_c_string_length (scm_car (lines))) { - scm_puts (";;; ", scm_current_error_port ()); - scm_display (scm_car (lines), scm_current_error_port ()); - scm_newline (scm_current_error_port ()); + scm_puts (";;; ", scm_current_warning_port ()); + scm_display (scm_car (lines), scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); } scm_close_port (oport); @@ -767,7 +767,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl { scm_puts (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n" ";;; or pass the --no-auto-compile argument to disable.\n", - scm_current_error_port ()); + scm_current_warning_port ()); message_shown = 1; } @@ -933,9 +933,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback, &stat_source, &stat_compiled)) { - scm_puts (";;; found fresh local cache at ", scm_current_error_port ()); - scm_display (fallback, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); + scm_puts (";;; found fresh local cache at ", scm_current_warning_port ()); + scm_display (fallback, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); return scm_load_compiled_with_vm (fallback); } } diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 1d25f63df..2659d6cb3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -217,7 +217,7 @@ If there is no handler at all, Guile prints an error and then exits." (define current-warning-port current-error-port) (define (warn . stuff) - (with-output-to-port (current-error-port) + (with-output-to-port (current-warning-port) (lambda () (newline) (display ";;; WARNING ") @@ -1382,7 +1382,7 @@ VALUE." (define (%load-announce file) (if %load-verbosely - (with-output-to-port (current-error-port) + (with-output-to-port (current-warning-port) (lambda () (display ";;; ") (display "loading ") @@ -3393,7 +3393,7 @@ module '(ice-9 q) '(make-q q-length))}." #f)) (define (warn module name int1 val1 int2 val2 var val) - (format (current-error-port) + (format (current-warning-port) "WARNING: ~A: `~A' imported from both ~A and ~A\n" (module-name module) name @@ -3415,7 +3415,7 @@ module '(ice-9 q) '(make-q q-length))}." (define (warn-override-core module name int1 val1 int2 val2 var val) (and (eq? int1 the-scm-module) (begin - (format (current-error-port) + (format (current-warning-port) "WARNING: ~A: imported module ~A overrides core binding `~A'\n" (module-name module) (module-name int2) @@ -3537,13 +3537,13 @@ module '(ice-9 q) '(make-q q-length))}." go-path (begin (if gostat - (format (current-error-port) + (format (current-warning-port) ";;; note: source file ~a\n;;; newer than compiled ~a\n" name go-path)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) - (format (current-error-port) ";;; compiling ~a\n" name) + (format (current-warning-port) ";;; compiling ~a\n" name) (let ((cfn ((module-ref (resolve-interface '(system base compile)) @@ -3551,15 +3551,15 @@ module '(ice-9 q) '(make-q q-length))}." name #:opts %auto-compilation-options #:env (current-module)))) - (format (current-error-port) ";;; compiled ~a\n" cfn) + (format (current-warning-port) ";;; compiled ~a\n" cfn) cfn)) (else #f)))))) (lambda (k . args) - (format (current-error-port) + (format (current-warning-port) ";;; WARNING: compilation of ~a failed:\n" name) (for-each (lambda (s) (if (not (string-null? s)) - (format (current-error-port) ";;; ~a\n" s))) + (format (current-warning-port) ";;; ~a\n" s))) (string-split (call-with-output-string (lambda (port) (print-exception port #f k args))) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index aed35021c..75e14ea1e 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -54,11 +54,13 @@ ;;; Warnings ;;; +;; This name existed before %current-warning-port was introduced, but +;; otherwise it is a deprecated binding. (define *current-warning-port* - ;; The port where warnings are sent. - (make-fluid (current-error-port))) - -(fluid-set! *current-warning-port* (current-error-port)) + ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as + ;; other modules might depend on this being a normal binding and not a + ;; syntax binding. + (parameter-fluid current-warning-port)) (define *current-warning-prefix* ;; Prefix string when emitting a warning. @@ -194,7 +196,7 @@ "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*))) + (port (current-warning-port))) (if (warning-type? wt) (apply (warning-type-printer wt) port (location-string location) -- 2.20.1