Subject: bug#70142: closed (Re: bug#70142: [PATCH] Fix error messages containing format strings)

From: [email-masked] (GNU bug Tracking System)
Date: Mon, 06 May 2024 09:44:02 +0000

Your bug report

#70142: [PATCH] Fix error messages containing format strings

which was filed against the guile package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
70142: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=70142
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#70142: [PATCH] Fix error messages containing format strings
From: Ludovic Courtès <[email-masked]>
To: Michael Käppler <[email-masked]>
Cc: [email-masked]
Date: Mon, 06 May 2024 11:42:34 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

Hi Michael,

Michael Käppler <[email-masked]> skribis:

> The reason is that format strings occurring in the message are
> escaped, see `module/ice-9/boot-9.scm`  and
> `module/language/tree-il/primitives.scm`.
>
> So a call of
>
> `(error "Wrong argument: ~a" 42)`
>
> is rendered as
>
> "Wrong argument: ~a 42"
> Some callers did not take this behavior into account.

Good catch, applied.  Thanks!

Ludo’.

Subject: [PATCH] Fix error messages containing format strings
From: Michael Käppler <[email-masked]>
To: [email-masked]
Date: Tue, 2 Apr 2024 09:52:34 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

Hi all,
I recently ran into the issue that some error messages in Guile are not
formatted properly.
As a simple reproducer, fire up a REPL and do

,option on-error 'foo

Which will yield

"While executing meta-command:
Bad on-error value ~a; expected one of ~a foo (debug backtrace report pass)"

The reason is that format strings occurring in the message are
escaped, see `module/ice-9/boot-9.scm`  and
`module/language/tree-il/primitives.scm`.

So a call of

`(error "Wrong argument: ~a" 42)`

is rendered as

"Wrong argument: ~a 42"
Some callers did not take this behavior into account.

Patch attached.

Michael
From fb01f6edc56c35b18b2dbc5b29949716edeae31d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Michael=20K=C3=A4ppler?= <[email-masked]>
Date: Tue, 2 Apr 2024 08:58:52 +0200
Subject: [PATCH] Fix error messages containing format strings

The builtin primitive procedure `error` takes an optional message and
a list of arguments to include into the error message.
These args are formatted with `~S` and appended to the error message, so
that an example call of

`(error "Wrong argument: " 42)`

results in the output

"Wrong argument: 42"

If format strings occur in the message itself, however, they are
escaped. Thus a call like

`(error "Wrong argument: ~a" 42)`

is rendered as

"Wrong argument: ~a 42"

Some callers did not take this behavior into account, leading to
confusing error messages.
Changing the behavior of `error` to be
both backwards-compatible and accept also format strings inside messages
is not straightforward, because it would have to handle escaped `~`
characters as well. Therefore, fix `error` call sites using format
strings to use `format` before calling out to `error`.

The following files are affected:

* module/ice-9/format.scm (format)
* module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface)
* module/oop/goops.scm (make)
* module/srfi/srfi-37.scm (Comment at the beginning of file)
* module/system/base/compile.scm (call-once)
* module/system/repl/command.scm (break, tracepoint)
* module/system/repl/common.scm (repl-default-options)
* module/system/vm/traps.scm (arg-check, trap-at-source-location)

There are a couple of further call sites that were left unchanged,
either because they are using their own `error` procedure:

* module/ice-9/read.scm
* module/ice-9/command-line.scm

or are not referenced from other modules:

