From 2781739291914253e8cb3675d3df033f5d2b3fc2 Mon Sep 17 00:00:00 2001
From: Daphne Preston-Kendal <git@dpk.io>
Date: Sat, 2 Nov 2024 01:03:27 +0100
Subject: [PATCH] Move REPL condition printing into the SRFI 35 implementation

---
 lib/chibi/repl.scm       | 45 ----------------------------------------
 lib/chibi/repl.sld       |  1 -
 lib/srfi/35/internal.scm | 43 ++++++++++++++++++++++++++++++++++++++
 lib/srfi/35/internal.sld | 11 +++++-----
 4 files changed, 48 insertions(+), 52 deletions(-)

diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index 19d4ff02..5da914ab 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -370,49 +370,6 @@
                (display ".\nNote module files must end in \".sld\".\n" out)))))))
     )))
 
-(define (repl-print-condition exn out)
-  (define components (simple-conditions exn))
-  (define n-components (length components))
-  (display "CONDITION: " out)
-  (display n-components out)
-  (display " component" out)
-  (if (not (=  n-components 1)) (display "s" out))
-  (display "\n" out)
-  (for-each
-   (lambda (component idx)
-     (define component-type (type-of component))
-     (display " " out)
-     (display idx out)
-     (display ". " out)
-     (display (type-name component-type) out)
-     (display "\n" out)
-     (let loop ((as (reverse
-                     (condition-type-ancestors component-type)))
-                (idx 0))
-       (if (not (null? as))
-           (let ((a (car as)))
-             (let a-loop ((fields (type-slots a))
-                          (idx idx))
-               (if (null? fields)
-                   (loop (cdr as) idx)
-                   (begin
-                     (display "    " out)
-                     (display (if (pair? (car fields))
-                                  (car (cdar fields))
-                                  (car fields))
-                              out)
-                     (if (not (eqv? a component-type))
-                         (begin
-                           (display " (" out)
-                           (display (type-name a) out)
-                           (display ")" out)))
-                     (display ": " out)
-                     (write (slot-ref component-type component idx) out)
-                     (display "\n" out)
-                     (a-loop (cdr fields) (+ idx 1)))))))))
-   components
-   (iota n-components 1)))
-
 (define undefined-value (if #f #f))
 
 (define $0 undefined-value)
@@ -463,8 +420,6 @@
      (lambda (n) (thread-interrupt! thread))
      (lambda ()
        (protect (exn
-                 ((condition? exn)
-                  (repl-print-condition exn out))
                  (else
                   (repl-print-exception exn out)
                   (repl-advise-exception exn (current-error-port))))
diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld
index a64ae033..781bd1b5 100644
--- a/lib/chibi/repl.sld
+++ b/lib/chibi/repl.sld
@@ -9,7 +9,6 @@
           (srfi 1)
           (srfi 9)
           (only (srfi 18) current-thread)
-          (srfi 35 internal)
           (srfi 38)
           (srfi 95)
           (srfi 98))
diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm
index bd07dd37..b8b94f6f 100644
--- a/lib/srfi/35/internal.scm
+++ b/lib/srfi/35/internal.scm
@@ -204,3 +204,46 @@
 (define-condition-type/constructor &error &serious
   make-error error?)
 
+;; (chibi repl) support
+(define-method (repl-print-exception (exn condition?) (out output-port?))
+  (define components (simple-conditions exn))
+  (define n-components (length components))
+  (display "CONDITION: " out)
+  (display n-components out)
+  (display " component" out)
+  (if (not (=  n-components 1)) (display "s" out))
+  (display "\n" out)
+  (for-each
+   (lambda (component idx)
+     (define component-type (record-rtd component))
+     (display " " out)
+     (display idx out)
+     (display ". " out)
+     (display (rtd-name component-type) out)
+     (display "\n" out)
+     (let loop ((as (reverse
+                     (condition-type-ancestors component-type)))
+                (idx 0))
+       (if (not (null? as))
+           (let ((a (car as)))
+             (let a-loop ((fields (vector->list (rtd-field-names a)))
+                          (idx idx))
+               (if (null? fields)
+                   (loop (cdr as) idx)
+                   (begin
+                     (display "    " out)
+                     (display (if (pair? (car fields))
+                                  (car (cdar fields))
+                                  (car fields))
+                              out)
+                     (if (not (eqv? a component-type))
+                         (begin
+                           (display " (" out)
+                           (display (rtd-name a) out)
+                           (display ")" out)))
+                     (display ": " out)
+                     (write (slot-ref component-type component idx) out)
+                     (display "\n" out)
+                     (a-loop (cdr fields) (+ idx 1)))))))))
+   components
+   (iota n-components 1)))
diff --git a/lib/srfi/35/internal.sld b/lib/srfi/35/internal.sld
index dfc23e08..0bc944a6 100644
--- a/lib/srfi/35/internal.sld
+++ b/lib/srfi/35/internal.sld
@@ -3,28 +3,27 @@
                   define-record-type
                   ;; exclude (srfi 1 immutable) duplicate imports:
                   map cons list append reverse)
+          (scheme write)
           (only (chibi)
-                er-macro-transformer
+                slot-ref
                 is-a?)
+          (only (chibi repl) repl-print-exception)
+          (only (chibi generic) define-method)
           ;; don’t let people go messing with a compound condition
           ;; components list:
           (srfi 1 immutable)
           (srfi 99)
           (srfi 133))
-  (export simple-condition?
-          compound-condition?
-          make-condition-type
+  (export make-condition-type
           condition?
           condition-type?
           condition-subtype?
-          condition-type-ancestors
           make-condition
           make-compound-condition
           condition-has-type?
           condition-ref
           simple-conditions
           extract-condition
-          compound-condition-components
           condition-predicate
           condition-accessor
           define-condition-type/constructor