From d677a135f148145cff3801cbd3ba8d42bed69fdc Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Tue, 17 Sep 2024 18:37:40 +0900
Subject: [PATCH 01/11] Add current-test-value-formatter.

---
 lib/chibi/test.scm | 33 +++++++++++++++++++++++----------
 lib/chibi/test.sld |  2 +-
 2 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm
index 81bd627b..9c1b5108 100644
--- a/lib/chibi/test.scm
+++ b/lib/chibi/test.scm
@@ -526,6 +526,7 @@
              (not (assq-ref info 'line-number)))
         `((file-name . ,(car (pair-source expr)))
           (line-number . ,(cdr (pair-source expr)))
+          (format . ,(current-test-value-formatter))
           ,@info)
         info)))
 
@@ -584,14 +585,20 @@
      ((SKIP) "-")
      (else "."))))
 
-(define (display-expected/actual expected actual)
-  (let* ((e-str (write-to-string expected))
-         (a-str (write-to-string actual))
-         (diff (diff e-str a-str read-char)))
-    (write-string "expected ")
-    (write-string (edits->string/color (car diff) (car (cddr diff)) 1))
-    (write-string " but got ")
-    (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))))
+(define (display-expected/actual expected actual format)
+  (let ((e-str (format expected))
+        (a-str (format actual)))
+    (if (and (equal? e-str a-str)
+             (not (eqv? format write-to-string)))
+        ;; If the formatter can't display any difference, fall back to
+        ;; write-to-string.
+        (display-expected/actual expected actual write-to-string)
+        (let ((diff (diff e-str a-str read-char)))
+          (write-string "expected ")
+          (write-string (edits->string/color (car diff) (car (cddr diff)) 1))
+          (write-string " but got ")
+          (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))
+          ))))
 
 (define (test-print-explanation indent status info)
   (cond
@@ -617,8 +624,9 @@
           (write (assq-ref info 'result)))))
    ((eq? status 'FAIL)
     (display indent)
-    (display-expected/actual
-     (assq-ref info 'expected) (assq-ref info 'result))))
+    (display-expected/actual (assq-ref info 'expected)
+                             (assq-ref info 'result)
+                             (or (assq-ref info 'format) write-to-string))))
   ;; print variables
   (cond
    ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
@@ -863,6 +871,11 @@
 
 ;;> \section{Parameters}
 
+;;> If specified, takes a single object as input (the expected or
+;;> actual value of a test) and returns the string representation
+;;> (default \scheme{write-to-string}).
+(define current-test-value-formatter (make-parameter #f))
+
 ;;> The current test group as started by \scheme{test-group} or
 ;;> \scheme{test-begin}.
 
diff --git a/lib/chibi/test.sld b/lib/chibi/test.sld
index 4aa039c3..b5eef726 100644
--- a/lib/chibi/test.sld
+++ b/lib/chibi/test.sld
@@ -10,7 +10,7 @@
    test-get-name! test-group-name test-group-ref
    test-group-set! test-group-inc! test-group-push!
    ;; parameters
-   current-test-verbosity
+   current-test-value-formatter current-test-verbosity
    current-test-applier current-test-skipper current-test-reporter
    current-test-group-reporter test-failure-count
    current-test-epsilon current-test-comparator

From 702e881289eeb8c9f77a584ffb7b1e690b22ec8e Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Fri, 20 Sep 2024 09:13:16 +0900
Subject: [PATCH 02/11] Add error advise when forgetting to import a language.

Closes #1001.
---
 lib/chibi/repl.scm | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index fad9b498..5c2d5e73 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -296,6 +296,8 @@
          (pair? (exception-irritants exn)))
     (let ((name (car (exception-irritants exn))))
       (cond
+       ((and (identifier? name) (not (env-parent (current-environment))))
+        (display "Did you forget to import a language? e.g. (import (scheme base))\n" out))
        ((identifier? name)
         (display "Searching for modules exporting " out)
         (display name out)

From c288520ca5a148dda8b49c1722ae273b2995a313 Mon Sep 17 00:00:00 2001
From: Ekaitz Zarraga <ekaitz@elenq.tech>
Date: Mon, 7 Oct 2024 23:17:21 +0200
Subject: [PATCH 03/11] Fix typo in doc

---
 doc/chibi.scrbl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl
index 7c159e32..09612775 100755
--- a/doc/chibi.scrbl
+++ b/doc/chibi.scrbl
@@ -1403,7 +1403,7 @@ namespace.
 
 \item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}}
 
-\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formattinga.}}
+\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}}
 
 \item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
 

From be31278685fc97b35f4ce540d42e9f6328343cbf Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Wed, 9 Oct 2024 07:16:41 +0900
Subject: [PATCH 04/11] Clarify there is no special meaning to else in match.

Closes #1005.
---
 lib/chibi/match/match.scm | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm
index f9cfb201..669529e9 100644
--- a/lib/chibi/match/match.scm
+++ b/lib/chibi/match/match.scm
@@ -32,6 +32,11 @@
 
 ;;> If no patterns match an error is signalled.
 
+;;> Note there is no \scheme{else} clause.  \scheme{else} is sometimes
+;;> used descriptively for the last pattern, since an identifier used
+;;> only once matches anything, but it's preferred to use \scheme{_}
+;;> described below.
+
 ;;> Identifiers will match anything, and make the corresponding
 ;;> binding available in the body.
 
@@ -128,7 +133,7 @@
 ;;> are bound if the \scheme{or} operator matches, but the binding is
 ;;> only defined for identifiers from the subpattern which matched.
 
-;;> \example{(match 1 ((or) #t) (else #f))}
+;;> \example{(match 1 ((or) #t) (_ #f))}
 ;;> \example{(match 1 ((or x) x))}
 ;;> \example{(match 1 ((or x 2) x))}
 

From 0976d04b21679a66041a5b21a8df2604288c8fc4 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Wed, 23 Oct 2024 23:17:03 +0900
Subject: [PATCH 05/11] Adding initial CSV library.

---
 lib/chibi/csv-test.sld |  72 +++++++++++
 lib/chibi/csv.scm      | 286 +++++++++++++++++++++++++++++++++++++++++
 lib/chibi/csv.sld      |   9 ++
 3 files changed, 367 insertions(+)
 create mode 100644 lib/chibi/csv-test.sld
 create mode 100644 lib/chibi/csv.scm
 create mode 100644 lib/chibi/csv.sld

diff --git a/lib/chibi/csv-test.sld b/lib/chibi/csv-test.sld
new file mode 100644
index 00000000..3842667d
--- /dev/null
+++ b/lib/chibi/csv-test.sld
@@ -0,0 +1,72 @@
+
+(define-library (chibi csv-test)
+  (import (scheme base)
+          (srfi 227)
+          (chibi csv)
+          (chibi test))
+  (export run-tests)
+  (begin
+    (define string->csv
+      (opt-lambda (str (reader (csv-read->list)))
+        (reader (open-input-string str))))
+    (define (run-tests)
+      (test-begin "(chibi csv)")
+      (test-assert (eof-object? (string->csv "")))
+      (test '("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350"))
+      (test '("1997" "Ford" "E350")
+          (string->csv "\n1997,Ford,E350"))
+      (test '(" ")
+          (string->csv " \n1997,Ford,E350"))
+      (test '("" "")
+          (string->csv ",\n1997,Ford,E350"))
+      (test '("1997" "Ford" "E350")
+          (string->csv "\"1997\",\"Ford\",\"E350\""))
+      (test '("1997" "Ford" "E350" "Super, luxurious truck")
+          (string->csv "1997,Ford,E350,\"Super, luxurious truck\""))
+      (test '("1997" "Ford" "E350" "Super, \"luxurious\" truck")
+          (string->csv "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\""))
+      (test '("1997" "Ford" "E350" "Go get one now\nthey are going fast")
+          (string->csv "1997,Ford,E350,\"Go get one now
+they are going fast\""))
+      (test '("1997" "Ford" "E350")
+          (string->csv
+           "# this is a comment\n1997,Ford,E350"
+           (csv-read->list
+            (csv-parser (csv-grammar '((comment-chars #\#)))))))
+      (test '("1997" "Fo\"rd" "E3\"50")
+          (string->csv "1997\tFo\"rd\tE3\"50"
+                            (csv-read->list (csv-parser default-tsv-grammar))))
+      (test '#("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350" (csv-read->vector)))
+      (test '#("1997" "Ford" "E350")
+          (string->csv "1997,Ford,E350" (csv-read->fixed-vector 3)))
+      (test-error
+          (string->csv "1997,Ford,E350" (csv-read->fixed-vector 2)))
+      (let ((city-csv "Los Angeles,34°03′N,118°15′W
+New York City,40°42′46″N,74°00′21″W
+Paris,48°51′24″N,2°21′03″E"))
+        (test '(*TOP*
+                (row (col-0 "Los Angeles")
+                     (col-1 "34°03′N")
+                     (col-2 "118°15′W"))
+                (row (col-0 "New York City")
+                     (col-1 "40°42′46″N")
+                     (col-2 "74°00′21″W"))
+                (row (col-0 "Paris")
+                     (col-1 "48°51′24″N")
+                     (col-2 "2°21′03″E")))
+            ((csv->sxml) (open-input-string city-csv)))
+       (test '(*TOP*
+               (city (name "Los Angeles")
+                     (latitude "34°03′N")
+                     (longitude "118°15′W"))
+               (city (name "New York City")
+                     (latitude "40°42′46″N")
+                     (longitude "74°00′21″W"))
+               (city (name "Paris")
+                     (latitude "48°51′24″N")
+                     (longitude "2°21′03″E")))
+           ((csv->sxml 'city '(name latitude longitude))
+            (open-input-string city-csv))))
+      (test-end))))
diff --git a/lib/chibi/csv.scm b/lib/chibi/csv.scm
new file mode 100644
index 00000000..6138d36b
--- /dev/null
+++ b/lib/chibi/csv.scm
@@ -0,0 +1,286 @@
+
+;;> \section{CSV Grammars}
+
+;;> CSV is a simple and compact format for tabular data, which has
+;;> made it popular for a variety of tasks since the early days of
+;;> computing.  Unfortunately, there are many incompatible dialects
+;;> requiring a grammar to specify all of the different options.
+
+(define-record-type Csv-Grammar
+  (make-csv-grammar separator-chars quote-char escape-char record-separator comment-chars)
+  csv-grammar?
+  (separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!)
+  (quote-char csv-grammar-quote-char csv-grammar-quote-char-set!)
+  (escape-char csv-grammar-escape-char csv-grammar-escape-char-set!)
+  (record-separator csv-grammar-record-separator csv-grammar-record-separator-set!)
+  (comment-chars csv-grammar-comment-chars csv-grammar-comment-chars-set!))
+
+;; TODO: Consider some minimal low-level parsing options.  In general
+;; this is intended to be performed by the parser, but if we can skip
+;; intermediate string generation (e.g. parsing numbers directly) it
+;; can save a considerable amount of garbage when parsing large files.
+
+;;> Creates a new CSV grammar from the given spec, an alist of symbols
+;;> to values.  The following options are supported:
+;;>
+;;> \itemlist[
+;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\,)} (comma-separated).}
+;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\"} (a double-quote).}
+;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#\"} (a double-quote).  If this is the same character as the \scheme{quote-char}, then the quote char can be doubled to escape, but no other characters can be escaped.}
+;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}.  These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences.  Defaults to \scheme{'lax}.}
+;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).}
+;;> ]
+(define (csv-grammar spec)
+  (let ((grammar (make-csv-grammar '(#\,) #\" #\" 'lax '())))
+    (for-each
+     (lambda (x)
+       (case (car x)
+         ((separator-chars delimiter)
+          (csv-grammar-separator-chars-set! grammar (cdr x)))
+         ((quote-char)
+          (csv-grammar-quote-char-set! grammar (cdr x)))
+         ((escape-char)
+          (csv-grammar-escape-char-set! grammar (cdr x)))
+         ((record-separator newline-type)
+          (let ((rec-sep
+                 (case (cdr x)
+                   ((crlf lax) (cdr x))
+                   ((cr) #\return)
+                   ((lf) #\newline)
+                   (else
+                    (if (char? (cdr x))
+                        (cdr x)
+                        (error "invalid record-separator, expected a char or one of 'lax or 'crlf" (cdr x)))))))
+            (csv-grammar-escape-char-set! grammar (cdr x))))
+         ((comment-chars)
+          (csv-grammar-comment-chars-set! grammar (cdr x)))
+         (else
+          (error "unknown csv-grammar spec" x))))
+     spec)
+    grammar))
+
+;;> The default CSV grammar for convenience, with all of the defaults
+;;> from \scheme{csv-grammar}, i.e. comma-delimited with \scheme{#\"}
+;;> for quoting, doubled to escape.
+(define default-csv-grammar
+  (csv-grammar '()))
+
+;;> The default TSV grammar for convenience, splitting fields only on
+;;> tabs, with no quoting or escaping.
+(define default-tsv-grammar
+  (csv-grammar '((separator-chars #\tab) (quote-char . #f) (escape-char . #f))))
+
+;;> \section{CSV Parsers}
+
+;;> Parsers are low-level utilities to perform operations on records a
+;;> field at a time.  You generally want to work with readers, which
+;;> build on this to build records into familiar data structures.
+
+;;> Parsers follow the rules of a grammar to parse a single CSV
+;;> record, possible comprised of multiple fields.  A parser is a
+;;> procedure of three arguments which performs a fold operation over
+;;> the fields of the record. The parser signature is:
+;;> \scheme{(parser kons knil in)}, where \scheme{kons} itself is
+;;> a procedure of three arguments: \scheme{(proc acc index field)}.
+;;> \scheme{proc} is called on each field of the record, in order,
+;;> along with its zero-based \scheme{index} and the accumulated
+;;> result of the last call, starting with \scheme{knil}.
+
+;;> Returns a new CSV parser for the given \var{grammar}.
+(define csv-parser
+  (opt-lambda ((grammar default-csv-grammar))
+    (lambda (kons knil in)
+      (when (pair? (csv-grammar-comment-chars grammar))
+        (let lp ()
+          (when (memv (peek-char in) (csv-grammar-comment-chars grammar))
+            (csv-skip-line in grammar)
+            (lp))))
+      (let lp ((acc knil)
+               (index 0)
+               (out (open-output-string)))
+        (define (finish-row)
+          (let ((field (get-output-string out)))
+            (if (and (zero? index) (equal? field ""))
+                ;; empty row, read again
+                (lp acc index out)
+                (kons acc index field))))
+        (let ((ch (read-char in)))
+          (cond
+           ((eof-object? ch)
+            (let ((field (get-output-string out)))
+              (if (and (zero? index) (equal? field ""))
+                  ;; no data
+                  ch
+                  (kons acc index field))))
+           ((memv ch (csv-grammar-separator-chars grammar))
+            (lp (kons acc index (get-output-string out))
+                (+ index 1)
+                (open-output-string)))
+           ((eqv? ch (csv-grammar-quote-char grammar))
+            ;; TODO: Consider a strict mode to enforce no text
+            ;; before/after the quoted text.
+            (csv-read-quoted in out grammar)
+            (lp acc index out))
+           ((eqv? ch (csv-grammar-record-separator grammar))
+            (finish-row))
+           ((and (eqv? ch #\return)
+                 (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+            (cond
+             ((eqv? (peek-char in) #\newline)
+              (read-char in)
+              (finish-row))
+             ((eq? (csv-grammar-record-separator grammar) 'lax)
+              (finish-row))
+             (else
+              (write-char ch out)
+              (lp acc (+ index 1) out))))
+           ((and (eqv? ch #\newline)
+                 (eq? (csv-grammar-record-separator grammar) 'lax))
+            (finish-row))
+           (else
+            (write-char ch out)
+            (lp acc index out))))))))
+
+(define (csv-skip-line in grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch))
+       ((eqv? ch (csv-grammar-record-separator grammar)))
+       ((and (eqv? ch #\newline)
+             (eq? (csv-grammar-record-separator grammar) 'lax)))
+       ((and (eqv? ch #\return)
+             (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+        (cond
+         ((eqv? (peek-char in) #\newline) (read-char in))
+         ((eq? (csv-grammar-record-separator grammar) 'lax))
+         (else (lp))))
+       (else (lp))))))
+
+(define (csv-read-quoted in out grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch)
+        (error "unterminated csv quote" (get-output-string out)))
+       ((eqv? ch (csv-grammar-quote-char grammar))
+        (when (and (eqv? ch (csv-grammar-escape-char grammar))
+                   (eqv? ch (peek-char in)))
+          (write-char (read-char in) out)
+          (lp)))
+       ((eqv? ch (csv-grammar-escape-char grammar))
+        (write-char (read-char in) out)
+        (lp))
+       (else
+        ;; TODO: Consider an option to disable newlines in quotes.
+        (write-char ch out)
+        (lp))))))
+
+;;> \section{CSV Readers}
+
+;;> A CSV reader reads a single record, returning some representation
+;;> of it.  You can either loop manually with these or pass them to
+;;> one of the high-level utilities to operate on a whole CSV file at
+;;> a time.
+
+;;> The simplest reader, simply returns the field string values in
+;;> order as a list.
+(define csv-read->list
+  (opt-lambda ((parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (parser (lambda (ls i field) (cons field ls)) '() in)))
+        (if (pair? res)
+            (reverse res)
+            res)))))
+
+;;> The equivalent of \scheme{csv-read->list} but returns a vector.
+(define csv-read->vector
+  (opt-lambda ((parser (csv-parser)))
+    (let ((reader (csv-read->list parser)))
+      (opt-lambda ((in (current-input-port)))
+        (let ((res (reader in)))
+          (if (pair? res)
+              (list->vector res)
+              res))))))
+
+;;> The same as \scheme{csv-read->vector} but requires the vector to
+;;> be of a fixed size, and may be more efficient.
+(define csv-read->fixed-vector
+  (opt-lambda (size (parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (make-vector size)))
+        (let ((len (parser (lambda (prev-i i field) (vector-set! res i field) i)
+                           0
+                           in)))
+          (if (zero? len)
+              eof-object
+              res))))))
+
+;;> Returns an SXML representation of the record, as a row with
+;;> multiple named columns.
+(define csv-read->sxml
+  (opt-lambda ((row-name 'row)
+               (column-names
+                (lambda (i)
+                  (string->symbol (string-append "col-" (number->string i)))))
+               (parser (csv-parser)))
+    (define (get-column-name i)
+      (if (procedure? column-names)
+          (column-names i)
+          (list-ref column-names i)))
+    (opt-lambda ((in (current-input-port)))
+      (let ((res (parser (lambda (ls i field)
+                           `((,(get-column-name i) ,field) ,@ls))
+                         (list row-name)
+                         in)))
+        (if (pair? res)
+            (reverse res)
+            res)))))
+
+;;> \section{CSV Utilities}
+
+;;> A folding operation on records.  \var{proc} is called successively
+;;> on each row and the accumulated result.
+(define csv-fold
+  (opt-lambda (proc
+               knil
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (let lp ((acc knil))
+      (let ((row (reader in)))
+        (cond
+         ((eof-object? row) acc)
+         (else (lp (proc row acc))))))))
+
+;;> An iterator which simply calls \var{proc} on each record in the
+;;> input in order.
+(define csv-for-each
+  (opt-lambda (proc
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (csv-fold (lambda (row acc) (proc row)) #f reader in)))
+
+;;> Returns a list containing the result of calling \var{proc} on each
+;;> element in the input.
+(define csv-map
+  (opt-lambda (proc
+               (reader (csv-read->list))
+               (in (current-input-port)))
+    (reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in))))
+
+;;> Returns a list of all of the read records in the input.
+(define csv->list
+  (opt-lambda ((reader (csv-read->list))
+               (in (current-input-port)))
+    (csv-map (lambda (row) row) reader in)))
+
+;;> Returns an SXML representation of the CSV.
+(define csv->sxml
+  (opt-lambda ((row-name 'row)
+               (column-names
+                (lambda (i)
+                  (string->symbol (string-append "col-" (number->string i)))))
+               (parser (csv-parser)))
+    (opt-lambda ((in (current-input-port)))
+      (cons '*TOP*
+            (csv->list (csv-read->sxml row-name column-names parser) in)))))
diff --git a/lib/chibi/csv.sld b/lib/chibi/csv.sld
new file mode 100644
index 00000000..f4df593d
--- /dev/null
+++ b/lib/chibi/csv.sld
@@ -0,0 +1,9 @@
+
+(define-library (chibi csv)
+  (import (scheme base) (srfi 227))
+  (export csv-grammar csv-parser csv-grammar?
+          default-csv-grammar default-tsv-grammar
+          csv-read->list csv-read->vector  csv-read->fixed-vector
+          csv-read->sxml
+          csv-fold csv-map csv->list csv-for-each csv->sxml)
+  (include "csv.scm"))

From 4f3a98b2b3085ee2862a7f58899cb48655dd37a6 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Fri, 25 Oct 2024 18:44:30 +0900
Subject: [PATCH 06/11] Improving csv docs.

---
 lib/chibi/csv.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 80 insertions(+), 4 deletions(-)

diff --git a/lib/chibi/csv.scm b/lib/chibi/csv.scm
index 6138d36b..b51e54e9 100644
--- a/lib/chibi/csv.scm
+++ b/lib/chibi/csv.scm
@@ -24,12 +24,21 @@
 ;;> to values.  The following options are supported:
 ;;>
 ;;> \itemlist[
-;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\,)} (comma-separated).}
-;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\"} (a double-quote).}
-;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#\"} (a double-quote).  If this is the same character as the \scheme{quote-char}, then the quote char can be doubled to escape, but no other characters can be escaped.}
+;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\\,)} (comma-separated).}
+;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\\"} (a double-quote).}
+;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#\\"} (a double-quote).  If this is the same character as the \scheme{quote-char}, then the quote char can be doubled to escape, but no other characters can be escaped.}
 ;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}.  These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences.  Defaults to \scheme{'lax}.}
 ;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).}
 ;;> ]
