[Guile-commits] 01/01: (wip) give a handle into format used in exceptions

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 8d109f9174f915b5cc37007771a13048dd428317
Author: Daniel Llorens <address@hidden>
Date:   Fri Nov 22 12:47:39 2019 +0100

    (wip) give a handle into format used in exceptions
---
 module/ice-9/boot-9.scm | 90 ++++++++++++++++++++++++-------------------------
 1 file changed, 45 insertions(+), 45 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d893692..3a30206 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -6,12 +6,12 @@
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
@@ -321,7 +321,7 @@ If returning early, return the return value of F."
 
 ;; let format alias simple-format until the more complete version is loaded
 
-(define format simple-format)
+(define exception-format simple-format)
 
 ;; this is scheme wrapping the C code so the final pred call is a tail call,
 ;; per SRFI-13 spec
@@ -989,7 +989,7 @@ VALUE."
         (let lp ((i 0))
           (if (< i n)
               (cons (datum->syntax
-                     x 
+                     x
                      (string->symbol
                       (string (integer->char (+ (char->integer #\a) i)))))
                     (lp (1+ i)))
@@ -1014,7 +1014,7 @@ VALUE."
                 (if (= (length args) nfields)
                     (apply make-struct/no-tail rtd args)
                     (scm-error 'wrong-number-of-args
-                               (format #f "make-~a" type-name)
+                               (exception-format #f "make-~a" type-name)
                                "Wrong number of arguments" '() #f)))))))))
 
   (define (default-record-printer s p)
@@ -1821,8 +1821,8 @@ non-locally, that exit determines the continuation."
           (let ((filename (or (cadr source) "<unnamed port>"))
                 (line (caddr source))
                 (col (cdddr source)))
-            (format port "~a:~a:~a: " filename (1+ line) col))
-          (format port "ERROR: "))))
+            (exception-format port "~a:~a:~a: " filename (1+ line) col))
+          (exception-format port "ERROR: "))))
 
   (set! set-exception-printer!
         (lambda (key proc)
@@ -1831,7 +1831,7 @@ non-locally, that exit determines the continuation."
   (set! print-exception
         (lambda (port frame key args)
           (define (default-printer)
-            (format port "Throw to key `~a' with args `~s'." key args))
+            (exception-format port "Throw to key `~a' with args `~s'." key 
args))
 
           (when frame
             (print-location frame port)
@@ -1840,7 +1840,7 @@ non-locally, that exit determines the continuation."
                           (lambda () (frame-procedure-name frame))
                           (lambda _ #f))))
               (when name
-                (format port "In procedure ~a:\n" name))))
+                (exception-format port "In procedure ~a:\n" name))))
 
           (catch #t
             (lambda ()
@@ -1849,7 +1849,7 @@ non-locally, that exit determines the continuation."
                     (printer port key args default-printer)
                     (default-printer))))
             (lambda (k . args)
-              (format port "Error while printing exception.")))
+              (exception-format port "Error while printing exception.")))
           (newline port)
           (force-output port))))
 
