mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

warnings written to warning port

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-12-05 15:43:18 +01:00
parent 3972de7675
commit 2c27dd57c7
4 changed files with 28 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/deprecation.c
View file

@ -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 ());
}
}
}

20
libguile/load.c
View file

@ -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);
}
}

18
module/ice-9/boot-9.scm
View file

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

12
module/system/base/message.scm
View file

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