Re: How can I tell guile to shut up? ;)

[Andy Wingo <wingo@pobox.com>]

[-- Attachment #1: Type: text/plain, Size: 2018 bytes --]

Hi,

On Thu 31 Mar 2011 13:11, Andy Wingo <wingo@pobox.com> writes:

> On Wed 02 Mar 2011 09:22, "Juhani Viheräkoski" <moonshine@kapsi.fi> writes:
>
>> $ ./test-script
>> ;;; note: source file /home/misty/moonshine/yarg/scripts/./race
>> ;;;       newer than compiled
>> /home/misty/.cache/guile/ccache/2.0-LE-4-2.0/home/misty/moonshine/yarg/scripts/test-script.go
>> ;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
>> ;;;       or pass the --no-auto-compile argument to disable.
>> ;;; compiling /home/misty/moonshine/yarg/scripts/./test-script
>> ;;; compiled
>> /home/misty/.cache/guile/ccache/2.0-LE-4-2.0/home/misty/moonshine/yarg/scripts/test-script.go
>
>> It seems there is no option to disable these annoying messages in guile
>> 2.0. I do scripts using guile and I would appreciate not getting these
>> messages that interfere with other output. It is possible to use
>> 2>/dev/null but what would I do if my script would output error messages
>> (as it will probably do at some point)?
>
> I entirely agree that it's a problem.  By default, running a Guile
> script should not cause Guile itself to print anything, to any port.
>
> These messages are useful at times, but they were more useful last year
> when compilation didn't work as well as it does now, and they could
> probably be pared down a bit.
[...]
>
>> My suggestion is to add option --quiet to guile.
>
> Hmm.  I think prefer adding -Wfoo, for warnings, like GCC does.  It's
> not getopt-long compatible, but we already have -ds.  For other
> informational messages, it does seem that we need something like
> --quiet, or --verbosity=..., or something.  Not quite sure what that
> is.  I've copied guile-devel on this mail to see if anyone else has
> opinions on this.

After some thinking, the base thing to do is just to add a warning port,
and make warnings (non-fatal informative messages) write to that port.
I have done this in the attached patches.  Any objections?

Andy


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-add-current-warning-port.patch --]
[-- Type: text/x-diff, Size: 3935 bytes --]

From cf289add3ef2144b1341f6f8afe06931d6007721 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 28 Jun 2011 23:24:43 +0200
Subject: [PATCH 1/2] add current-warning-port

* libguile/ports.h:
* libguile/ports.c (scm_current_warning_port)
  (scm_set_current_warning_port): New functions, wrapping the Scheme
  ones.

* module/ice-9/boot-9.scm (current-warning-port)
  (set-current-warning-port): New functions, defining a port for
  warnings.
  (%current-warning-port): New public fluid.  A good idea or not?  We
  commit, you decide!
---
 libguile/ports.c        |   24 ++++++++++++++++++++++++
 libguile/ports.h        |    2 ++
 module/ice-9/boot-9.scm |   27 +++++++++++++++++++++++++++
 3 files changed, 53 insertions(+), 0 deletions(-)

diff --git a/libguile/ports.c b/libguile/ports.c
index 6bb9610..be91b3e 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -412,6 +412,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_current_warning_port (void)
+{
+  static SCM cwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (cwp_var))
+    cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+  
+  return scm_call_0 (scm_variable_ref (cwp_var));
+}
+
 SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
 	    (),
 	    "Return the current-load-port.\n"
@@ -466,6 +477,19 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+
+SCM
+scm_set_current_warning_port (SCM port)
+{
+  static SCM scwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (scwp_var))
+    scwp_var = scm_c_private_lookup ("guile", "set-current-warning-port");
+  
+  return scm_call_1 (scm_variable_ref (scwp_var), port);
+}
+
+
 void
 scm_dynwind_current_input_port (SCM port)
 #define FUNC_NAME NULL
diff --git a/libguile/ports.h b/libguile/ports.h
index 6a669b6..fcf1424 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -247,10 +247,12 @@ SCM_API SCM scm_drain_input (SCM port);
 SCM_API SCM scm_current_input_port (void);
 SCM_API SCM scm_current_output_port (void);
 SCM_API SCM scm_current_error_port (void);
+SCM_API SCM scm_current_warning_port (void);
 SCM_API SCM scm_current_load_port (void);
 SCM_API SCM scm_set_current_input_port (SCM port);
 SCM_API SCM scm_set_current_output_port (SCM port);
 SCM_API SCM scm_set_current_error_port (SCM port);
+SCM_API SCM scm_set_current_warning_port (SCM port);
 SCM_API void scm_dynwind_current_input_port (SCM port);
 SCM_API void scm_dynwind_current_output_port (SCM port);
 SCM_API void scm_dynwind_current_error_port (SCM port);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70b9f7..f07094c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -227,6 +227,8 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)
 
 (define (warn . stuff)
   (with-output-to-port (current-error-port)
@@ -665,6 +667,31 @@ If there is no handler at all, Guile prints an error and then exits."
 
 
 \f
+;;;
+;;; Warnings.
+;;;
+
+;; Here it would be better to use mutable parameters or something, to
+;; avoid exposing the fluid as a binding.
+;;
+(define %current-warning-port (make-fluid))
+
+;; Instead of initializing %current-warning-port to
+;; (current-error-port), let's be sloppy and leave current-warning-port
+;; dynamically scoped, defaulting to (current-error-port).  This lets
+;; (with-error-to-port ...) redirect warnings, at least in the default
+;; setup.  Is it bad idea?  Let us know!
+;;
+(define (current-warning-port)
+  (or (fluid-ref %current-warning-port) (current-error-port)))
+
+(define (set-current-warning-port port)
+  (let ((old (current-warning-port)))
+    (fluid-set! %current-warning-port port)
+    old))
+
+
+\f
 
 ;;;
 ;;; Extensible exception printing.
-- 
1.7.5.4


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-warnings-written-to-warning-port.patch --]
[-- Type: text/x-diff, Size: 8126 bytes --]

From b2ca6679ecc0304a2fbc0d758ae93fb54bc2782c Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 28 Jun 2011 23:43:14 +0200
Subject: [PATCH 2/2] 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 |   10 ++++------
 4 files changed, 25 insertions(+), 27 deletions(-)

diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index be5fffc..0822707 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 b06fd77..9f995be 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -741,18 +741,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);
@@ -770,7 +770,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;
     }
 
@@ -891,9 +891,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
           && compiled_is_fresh (full_filename, fallback))
         {
-          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 f07094c..0cdd851 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -231,7 +231,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 ")
@@ -1429,7 +1429,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 ")
@@ -3380,7 +3380,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
@@ -3402,7 +3402,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)
@@ -3514,13 +3514,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))
@@ -3528,15 +3528,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 95468ca..84d6c41 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -54,11 +54,9 @@
 ;;; Warnings
 ;;;
 
-(define *current-warning-port*
-  ;; The port where warnings are sent.
-  (make-fluid))
-
-(fluid-set! *current-warning-port* (current-error-port))
+;; This name existed before %current-warning-port was introduced, but
+;; otherwise it is a deprecated binding.
+(define *current-warning-port* %current-warning-port)
 
 (define *current-warning-prefix*
   ;; Prefix string when emitting a warning.
@@ -196,7 +194,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)
-- 
1.7.5.4


[-- Attachment #4: Type: text/plain, Size: 25 bytes --]

-- 
http://wingolog.org/