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

From fb01f6edc56c35b18b2dbc5b29949716edeae31d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Michael=20K=C3=A4ppler?= <[email protected]>
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