@@ -1863,7 +1863,7 @@ non-locally, that exit determines the continuation."
     (apply (case-lambda
              ((subr msg args . rest)
               (if subr
-                  (format port "In procedure ~a: " subr))
+                  (exception-format port "In procedure ~a: " subr))
               (apply format port msg (or args '())))
              (_ (default-printer)))
            args))
@@ -1871,30 +1871,30 @@ non-locally, that exit determines the continuation."
   (define (syntax-error-printer port key args default-printer)
     (apply (case-lambda
              ((who what where form subform . extra)
-              (format port "Syntax error:\n")
+              (exception-format port "Syntax error:\n")
               (if where
                   (let ((file (or (assq-ref where 'filename) "unknown file"))
                         (line (and=> (assq-ref where 'line) 1+))
                         (col (assq-ref where 'column)))
-                    (format port "~a:~a:~a: " file line col))
-                  (format port "unknown location: "))
+                    (exception-format port "~a:~a:~a: " file line col))
+                  (exception-format port "unknown location: "))
               (if who
-                  (format port "~a: " who))
-              (format port "~a" what)
+                  (exception-format port "~a: " who))
+              (exception-format port "~a" what)
               (if subform
-                  (format port " in subform ~s of ~s" subform form)
+                  (exception-format port " in subform ~s of ~s" subform form)
                   (if form
-                      (format port " in form ~s" form))))
+                      (exception-format port " in form ~s" form))))
              (_ (default-printer)))
            args))
 
   (define (keyword-error-printer port key args default-printer)
     (let ((message (cadr args))
           (faulty  (car (cadddr args)))) ; I won't do it again, I promise.
-      (format port "~a: ~s" message faulty)))
+      (exception-format port "~a: ~s" message faulty)))
 
   (define (getaddrinfo-error-printer port key args default-printer)
-    (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+    (exception-format port "In procedure getaddrinfo: ~a" (gai-strerror (car 
args))))
 
   (set-exception-printer! 'goops-error scm-error-printer)
   (set-exception-printer! 'host-not-found scm-error-printer)
@@ -2108,11 +2108,11 @@ non-locally, that exit determines the continuation."
        (lambda (key . args)
          (for-each (lambda (s)
                      (if (not (string-null? s))
-                         (format (current-warning-port) ";;; ~a\n" s)))
+                         (exception-format (current-warning-port) ";;; ~a\n" 
s)))
                    (string-split
                     (call-with-output-string
                      (lambda (port)
-                       (format port template arg ...)
+                       (exception-format port template arg ...)
                        (print-exception port #f key args)))
                     #\newline))
          #f)))))
@@ -2326,7 +2326,7 @@ name extensions listed in %load-extensions."
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))
                                       fragments))))
-         
+
          (define (getter rtd type-name field slot)
            (define id (make-id rtd type-name '- field))
            #`(define #,id
@@ -3217,7 +3217,7 @@ deterministic."
   (let ((f (module-filename m)))
     (if f
         (save-module-excursion
-         (lambda () 
+         (lambda ()
            ;; Re-set the initial environment, as in try-module-autoload.
            (set-current-module (make-fresh-user-module))
            (primitive-load-path f)
@@ -3337,7 +3337,7 @@ error if selected binding does not exist in the used 
module."
     (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
   (define (valid-autoload? x)
     (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
-  
+
   ;; We could add a #:no-check arg, set by the define-module macro, if
   ;; these checks are taking too much time.
   ;;
@@ -3391,7 +3391,7 @@ error if selected binding does not exist in the used 
module."
       (let ((iface (resolve-interface transformer))
             (sym (car (last-pair transformer))))
         (set-module-transformer! module (module-ref iface sym))))
-    
+
     (run-hook module-defined-hook module)
     module))
 
@@ -3711,7 +3711,7 @@ but it fails to load."
               (let lp ()
                 (call-with-prompt
                  continue-tag
-                 (lambda () 
+                 (lambda ()
                    (define-syntax #,(datum->syntax #'while 'continue)
                      (lambda (x)
                        (syntax-case x ()
@@ -3753,7 +3753,7 @@ but it fails to load."
              (eqv? (string-ref (symbol->string dat) 0) #\:))))
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-    
+
     (define (parse-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
@@ -3835,7 +3835,7 @@ but it fails to load."
         ((kw val . args)
          (syntax-violation 'define-module "unknown keyword or bad argument"
                            #'kw #'val))))
-    
+
     (syntax-case x ()
       ((_ (name name* ...) arg ...)
        (and-map symbol? (syntax->datum #'(name name* ...)))
@@ -3877,7 +3877,7 @@ but it fails to load."
              (eqv? (string-ref (symbol->string dat) 0) #\:))))
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-    
+
     (define (quotify-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
@@ -3904,7 +3904,7 @@ but it fails to load."
            (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
              (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
                             out)))))))
-    
+
     (syntax-case x ()
       ((_ spec ...)
        (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
@@ -4052,7 +4052,7 @@ but it fails to load."
 
 (define duplicate-handlers
   (let ((m (make-module)))
-    
+
     (define (check module name int1 val1 int2 val2 var val)
       (scm-error 'misc-error
                  #f
@@ -4062,16 +4062,16 @@ but it fails to load."
                        (module-name int1)
                        (module-name int2))
                  #f))
-    
+
     (define (warn module name int1 val1 int2 val2 var val)
-      (format (current-warning-port)
+      (exception-format (current-warning-port)
               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
               (module-name module)
               name
               (module-name int1)
               (module-name int2))
       #f)
-     
+
     (define (replace module name int1 val1 int2 val2 var val)
       (let ((old (or (and var (object-property var 'replace) var)
                      (module-variable int1 name)))
@@ -4082,26 +4082,26 @@ but it fails to load."
                  old)
             (and (object-property new 'replace)
                  new))))
-    
+
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin
-             (format (current-warning-port)
+             (exception-format (current-warning-port)
                      "WARNING: ~A: imported module ~A overrides core binding 
`~A'\n"
                      (module-name module)
                      (module-name int2)
                      name)
              (module-local-variable int2 name))))
-     
+
     (define (first module name int1 val1 int2 val2 var val)
       (or var (module-local-variable int1 name)))
-     
+
     (define (last module name int1 val1 int2 val2 var val)
       (module-local-variable int2 name))
-     
+
     (define (noop module name int1 val1 int2 val2 var val)
       #f)
-    
+
     (set-module-name! m 'duplicate-handlers)
     (set-module-kind! m 'interface)
     (module-define! m 'check check)
@@ -4259,15 +4259,15 @@ when none is available, reading FILE-NAME with READER."
            (load-thunk-from-file go-file-name)
            (begin
              (when gostat
-               (format (current-warning-port)
+               (exception-format (current-warning-port)
                        ";;; note: source file ~a\n;;;       newer than 
compiled ~a\n"
                        name go-file-name))
              (cond
               (%load-should-auto-compile
                (%warn-auto-compilation-enabled)
-               (format (current-warning-port) ";;; compiling ~a\n" name)
+               (exception-format (current-warning-port) ";;; compiling ~a\n" 
name)
                (let ((cfn (compile name)))
-                 (format (current-warning-port) ";;; compiled ~a\n" cfn)
+                 (exception-format (current-warning-port) ";;; compiled ~a\n" 
cfn)
                  (load-thunk-from-file cfn)))
               (else #f)))))
      #:warning "WARNING: compilation of ~a failed:\n" name))
@@ -4340,7 +4340,7 @@ when none is available, reading FILE-NAME with READER."
             (dir (and (string? file) (dirname file))))
        ;; A module that uses `load' is not declarative.
        (when (module-declarative? (current-module))
-         (format (current-warning-port)
+         (exception-format (current-warning-port)
                  "WARNING: Use of `load' in declarative module ~A.  ~A\n"
                  (module-name (current-module))
                  "Add #:declarative? #f to your define-module invocation.")