+;;>
+;;> Example Gecos grammar:
+;;>
+;;> \example{
+;;> (csv-grammar
+;;>   '((separator-chars #\\:)
+;;>     (quote-char . #f)
+;;>     (escape-char . #f)))
+;;> }
 (define (csv-grammar spec)
   (let ((grammar (make-csv-grammar '(#\,) #\" #\" 'lax '())))
     (for-each
@@ -86,7 +95,15 @@
 ;;> along with its zero-based \scheme{index} and the accumulated
 ;;> result of the last call, starting with \scheme{knil}.
 
-;;> Returns a new CSV parser for the given \var{grammar}.
+;;> Returns a new CSV parser for the given \var{grammar}.  The parser
+;;> by itself can be used to parse a record at a time.
+;;>
+;;> \example{
+;;> (let ((parse (csv-parser)))
+;;>   (parse (lambda (vec i field) (vector-set! vec i (string->number field)) vec)
+;;>          (make-vector 3)
+;;>          (open-input-string "1,2,3")))
+;;> }
 (define csv-parser
   (opt-lambda ((grammar default-csv-grammar))
     (lambda (kons knil in)
@@ -185,6 +202,10 @@
 
 ;;> The simplest reader, simply returns the field string values in
 ;;> order as a list.
+;;>
+;;> \example{
+;;> ((csv-read->list) (open-input-string "foo,bar,baz"))
+;;> }
 (define csv-read->list
   (opt-lambda ((parser (csv-parser)))
     (opt-lambda ((in (current-input-port)))
@@ -194,6 +215,10 @@
             res)))))
 
 ;;> The equivalent of \scheme{csv-read->list} but returns a vector.
+;;>
+;;> \example{
+;;> ((csv-read->vector) (open-input-string "foo,bar,baz"))
+;;> }
 (define csv-read->vector
   (opt-lambda ((parser (csv-parser)))
     (let ((reader (csv-read->list parser)))
@@ -205,6 +230,10 @@
 
 ;;> The same as \scheme{csv-read->vector} but requires the vector to
 ;;> be of a fixed size, and may be more efficient.
+;;>
+;;> \example{
+;;> ((csv-read->fixed-vector 3) (open-input-string "foo,bar,baz"))
+;;> }
 (define csv-read->fixed-vector
   (opt-lambda (size (parser (csv-parser)))
     (opt-lambda ((in (current-input-port)))
@@ -218,6 +247,11 @@
 
 ;;> Returns an SXML representation of the record, as a row with
 ;;> multiple named columns.
+;;>
+;;> \example{
+;;> ((csv-read->sxml 'city '(name latitude longitude))
+;;>  (open-input-string "Tokyo,35°41′23″N,139°41′32″E"))
+;;> }
 (define csv-read->sxml
   (opt-lambda ((row-name 'row)
                (column-names
@@ -241,6 +275,16 @@
 
 ;;> A folding operation on records.  \var{proc} is called successively
 ;;> on each row and the accumulated result.
+;;>
+;;> \example{
+;;> (csv-fold
+;;>  (lambda (row acc) (cons (cadr (assq 'name (cdr row))) acc))
+;;>  '()
+;;>  (csv-read->sxml 'city '(name latitude longitude))
+;;>  (open-input-string
+;;>   "Tokyo,35°41′23″N,139°41′32″E
+;;> Paris,48°51′24″N,2°21′03″E"))
+;;> }
 (define csv-fold
   (opt-lambda (proc
                knil
@@ -254,6 +298,16 @@
 
 ;;> An iterator which simply calls \var{proc} on each record in the
 ;;> input in order.
+;;>
+;;> \example{
+;;> (let ((count 0))
+;;>   (csv-for-each
+;;>    (lambda (row) (if (string->number (car row)) (set! count (+ 1 count))))
+;;>    (csv-read->list)
+;;>    (open-input-string
+;;>      "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;>    count)
+;;> }
 (define csv-for-each
   (opt-lambda (proc
                (reader (csv-read->list))
@@ -262,6 +316,14 @@
 
 ;;> Returns a list containing the result of calling \var{proc} on each
 ;;> element in the input.
+;;>
+;;> \example{
+;;> (csv-map
+;;>  (lambda (row) (string->symbol (cadr row)))
+;;>  (csv-read->list)
+;;>  (open-input-string
+;;>    "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;> }
 (define csv-map
   (opt-lambda (proc
                (reader (csv-read->list))
@@ -269,12 +331,26 @@
     (reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in))))
 
 ;;> Returns a list of all of the read records in the input.
+;;>
+;;> \example{
+;;> (csv->list
+;;>  (csv-read->list)
+;;>  (open-input-string
+;;>    "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
+;;> }
 (define csv->list
   (opt-lambda ((reader (csv-read->list))
                (in (current-input-port)))
     (csv-map (lambda (row) row) reader in)))
 
 ;;> Returns an SXML representation of the CSV.
+;;>
+;;> \example{
+;;> ((csv->sxml 'city '(name latitude longitude))
+;;>  (open-input-string
+;;>   "Tokyo,35°41′23″N,139°41′32″E
+;;> Paris,48°51′24″N,2°21′03″E"))
+;;> }
 (define csv->sxml
   (opt-lambda ((row-name 'row)
                (column-names

From f4e3c0fd0bbaf93cacb0da7b75e35de63fb95f77 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Mon, 28 Oct 2024 09:16:30 +0900
Subject: [PATCH 07/11] Defining and using a repl-print generic to allow
 customizing REPL output.

---
 lib/chibi/repl.scm | 19 ++++++++++++-------
 lib/chibi/repl.sld |  4 ++--
 2 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index 5c2d5e73..7226f9fb 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -402,6 +402,11 @@
         ((= (length value) 1) (push-history-value! (car value)))
         (else (push-history-value! value))))
 
+(define-generic repl-print)
+
+(define-method (repl-print obj (out output-port?))
+  (write/ss obj out))
+
 (define (repl/eval rp expr-list)
   (let ((thread (current-thread))
         (out (repl-out rp)))
@@ -422,17 +427,17 @@
                           (null? expr))
                       (eval expr (repl-env rp))
                       expr))
-              (lambda res-list
+              (lambda res-values
                 (cond
-                 ((not (or (null? res-list)
-                           (equal? res-list (list (if #f #f)))))
-                  (push-history-value-maybe! res-list)
-                  (write/ss (car res-list) out)
+                 ((not (or (null? res-values)
+                           (equal? res-values (list undefined-value))))
+                  (push-history-value-maybe! res-values)
+                  (repl-print (car res-values) out)
                   (for-each
                    (lambda (res)
                      (write-char #\space out)
-                     (write/ss res out))
-                   (cdr res-list))
+                     (repl-print res out))
+                   (cdr res-values))
                   (newline out))))))
           expr-list))))))
 
diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld
index ae504cba..3e3ff957 100644
--- a/lib/chibi/repl.sld
+++ b/lib/chibi/repl.sld
@@ -1,8 +1,8 @@
 
 (define-library (chibi repl)
-  (export repl $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
+  (export repl repl-print $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
   (import (chibi) (only (meta) load-module module-name->file)
-          (chibi ast) (chibi modules) (chibi doc)
+          (chibi ast) (chibi modules) (chibi doc) (chibi generic)
           (chibi string) (chibi io) (chibi optional)
           (chibi process) (chibi term edit-line)
           (srfi 1)

From 416da215284761e9b9dbfa041c6080f3100d7f83 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Tue, 29 Oct 2024 21:45:00 +0900
Subject: [PATCH 08/11] Add repl-print-exception.

---
 lib/chibi/repl.scm | 9 +++++++--
 lib/chibi/repl.sld | 3 ++-
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index 7226f9fb..5da914ab 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -1,5 +1,5 @@
 ;; repl.scm - friendlier repl with line editing and signal handling
-;; Copyright (c) 2012-2013 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2012-2024 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;> A user-friendly REPL with line editing and signal handling.  The
@@ -407,6 +407,11 @@
 (define-method (repl-print obj (out output-port?))
   (write/ss obj out))
 
+(define-generic repl-print-exception)
+
+(define-method (repl-print-exception obj (out output-port?))
+  (print-exception obj out))
+
 (define (repl/eval rp expr-list)
   (let ((thread (current-thread))
         (out (repl-out rp)))
@@ -416,7 +421,7 @@
      (lambda ()
        (protect (exn
                  (else
-                  (print-exception exn out)
+                  (repl-print-exception exn out)
                   (repl-advise-exception exn (current-error-port))))
          (for-each
           (lambda (expr)
diff --git a/lib/chibi/repl.sld b/lib/chibi/repl.sld
index 3e3ff957..781bd1b5 100644
--- a/lib/chibi/repl.sld
+++ b/lib/chibi/repl.sld
@@ -1,6 +1,7 @@
 
 (define-library (chibi repl)
-  (export repl repl-print $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
+  (export repl repl-print repl-print-exception
+          $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
   (import (chibi) (only (meta) load-module module-name->file)
           (chibi ast) (chibi modules) (chibi doc) (chibi generic)
           (chibi string) (chibi io) (chibi optional)

From 3777c1b935cda14bb5999b0d928239716530f658 Mon Sep 17 00:00:00 2001
From: Daphne Preston-Kendal <git@dpk.io>
Date: Sat, 26 Oct 2024 13:59:31 +0200
Subject: [PATCH 09/11] Add SRFI 35 support

---
 lib/chibi/repl.scm                 |  45 ++++++
 lib/chibi/repl.sld                 |   1 +
 lib/srfi/35.sld                    |  24 +++
 lib/srfi/35/internal.scm           | 230 +++++++++++++++++++++++++++++
 lib/srfi/35/internal.sld           |  49 ++++++
 lib/srfi/35/test.sld               |  94 ++++++++++++
 lib/srfi/99/records/procedural.scm |  18 ++-
 lib/srfi/99/records/procedural.sld |   5 +-
 tests/lib-tests.scm                |   2 +
 9 files changed, 461 insertions(+), 7 deletions(-)
 create mode 100644 lib/srfi/35.sld
 create mode 100644 lib/srfi/35/internal.scm
 create mode 100644 lib/srfi/35/internal.sld
 create mode 100644 lib/srfi/35/test.sld

diff --git a/lib/chibi/repl.scm b/lib/chibi/repl.scm
index 5da914ab..19d4ff02 100644
--- a/lib/chibi/repl.scm
+++ b/lib/chibi/repl.scm
@@ -370,6 +370,49 @@
                (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)
@@ -420,6 +463,8 @@
      (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 781bd1b5..a64ae033 100644
--- a/lib/chibi/repl.sld
+++ b/lib/chibi/repl.sld
@@ -9,6 +9,7 @@
           (srfi 1)
           (srfi 9)
           (only (srfi 18) current-thread)
+          (srfi 35 internal)
           (srfi 38)
           (srfi 95)
           (srfi 98))
diff --git a/lib/srfi/35.sld b/lib/srfi/35.sld
new file mode 100644
index 00000000..13c13c9a
--- /dev/null
+++ b/lib/srfi/35.sld
@@ -0,0 +1,24 @@
+(define-library (srfi 35)
+  (import (srfi 35 internal))
+  (export make-condition-type
+          condition-type?
+          make-condition
+          condition?
+          condition-has-type?
+          condition-ref
+          make-compound-condition
+          extract-condition
+          define-condition-type
+          condition
+
+          &condition
+
+          &message
+          message-condition?
+          condition-message
+
+          &serious
+          serious-condition?
+
+          &error
+          error?))
diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm
new file mode 100644
index 00000000..265a3565
--- /dev/null
+++ b/lib/srfi/35/internal.scm
@@ -0,0 +1,230 @@
+(define-record-type Simple-Condition
+  (make-simple-condition)
+  simple-condition?)
+
+(define-record-type Compound-Condition
+  (%make-compound-condition components)
+  compound-condition?
+  (components compound-condition-components))
+
+(define (make-condition-type id parent field-names)
+  (make-rtd id
+            (list->vector
+             (map
+              (lambda (field-name)
+                (list 'immutable field-name))
+              field-names))
+            parent))
+
+(define (condition? obj)
+  (or (simple-condition? obj)
+      (compound-condition? obj)))
+
+(define (condition-type? obj)
+  (condition-subtype? obj Simple-Condition))
+
+(define (condition-subtype? maybe-child-ct maybe-parent-ct)
+  (and (rtd? maybe-child-ct)
+       (or (eqv? maybe-child-ct maybe-parent-ct)
+           (condition-subtype? (rtd-parent maybe-child-ct)
+                               maybe-parent-ct))))
+
+(define (condition-type-ancestors ct)
+  (unfold (lambda (a) (not (condition-type? a)))
+          (lambda (a) a)
+          (lambda (a) (rtd-parent a))
+          ct))
+
+(define (condition-type-common-ancestor ct_1 ct_2)
+  (let ((ct_1-as (condition-type-ancestors ct_1))
+        (ct_2-as (condition-type-ancestors ct_2)))
+    (find (lambda (a)
+            (memv a ct_2-as))
+          ct_1-as)))
+
+(define (make-condition ct . plist)
+  (define *undef* (cons '*undef* '()))
+  (let* ((field-names (rtd-all-field-names ct))
+         (field-values (make-vector (vector-length field-names) *undef*)))
+    (let loop ((property plist))
+      (if (null? property)
+          (cond ((vector-any (lambda (name value)
+                               (and (eq? value *undef*) name))
+                             field-names
+                             field-values)
+                 => (lambda (undef-field-name)
+                      (error "make-condition: value not given for field"
+                             undef-field-name
+                             ct)))
+                (else
+                 (apply (rtd-constructor ct) (vector->list field-values))))
+          (let ((idx (vector-index (lambda (x) (eq? x (car property)))
+                                   field-names)))
+            (if idx
+                (begin
+                  (vector-set! field-values idx (cadr property))
+                  (loop (cddr property)))
+                (error "make-condition: unknown field" (car property))))))))
+
+(define (make-compound-condition . cs)
+  (if (= (length cs) 1)
+      (car cs)
+      ;; SRFI 35 requires at least one component, but R6RS doesn’t;
+      ;; defer to R6RS’s less strict error checking (!)
+      (%make-compound-condition
+       (append-map
+        (lambda (c)
+          (if (simple-condition? c)
+              (list c)
+              (compound-condition-components c)))
+        cs))))
+
+(define (condition-has-type? c ct)
+  (if (simple-condition? c)
+      (is-a? c ct)
+      (any
+       (lambda (comp) (condition-has-type? comp ct))
+       (compound-condition-components c))))
+
+(define (condition-ref c field-name)
+  (if (simple-condition? c)
+      ((rtd-accessor (record-rtd c) field-name) c)
+      (condition-ref
+       (find
+        (lambda (comp)
+          (find field-name
+                (vector->list
+                 (rtd-all-field-names (record-rtd c)))))
+        (compound-condition-components c))
+       field-name)))
+
+(define (simple-conditions c)
+  (if (simple-condition? c)
+      (list c)
+      (compound-condition-components c)))
+
+(define (extract-condition c ct)
+  (if (and (simple-condition? c)
+           (condition-has-type? c ct))
+      c
+      (find
+       (lambda (comp)
+         (condition-has-type? comp ct))
+       (compound-condition-components ct))))
+
+(define (condition-predicate ct)
+  (lambda (obj)
+    (and (condition? obj)
+         (condition-has-type? obj ct))))
+(define (condition-accessor ct proc)
+  (lambda (c)
+    (cond ((and (simple-condition? c)
+                (condition-has-type? c ct))
+           (proc c))
+          ((find (lambda (comp) (condition-has-type? comp ct))
+                 (compound-condition-components c))
+           => (lambda (comp)
+                (proc comp)))
+          (else (error "condition-accessor: condition does not have the right type"
+                       c ct)))))
+
+(define-syntax define-condition-type/constructor
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((name (list-ref expr 1))
+            (parent (list-ref expr 2))
+            (constructor (list-ref expr 3))
+            (predicate (list-ref expr 4))
+            (field-specs (drop expr 5))
+            (field-names (map first field-specs))
+            (field-accessors (map second field-specs)))
+       (define _begin (rename 'begin))
+       (define _define (rename 'define))
+       (define _make-condition-type (rename 'make-condition-type))
+       (define _compound-condition? (rename 'compound-condition?))
+       (define _condition-predicate (rename 'condition-predicate))
+       (define _condition-accessor (rename 'condition-accessor))
+       (define _rtd-constructor (rename 'rtd-constructor))
+       (define _rtd-accessor (rename 'rtd-accessor))
+       (define _and (rename 'and))
+       (define _if (rename 'if))
+       (define _ct (rename 'ct))
+       (define _x (rename 'x))
+       `(,_begin
+         (,_define ,_ct
+           (,_make-condition-type ',name
+                                  ,parent
+                                  ',field-names))
+         (,_define ,name ,_ct)
+         (,_define ,constructor (,_rtd-constructor ,_ct))
+         (,_define ,predicate (,_condition-predicate ,_ct))
+         ,@(map
+            (lambda (field-name field-accessor)
+              `(,_define ,field-accessor
+                 (,_condition-accessor
+                  ,_ct
+                  (,_rtd-accessor ,_ct ',field-name))))
+            field-names
+            field-accessors))))))
+
+(define-syntax define-condition-type
+  (syntax-rules ()
+    ((_ name parent predicate (field-name field-accessor) ...)
+     (define-condition-type/constructor
+       name parent blah-ignored predicate
+       (field-name field-accessor) ...))))
+
+(define (%condition . specs)
+  (define (find-common-field-spec ct name)
+    (let loop ((more-specs specs))
+      (if (null? more-specs)
+          #f
+          (let* ((other-ct (caar more-specs))
+                 (field-specs (cdar more-specs))
+                 (a (condition-type-common-ancestor ct other-ct)))
+            (cond ((and (vector-index
+                         (lambda (n)
+                           (eq? n name))
+                         (rtd-all-field-names a))
+                        (assq name field-specs)))
+                  (else (loop (cdr more-specs))))))))
+  (let loop ((more-specs specs)
+             (components '()))
+    (if (null? more-specs)
+        (apply make-compound-condition (reverse components))
+        (let* ((this-spec (car more-specs))
+               (ct (car this-spec))
+               (field-specs (cdr this-spec))
+               (field-names (rtd-all-field-names ct))
+               (field-values
+                (vector-map
+                 (lambda (field-name)
+                   (cond ((assq field-name field-specs) => cdr)
+                         ((find-common-field-spec ct field-name) => cdr)
+                         (else
+                          (error "condition: value not given for field"
+                                 field-name
+                                 ct))))
+                 field-names)))
+          (loop
+           (cdr more-specs)
+           (cons
+            (apply (rtd-constructor ct) (vector->list field-values))
+            components))))))
+(define-syntax condition
+  (syntax-rules ()
+    ((_ (ct (field-name field-value) ...) ...)
+     (%condition (list ct (cons 'field-name field-value) ...) ...))))
+
+(define &condition Simple-Condition)
+
+(define-condition-type/constructor &message &condition
+  make-message-condition message-condition?
+  (message condition-message))
+
+(define-condition-type/constructor &serious &condition
+  make-serious-condition serious-condition?)
+
+(define-condition-type/constructor &error &serious
+  make-error error?)
+
diff --git a/lib/srfi/35/internal.sld b/lib/srfi/35/internal.sld
new file mode 100644
index 00000000..dfc23e08
--- /dev/null
+++ b/lib/srfi/35/internal.sld
@@ -0,0 +1,49 @@
+(define-library (srfi 35 internal)
+  (import (except (scheme base)
+                  define-record-type
+                  ;; exclude (srfi 1 immutable) duplicate imports:
+                  map cons list append reverse)
+          (only (chibi)
+                er-macro-transformer
+                is-a?)
+          ;; 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
+          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
+          define-condition-type
+          condition
+
+          &condition
+
+          &message
+          make-message-condition
+          message-condition?
+          condition-message
+
+          &serious
+          make-serious-condition
+          serious-condition?
+
+          &error
+          make-error
+          error?)
+
+  (include "internal.scm"))
diff --git a/lib/srfi/35/test.sld b/lib/srfi/35/test.sld
new file mode 100644
index 00000000..aec2a63b
--- /dev/null
+++ b/lib/srfi/35/test.sld
@@ -0,0 +1,94 @@
+(define-library (srfi 35 test)
+  (import (scheme base)
+          (srfi 35 internal)
+          (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "srfi-35: condition types")
+      (test-group "Adapted from the SRFI 35 examples"
+        (define-condition-type &c &condition
+          c?
+          (x c-x))
+
+        (define-condition-type &c1 &c
+          c1?
+          (a c1-a))
+
+        (define-condition-type &c2 &c
+          c2?
+          (b c2-b))
+        (define v1 (make-condition &c1 'x "V1" 'a "a1"))
+        (define v2 (condition (&c2
+                               (x "V2")
+                               (b "b2"))))
+        (define v3 (condition (&c1
+                               (x "V3/1")
+                               (a "a3"))
+                              (&c2
+                               (b "b3"))))
+        (define v4 (make-compound-condition v1 v2))
+        (define v5 (make-compound-condition v2 v3))
+
+        (test #t (c? v1))
+        (test #t (c1? v1))
+        (test #f (c2? v1))
+        (test "V1" (c-x v1))
+        (test "a1" (c1-a v1))
+
+        (test #t (c? v2))
+        (test #f (c1? v2))
+        (test #t (c2? v2))
+        (test "V2" (c-x v2))
+        (test "b2" (c2-b v2))
+
+        (test #t (c? v3))
+        (test #t (c1? v3))
+        (test #t (c2? v3))
+        (test "V3/1" (c-x v3))
+        (test "a3" (c1-a v3))
+        (test "b3" (c2-b v3))
+
+        (test #t (c? v4))
+        (test #t (c1? v4))
+        (test #t (c2? v4))
+        (test "V1" (c-x v4))
+        (test "a1" (c1-a v4))
+        (test "b2" (c2-b v4))
+
+        (test #t (c? v5))
+        (test #t (c1? v5))
+        (test #t (c2? v5))
+        (test "V2" (c-x v5))
+        (test "a3" (c1-a v5))
+        (test "b2" (c2-b v5)))
+
+      (test-group "Standard condition hierarchy"
+        (let ((mc (make-message-condition "foo!")))
+          (test #t (message-condition? mc))
+          (test "foo!" (condition-message mc))
+
+          (let ((ec (make-error)))
+            (test #t (error? ec))
+            (test #t (serious-condition? ec))
+
+            (let ((cc (make-compound-condition ec mc)))
+              (test #t (error? cc))
+              (test #t (serious-condition? cc))
+              (test #t (message-condition? cc))
+              (test "foo!" (condition-message mc))))))
+
+      (test-group "R6RS extension: shadowing field names"
+        (define-condition-type/constructor &a &condition
+          make-a a?
+          (val a-val))
+        (define-condition-type/constructor &b &a
+          make-b b?
+          (val b-val))
+
+        (define c (make-b 'a 'b))
+
+        (test 'a (a-val c))
+        (test 'b (b-val c)))
+
+      (test-end))))
diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm
index e213242d..16201c3e 100644
--- a/lib/srfi/99/records/procedural.scm
+++ b/lib/srfi/99/records/procedural.scm
@@ -9,7 +9,13 @@
   (type? x))
 
 (define (rtd-constructor rtd . o)
-  (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
+  (let ((fields
+         (if (pair? o)
+             (map
+              (lambda (field)
+                (rtd-field-offset rtd field))
+              (vector->list (car o)))
+             (iota (vector-length (rtd-all-field-names rtd)))))
         (make (make-constructor (type-name rtd) rtd)))
     (lambda args
       (let ((res (make)))
@@ -18,7 +24,7 @@
            ((null? a) (if (null? p) res (error "not enough args" p)))
            ((null? p) (error "too many args" a))
            (else
-            (slot-set! rtd res (rtd-field-offset rtd (car p)) (car a))
+            (slot-set! rtd res (car p) (car a))
             (lp (cdr a) (cdr p)))))))))
 
 (define (rtd-predicate rtd)
@@ -35,13 +41,13 @@
 
 (define (rtd-field-offset rtd field)
   (let ((p (type-parent rtd)))
-    (or (and (type? p)
-             (rtd-field-offset p field))
-        (let ((i (field-index-of (type-slots rtd) field)))
+    (or (let ((i (field-index-of (type-slots rtd) field)))
           (and i
                (if (type? p)
                    (+ i (vector-length (rtd-all-field-names p)))
-                   i))))))
+                   i)))
+        (and (type? p)
+             (rtd-field-offset p field)))))
 
 (define (rtd-accessor rtd field)
   (make-getter (type-name rtd) rtd (rtd-field-offset rtd field)))
diff --git a/lib/srfi/99/records/procedural.sld b/lib/srfi/99/records/procedural.sld
index b5791992..05a31616 100644
--- a/lib/srfi/99/records/procedural.sld
+++ b/lib/srfi/99/records/procedural.sld
@@ -1,5 +1,8 @@
 
 (define-library (srfi 99 records procedural)
   (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
-  (import (chibi) (chibi ast) (srfi 99 records inspection))
+  (import (chibi)
+          (chibi ast)
+          (only (srfi 1) iota)
+          (srfi 99 records inspection))
   (include "procedural.scm"))
diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm
index 38c044bc..612d2884 100644
--- a/tests/lib-tests.scm
+++ b/tests/lib-tests.scm
@@ -8,6 +8,7 @@
         (rename (srfi 18 test) (run-tests run-srfi-18-tests))
         (rename (srfi 26 test) (run-tests run-srfi-26-tests))
         (rename (srfi 27 test) (run-tests run-srfi-27-tests))
+        (rename (srfi 35 test) (run-tests run-srfi-35-tests))
         (rename (srfi 38 test) (run-tests run-srfi-38-tests))
         (rename (srfi 41 test) (run-tests run-srfi-41-tests))
         (rename (srfi 69 test) (run-tests run-srfi-69-tests))
@@ -83,6 +84,7 @@
 (run-srfi-18-tests)
 (run-srfi-26-tests)
 (run-srfi-27-tests)
+(run-srfi-35-tests)
 (run-srfi-38-tests)
 (run-srfi-41-tests)
 (run-srfi-69-tests)

From 76f35bc733036e43d7a523e43555014bfaebb29f Mon Sep 17 00:00:00 2001
From: Daphne Preston-Kendal <git@dpk.io>
Date: Sun, 27 Oct 2024 10:35:52 +0100
Subject: [PATCH 10/11] Define define-condition-type/constructor with
 syntax-rules

---
 lib/srfi/35/internal.scm | 50 +++++++++++-----------------------------
 1 file changed, 13 insertions(+), 37 deletions(-)

diff --git a/lib/srfi/35/internal.scm b/lib/srfi/35/internal.scm
index 265a3565..bd07dd37 100644
--- a/lib/srfi/35/internal.scm
+++ b/lib/srfi/35/internal.scm
@@ -129,43 +129,19 @@
                        c ct)))))
 
 (define-syntax define-condition-type/constructor
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (let* ((name (list-ref expr 1))
-            (parent (list-ref expr 2))
-            (constructor (list-ref expr 3))
-            (predicate (list-ref expr 4))
-            (field-specs (drop expr 5))
-            (field-names (map first field-specs))
-            (field-accessors (map second field-specs)))
-       (define _begin (rename 'begin))
-       (define _define (rename 'define))
-       (define _make-condition-type (rename 'make-condition-type))
-       (define _compound-condition? (rename 'compound-condition?))
-       (define _condition-predicate (rename 'condition-predicate))
-       (define _condition-accessor (rename 'condition-accessor))
-       (define _rtd-constructor (rename 'rtd-constructor))
-       (define _rtd-accessor (rename 'rtd-accessor))
-       (define _and (rename 'and))
-       (define _if (rename 'if))
-       (define _ct (rename 'ct))
-       (define _x (rename 'x))
-       `(,_begin
-         (,_define ,_ct
-           (,_make-condition-type ',name
-                                  ,parent
-                                  ',field-names))
-         (,_define ,name ,_ct)
-         (,_define ,constructor (,_rtd-constructor ,_ct))
-         (,_define ,predicate (,_condition-predicate ,_ct))
-         ,@(map
-            (lambda (field-name field-accessor)
-              `(,_define ,field-accessor
-                 (,_condition-accessor
-                  ,_ct
-                  (,_rtd-accessor ,_ct ',field-name))))
-            field-names
-            field-accessors))))))
+  (syntax-rules ()
+    ((_ name parent constructor predicate
+        (field-name field-accessor) ...)
+     (begin
+       (define ct (make-condition-type 'name
+                                       parent
+                                       '(field-name ...)))
+       (define name ct)
+       (define constructor (rtd-constructor ct))
+       (define predicate (condition-predicate ct))
+       (define field-accessor
+         (condition-accessor ct
+                             (rtd-accessor ct 'field-name))) ...))))
 
 (define-syntax define-condition-type
   (syntax-rules ()

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 11/11] 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