1;;; User interface messages 2 3;; Copyright (C) 2009-2012,2016,2018,2020-2021 Free Software Foundation, Inc. 4 5;;; This library is free software; you can redistribute it and/or modify it 6;;; under the terms of the GNU Lesser General Public License as published by 7;;; the Free Software Foundation; either version 3 of the License, or (at 8;;; your option) any later version. 9;;; 10;;; This library is distributed in the hope that it will be useful, but 11;;; WITHOUT ANY WARRANTY; without even the implied warranty of 12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser 13;;; General Public License for more details. 14;;; 15;;; You should have received a copy of the GNU Lesser General Public License 16;;; along with this program. If not, see <http://www.gnu.org/licenses/>. 17 18;;; Commentary: 19;;; 20;;; This module provide a simple interface to send messages to the user. 21;;; TODO: Internationalize messages. 22;;; 23;;; Code: 24 25(define-module (system base message) 26 #:use-module (srfi srfi-1) 27 #:use-module (srfi srfi-9) 28 #:use-module (ice-9 match) 29 #:export (*current-warning-port* 30 *current-warning-prefix* 31 warning 32 33 warning-type? warning-type-name warning-type-description 34 warning-type-printer lookup-warning-type 35 36 %warning-types)) 37 38 39;;; 40;;; Source location 41;;; 42 43(define (location-string loc) 44 (if (pair? loc) 45 (format #f "~a:~a:~a" 46 (or (assoc-ref loc 'filename) "<stdin>") 47 (1+ (assoc-ref loc 'line)) 48 (assoc-ref loc 'column)) 49 "<unknown-location>")) 50 51 52;;; 53;;; Warnings 54;;; 55 56;; This name existed before %current-warning-port was introduced, but 57;; otherwise it is a deprecated binding. 58(define *current-warning-port* 59 ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as 60 ;; other modules might depend on this being a normal binding and not a 61 ;; syntax binding. 62 (parameter-fluid current-warning-port)) 63 64(define *current-warning-prefix* 65 ;; Prefix string when emitting a warning. 66 (make-fluid ";;; ")) 67 68 69(define-record-type <warning-type> 70 (make-warning-type name description printer) 71 warning-type? 72 (name warning-type-name) 73 (description warning-type-description) 74 (printer warning-type-printer)) 75 76(define %warning-types 77 ;; List of known warning types. 78 (map (lambda (args) 79 (apply make-warning-type args)) 80 81 (let-syntax ((emit 82 (lambda (s) 83 (syntax-case s () 84 ((_ port fmt args ...) 85 (string? (syntax->datum #'fmt)) 86 (with-syntax ((fmt 87 (string-append "~a" 88 (syntax->datum 89 #'fmt)))) 90 #'(format port fmt 91 (fluid-ref *current-warning-prefix*) 92 args ...))))))) 93 `((unsupported-warning ;; a "meta warning" 94 "warn about unknown warning types" 95 ,(lambda (port unused name) 96 (emit port "warning: unknown warning type `~A'~%" 97 name))) 98 99 (unused-variable 100 "report unused variables" 101 ,(lambda (port loc name) 102 (emit port "~A: warning: unused variable `~A'~%" 103 loc name))) 104 105 (unused-toplevel 106 "report unused local top-level variables" 107 ,(lambda (port loc name) 108 (emit port "~A: warning: possibly unused local top-level variable `~A'~%" 109 loc name))) 110 111 (shadowed-toplevel 112 "report shadowed top-level variables" 113 ,(lambda (port loc name previous-loc) 114 (emit port "~A: warning: shadows previous definition of `~A' at ~A~%" 115 loc name 116 (location-string previous-loc)))) 117 118 (unbound-variable 119 "report possibly unbound variables" 120 ,(lambda (port loc name) 121 (emit port "~A: warning: possibly unbound variable `~A'~%" 122 loc name))) 123 124 (macro-use-before-definition 125 "report possibly mis-use of macros before they are defined" 126 ,(lambda (port loc name) 127 (emit port "~A: warning: macro `~A' used before definition~%" 128 loc name))) 129 130 (use-before-definition 131 "report uses of top-levels before they are defined" 132 ,(lambda (port loc name) 133 (emit port "~A: warning: `~A' used before definition~%" 134 loc name))) 135 136 (non-idempotent-definition 137 "report names that can refer to imports on first load, but module definitions on second load" 138 ,(lambda (port loc name) 139 (emit port "~A: warning: non-idempotent binding for `~A'. When first loaded, value for `~A` comes from imported binding, but later module-local definition overrides it; any module reload would capture module-local binding rather than import.~%" 140 loc name name))) 141 142 (arity-mismatch 143 "report procedure arity mismatches (wrong number of arguments)" 144 ,(lambda (port loc name certain?) 145 (if certain? 146 (emit port 147 "~A: warning: wrong number of arguments to `~A'~%" 148 loc name) 149 (emit port 150 "~A: warning: possibly wrong number of arguments to `~A'~%" 151 loc name)))) 152 153 (duplicate-case-datum 154 "report a duplicate datum in a case expression" 155 ,(lambda (port loc datum clause case-expr) 156 (emit port 157 "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%" 158 loc datum clause case-expr))) 159 160 (bad-case-datum 161 "report a case datum that cannot be meaningfully compared using `eqv?'" 162 ,(lambda (port loc datum clause case-expr) 163 (emit port 164 "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%" 165 loc datum clause case-expr))) 166 167 (format 168 "report wrong number of arguments to `format'" 169 ,(lambda (port loc . rest) 170 (define (escape-newlines str) 171 (list->string 172 (string-fold-right (lambda (c r) 173 (if (eq? c #\newline) 174 (append '(#\\ #\n) r) 175 (cons c r))) 176 '() 177 str))) 178 179 (define (range min max) 180 (cond ((eq? min 'any) 181 (if (eq? max 'any) 182 "any number" ;; can't happen 183 (emit #f "up to ~a" max))) 184 ((eq? max 'any) 185 (emit #f "at least ~a" min)) 186 ((= min max) (number->string min)) 187 (else 188 (emit #f "~a to ~a" min max)))) 189 190 (match rest 191 (('simple-format fmt opt) 192 (emit port 193 "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%" 194 loc (escape-newlines fmt) opt)) 195 (('wrong-format-arg-count fmt min max actual) 196 (emit port 197 "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%" 198 loc (escape-newlines fmt) 199 (range min max) actual)) 200 (('syntax-error 'unterminated-iteration fmt) 201 (emit port "~A: warning: ~S: unterminated iteration~%" 202 loc (escape-newlines fmt))) 203 (('syntax-error 'unterminated-conditional fmt) 204 (emit port "~A: warning: ~S: unterminated conditional~%" 205 loc (escape-newlines fmt))) 206 (('syntax-error 'unexpected-semicolon fmt) 207 (emit port "~A: warning: ~S: unexpected `~~;'~%" 208 loc (escape-newlines fmt))) 209 (('syntax-error 'unexpected-conditional-termination fmt) 210 (emit port "~A: warning: ~S: unexpected `~~]'~%" 211 loc (escape-newlines fmt))) 212 (('wrong-port wrong-port) 213 (emit port 214 "~A: warning: ~S: wrong port argument~%" 215 loc wrong-port)) 216 (('wrong-format-string fmt) 217 (emit port 218 "~A: warning: ~S: wrong format string~%" 219 loc fmt)) 220 (('non-literal-format-string) 221 (emit port 222 "~A: warning: non-literal format string~%" 223 loc)) 224 (('wrong-num-args count) 225 (emit port 226 "~A: warning: wrong number of arguments to `format'~%" 227 loc)) 228 (else 229 (emit port "~A: `format' warning~%" loc))))))))) 230 231(define (lookup-warning-type name) 232 "Return the warning type NAME or `#f' if not found." 233 (find (lambda (wt) 234 (eq? name (warning-type-name wt))) 235 %warning-types)) 236 237(define (warning type location . args) 238 "Emit a warning of type TYPE for source location LOCATION (a source 239property alist) using the data in ARGS." 240 (let ((wt (lookup-warning-type type)) 241 (port (current-warning-port))) 242 (if (warning-type? wt) 243 (apply (warning-type-printer wt) 244 port (location-string location) 245 args) 246 (format port "~A: unknown warning type `~A': ~A~%" 247 (location-string location) type args)))) 248