* module/system/base/lalr.upstream.scm:
* module/sxml/upstream/assert.scm:
* module/sxml/sxml-match.ss:
---
 module/ice-9/format.scm         |  3 ++-
 module/ice-9/r6rs-libraries.scm | 17 ++++++++++++-----
 module/oop/goops.scm            |  2 +-
 module/srfi/srfi-37.scm         |  4 ++--
 module/system/base/compile.scm  |  2 +-
 module/system/repl/command.scm  |  4 ++--
 module/system/repl/common.scm   |  7 ++++++-
 module/system/vm/traps.scm      |  7 ++++---
 8 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index 01da71e90..e53649866 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -49,7 +49,8 @@
        ((boolean? destination) (current-output-port)) ; boolean but not false
        ((output-port? destination) destination)
        (else
-        (error "format: bad destination `~a'" destination)))))
+        (error
+          (simple-format #f "format: bad destination `~a'" destination))))))
 
   (define %output-col (or (port-column port) 0))
   (define %flush-output? #f)
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index f27b07841..90bfb5451 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -115,8 +115,10 @@
        (for-each (lambda (sym)
                    (module-add! iface sym
                                 (or (module-variable mod sym)
-                                    (error "no binding `~A' in module ~A"
-                                           sym mod)))
+                                    (error (format
+                                             #f
+                                             "no binding `~A' in module ~A"
+                                             sym mod))))
                    (when (hashq-ref (module-replacements mod) sym)
                      (hashq-set! (module-replacements iface) sym #t)))
                  (syntax->datum #'(identifier ...)))
@@ -131,7 +133,7 @@
                                  mod)
        (for-each (lambda (sym)
                    (unless (module-local-variable iface sym)
-                     (error "no binding `~A' in module ~A" sym mod))
+                     (error (format #f "no binding `~A' in module ~A" sym mod)))
                    (module-remove! iface sym))
                  (syntax->datum #'(identifier ...)))
        iface))
@@ -167,7 +169,11 @@
                     (replace? (vector-ref v 1))
                     (var (vector-ref v 2)))
                 (when (module-local-variable iface to)
-                  (error "duplicate binding for `~A' in module ~A" to mod))
+                  (error (format
+                           #f
+                           "duplicate binding for `~A' in module ~A"
+                           to
+                           mod)))
                 (module-add! iface to var)
                 (when replace?
                   (hashq-set! replacements to #t))))
@@ -178,7 +184,8 @@
                   (to (cdar in))
                   (var (module-variable mod from))
                   (replace? (hashq-ref replacements from)))
-             (unless var (error "no binding `~A' in module ~A" from mod))
+             (unless var (error
+                           (format #f "no binding `~A' in module ~A" from mod)))
              (module-remove! iface from)
              (hashq-remove! replacements from)
              (lp (cdr in) (cons (vector to replace? var) out))))))))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index de5e8907d..8ed68694c 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -542,7 +542,7 @@ followed by its associated value.  If @var{l} does not hold a value for
 ;; Boot definition.
 (define (make class . args)
   (unless (memq <slot> (class-precedence-list class))
-    (error "Unsupported class: ~S" class))
+    (error (format #f "Unsupported class: ~S" class)))
   (make-slot class args))
 
 ;; Boot definition.
diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm
index c34b0d083..d6df2bee8 100644
--- a/module/srfi/srfi-37.scm
+++ b/module/srfi/srfi-37.scm
@@ -31,9 +31,9 @@
 ;; 			    (display-and-exit-proc "Foo version 42.0\n"))
 ;; 		    (option '(#\h "help") #f #f
 ;; 			    (display-and-exit-proc
-;; 			     "Usage: foo scheme-file ..."))))
+;; 			     "Usage: foo scheme-file ...\n"))))
 ;; 	    (lambda (opt name arg)
-;; 	      (error "Unrecognized option `~A'" name))
+;; 	      (error (format #f "Unrecognized option `~A'" name)))
 ;; 	    (lambda (op) (load op) (values)))
 ;;
 ;;; Code:
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index a33d012bd..f7e82404e 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -53,7 +53,7 @@
     (dynamic-wind
         (lambda ()
           (when entered
-            (error "thunk may only be entered once: ~a" thunk))
+            (error (format #f "thunk may only be entered once: ~a" thunk)))
           (set! entered #t))
         thunk
         (lambda () #t))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index e5a4d672b..ca7450610 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -672,7 +672,7 @@ Break on calls to PROCEDURE.
 Starts a recursive prompt when PROCEDURE is called."
   (let ((proc (repl-eval repl (repl-parse repl form))))
     (if (not (procedure? proc))
-        (error "Not a procedure: ~a" proc)
+        (error (format #f "Not a procedure: ~a" proc))
         (let ((idx (add-trap-at-procedure-call! proc)))
           (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
 
@@ -783,7 +783,7 @@ A tracepoint will print out the procedure and its arguments, when it is
 called, and its return value(s) when it returns."
   (let ((proc (repl-eval repl (repl-parse repl form))))
     (if (not (procedure? proc))
-        (error "Not a procedure: ~a" proc)
+        (error (format #f "Not a procedure: ~a" proc))
         (let ((idx (add-trace-at-procedure-call! proc)))
           (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))))
 
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 88ef93d3e..a3f2032ba 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -142,7 +142,12 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
          (lambda (x)
            (if (memq x vals)
                x
-               (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
+               (error
+                 (format
+                   #f
+                   "Bad on-error value ~a; expected one of ~a"
+                   x
+                   vals)))))))))
 
 (define %make-repl make-repl)
 (define* (make-repl lang #:optional debug)
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index cd0e13cc9..6c5d1e788 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -76,10 +76,10 @@
   (syntax-rules ()
     ((_ arg predicate? message)
      (if (not (predicate? arg))
-         (error "bad argument ~a: ~a" 'arg message)))
+         (error (format #f "bad argument ~a: ~a" 'arg message))))
     ((_ arg predicate?)
      (if (not (predicate? arg))
-         (error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
+         (error (format #f "bad argument ~a: expected ~a" 'arg 'predicate?))))))
 
 (define (new-disabled-trap enable disable)
   (let ((enabled? #f))
@@ -378,7 +378,8 @@
                                                      current-frame)))
                   procs))
            (if (null? traps)
-               (error "No procedures found at ~a:~a." file user-line)))
+               (error
+                 (format #f "No procedures found at ~a:~a." file user-line))))
          (lambda (frame)
            (for-each (lambda (trap) (trap frame)) traps)
            (set! traps #f)))))))
-- 
2.25.1