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