Merge pull request #1022 from MikeSS8/typo

fix typo

README.md

@@ -27,7 +27,7 @@ see the manual for instructions on compiling with fewer features or
 requesting a smaller language on startup.
 
 Chibi-Scheme is known to work on **32** and **64-bit** Linux, FreeBSD,
-NetBSD, OpenBSD and OS X, Plan 9, Windows, iOS, Android,
+NetBSD, OpenBSD, DragonFlyBSD, OS X, Plan 9, Windows, iOS, Android,
 ARM and [Emscripten](https://kripken.github.io/emscripten-site).  Basic
 support for native Windows desktop also exists. See README-win32.md
 for details and build instructions.
@@ -56,4 +56,5 @@ shared libraries.
 To make the emscripten build run `make js` (_not_ `emmake make js`).
 
 For more detailed documentation, run `make doc` and see the generated
-*doc/chibi.html*.
+*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
+online.

doc/chibi.scrbl

@@ -28,8 +28,8 @@ standard modules.  You can choose whichever layer suits your needs
 best and customize the rest.  Adding your own primitives or wrappers
 around existing C libraries is easy with the C FFI.
 
-Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
+Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
-DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
 
 \section{Installation}
 
@@ -435,7 +435,7 @@ temporary values we may generate, which is what the
 \cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
 \cmacro{sexp_gc_release2} macros do (there are similar macros for
 values 1-6).  Precise GCs prevent a class of memory leaks (and
-potential attackes based thereon), but if you prefer convenience then
+potential attacks based thereon), but if you prefer convenience then
 Chibi can be compiled with a conservative GC and you can ignore these.
 
 The interesting part is then the calls to \cfun{sexp_load},
@@ -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}}
 

eval.c

@@ -1947,8 +1947,8 @@ sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
       res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
 #endif
 #if SEXP_USE_BIGNUMS
-    } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
+    } else if ((sexp_flonum_value(z) > (double)SEXP_MAX_FIXNUM)
-               || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
+               || sexp_flonum_value(z) < (double)SEXP_MIN_FIXNUM) {
       res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
 #endif
     } else {

include/chibi/features.h

@@ -301,7 +301,7 @@
 
 /* uncomment this to make the VM adhere to alignment rules */
 /*   This is required on some platforms, e.g. ARM */
-/* #define SEXP_USE_ALIGNED_BYTECODE */
+/* #define SEXP_USE_ALIGNED_BYTECODE 1 */
 
 /************************************************************************/
 /* These settings are configurable but only recommended for */

include/chibi/sexp.h

@@ -1079,6 +1079,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x))
 #endif
 
+/* TODO: Doesn't support x == SEXP_MIN_FIXNUM. */
 #define sexp_negate(x)                                  \
   if (sexp_flonump(x))                                  \
     sexp_negate_flonum(x);                              \

lib/chibi/app-test.sld

@@ -41,4 +41,9 @@
           (guard (exn (else 'error))
             (run-application zoo-app-spec
                              '("zoo" "--soap" "wash" "--animals" "rhino"))))
+      (let ((out (open-output-string)))
+        (parameterize ((current-output-port out))
+          (run-application zoo-app-spec '("zoo" "help"))
+          (test "Usage: zoo [options] <command>\nCommands:\n  feed animals ... - feed the animals\n  wash animals ... - wash the animals\n  help - print help\nOptions:\n      --animals - list of animals to act on (default all)\n  -l, --lions - also apply the action to lions\n"
+              (get-output-string out))))
       (test-end))))

lib/chibi/app.scm

@@ -538,7 +538,7 @@
             (and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
         (lp (cdr ls) (car ls) commands options))
        ((and (pair? (car ls)) (eq? '@ (caar ls)))
-        (lp (cdr ls) docs commands (append options (cadr (car ls)))))
+        (lp (cdr ls) docs commands (append options (cdar ls))))
        ((and (pair? (car ls)) (symbol? (caar ls)))
         ;; don't print nested commands
         (if (pair? commands)

lib/chibi/csv-test.sld

@@ -0,0 +1,98 @@
+
+(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 csv->string
+      (opt-lambda (row (writer (csv-writer)))
+        (let ((out (open-output-string)))
+          (writer row out)
+          (get-output-string out))))
+    (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 #\#)))))))
+      (let ((parser (csv-parser (csv-grammar '((quote-non-numeric? . #t))))))
+        (test-error (string->csv "1997,\"Ford\",E350" (csv-read->list parser)))
+        (test '(1997 "Ford" "E350")
+            (string->csv "1997,\"Ford\",\"E350\"" (csv-read->list parser))))
+      (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 3 (csv-num-rows default-csv-grammar (open-input-string city-csv)))
+       (test 0 (csv-num-rows default-csv-grammar (open-input-string "")))
+       (test 1 (csv-num-rows default-csv-grammar (open-input-string "x"))))
+      (test "1997,Ford,E350\n"
+          (csv->string '("1997" "Ford" "E350")))
+      (test "1997,Ford,E350,\"Super, luxurious truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, luxurious truck")))
+      (test "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"\n"
+          (csv->string '("1997" "Ford" "E350" "Super, \"luxurious\" truck")))
+      (test "1997,Ford,E350,\"Go get one now\nthey are going fast\"\n"
+          (csv->string
+           '("1997" "Ford" "E350" "Go get one now\nthey are going fast")))
+      (test "1997,Ford,E350\n"
+          (csv->string '(1997 "Ford" E350)))
+      (test "1997,\"Ford\",\"E350\"\n"
+          (csv->string '(1997 "Ford" E350)
+                       (csv-writer (csv-grammar '((quote-non-numeric? . #t))))))
+      (test-end))))

lib/chibi/csv.scm

@@ -0,0 +1,498 @@
+
+;;> \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 quote-doubling-escapes? escape-char record-separator comment-chars quote-non-numeric?)
+  csv-grammar?
+  (separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!)
+  (quote-char csv-grammar-quote-char csv-grammar-quote-char-set!)
+  (quote-doubling-escapes? csv-grammar-quote-doubling-escapes? csv-grammar-quote-doubling-escapes?-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!)
+  (quote-non-numeric? csv-grammar-quote-non-numeric? csv-grammar-quote-non-numeric?-set!))
+
+;; TODO: Other options to consider:
+;; - strip-leading/trailing-whitespace?
+;; - newlines-in-quotes?
+
+;;> 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{'quote-doubling-escapes?} - If true, two successive \scheme{quote-char}s within quotes are treated as a single escaped \scheme{quote-char} (default true).}
+;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#f} (no explicit escape, use quote doubling).}
+;;> \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)))
+;;> }
+(define (csv-grammar spec)
+  (let ((grammar (make-csv-grammar '(#\,) #\" #t #f 'lax '() #f)))
+    (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)))
+         ((quote-doubling-escapes?)
+          (csv-grammar-quote-doubling-escapes?-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)))
+         ((quote-non-numeric?)
+          (csv-grammar-quote-non-numeric?-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))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \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}.  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)
+      (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)
+               (quoted? #f)
+               (out (open-output-string)))
+        (define (get-field)
+          (let ((field (get-output-string out)))
+            (cond
+             ((and (zero? index) (equal? field "")) field)
+             ((and (csv-grammar-quote-non-numeric? grammar) (not quoted?))
+              (or (string->number field)
+                  (error "unquoted field is not numeric" field)))
+             (else field))))
+        (define (finish-row)
+          (let ((field (get-field)))
+            (if (and (zero? index) (equal? field ""))
+                ;; empty row, read again
+                (lp acc index #f out)
+                (kons acc index field))))
+        (let ((ch (read-char in)))
+          (cond
+           ((eof-object? ch)
+            (let ((field (get-field)))
+              (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-field))
+                (+ index 1)
+                #f
+                (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 #t 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) quoted? out))))
+           ((and (eqv? ch #\newline)
+                 (eq? (csv-grammar-record-separator grammar) 'lax))
+            (finish-row))
+           (else
+            (write-char ch out)
+            (lp acc index quoted? 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 (csv-grammar-quote-doubling-escapes? 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))))))
+
+(define (csv-skip-quoted in grammar)
+  (let lp ()
+    (let ((ch (read-char in)))
+      (cond
+       ((eof-object? ch)
+        (error "unterminated csv quote"))
+       ((eqv? ch (csv-grammar-quote-char grammar))
+        (when (and (csv-grammar-quote-doubling-escapes? grammar)
+                   (eqv? ch (peek-char in)))
+          (read-char in)
+          (lp)))
+       ((eqv? ch (csv-grammar-escape-char grammar))
+        (read-char in)
+        (lp))
+       (else
+        (lp))))))
+
+;;> Returns the number of rows in the input.
+(define csv-num-rows
+  (opt-lambda ((grammar default-csv-grammar)
+               (in (current-input-port)))
+    (let lp ((num-rows 0) (start? #t))
+      (let ((ch (read-char in)))
+        (cond
+         ((eof-object? ch) (if start? num-rows (+ num-rows 1)))
+         ((eqv? ch (csv-grammar-quote-char grammar))
+          (csv-skip-quoted in grammar)
+          (lp num-rows #f))
+         ((eqv? ch (csv-grammar-record-separator grammar))
+          (lp (+ num-rows 1) #f))
+         ((and (eqv? ch #\return)
+               (memq (csv-grammar-record-separator grammar) '(crlf lax)))
+          (cond
+           ((eqv? (peek-char in) #\newline)
+            (read-char in)
+            (lp (+ num-rows 1) #t))
+           ((eq? (csv-grammar-record-separator grammar) 'lax)
+            (lp (+ num-rows 1) #t))
+           (else
+            (lp num-rows #f))))
+         ((and (eqv? ch #\newline)
+               (eq? (csv-grammar-record-separator grammar) 'lax))
+          (lp (+ num-rows 1) #t))
+         (else
+          (lp num-rows #f)))))))
+
+;;> \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.
+;;>
+;;> \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)))
+      (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.
+;;>
+;;> \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)))
+      (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.
+;;>
+;;> \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)))
+      (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.
+;;>
+;;> \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
+                (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.
+;;>
+;;> \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
+               (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.
+;;>
+;;> \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))
+               (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.
+;;>
+;;> \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))
+               (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.
+;;>
+;;> \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
+                (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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;> \section{CSV Writers}
+
+(define (write->string obj)
+  (let ((out (open-output-string)))
+    (write obj out)
+    (get-output-string out)))
+
+(define (csv-grammar-char-needs-quoting? grammar ch)
+  (or (eqv? ch (csv-grammar-quote-char grammar))
+      (eqv? ch (csv-grammar-escape-char grammar))
+      (memv ch (csv-grammar-separator-chars grammar))
+      (eqv? ch (csv-grammar-record-separator grammar))
+      (memv ch '(#\newline #\return))))
+
+(define (csv-write-quoted obj out grammar)
+  (let ((in (open-input-string (if (string? obj) obj (write->string obj)))))
+    (write-char (csv-grammar-quote-char grammar) out)
+    (let lp ()
+      (let ((ch (read-char in)))
+        (cond
+         ((eof-object? ch))
+         ((or (eqv? ch (csv-grammar-quote-char grammar))
+              (eqv? ch (csv-grammar-escape-char grammar)))
+          (cond
+           ((and (csv-grammar-quote-doubling-escapes? grammar)
+                 (eqv? ch (csv-grammar-quote-char grammar)))
+            (write-char ch out))
+           ((csv-grammar-escape-char grammar)
+            => (lambda (esc) (write-char esc out)))
+           (else (error "no quote defined for" ch grammar)))
+          (write-char ch out)
+          (lp))
+         (else
+          (write-char ch out)
+          (lp)))))
+    (write-char (csv-grammar-quote-char grammar) out)))
+
+(define csv-writer
+  (opt-lambda ((grammar default-csv-grammar))
+    (opt-lambda (row (out (current-output-port)))
+      (let lp ((ls row) (first? #t))
+        (when (pair? ls)
+          (unless first?
+            (write-char (car (csv-grammar-separator-chars grammar)) out))
+          (if (or (and (csv-grammar-quote-non-numeric? grammar)
+                       (not (number? (car ls))))
+                  (and (string? (car ls))
+                       (string-any
+                        (lambda (ch) (csv-grammar-char-needs-quoting? grammar ch))
+                        (car ls)))
+                  (and (not (string? (car ls)))
+                       (not (number? (car ls)))
+                       (not (symbol? (car ls)))))
+              (csv-write-quoted (car ls) out grammar)
+              (display (car ls) out))
+          (lp (cdr ls) #f)))
+      (write-string
+       (case (csv-grammar-record-separator grammar)
+         ((crlf) "\r\n")
+         ((lf lax) "\n")
+         ((cr) "\r")
+         (else (string (csv-grammar-record-separator grammar))))
+       out))))
+
+(define csv-write
+  (opt-lambda ((writer (csv-writer)))
+    (opt-lambda (rows (out (current-output-port)))
+      (for-each
+       (lambda (row) (writer row out))
+       rows))))

lib/chibi/csv.sld

@@ -0,0 +1,11 @@
+
+(define-library (chibi csv)
+  (import (scheme base) (scheme write) (srfi 130) (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-num-rows
+          csv-fold csv-map csv->list csv-for-each csv->sxml
+          csv-writer csv-write
+          csv-skip-line)
+  (include "csv.scm"))

lib/chibi/json.c

@@ -65,7 +65,7 @@ sexp json_read_number (sexp ctx, sexp self, sexp in) {
     res *= pow(10.0, scale_sign * scale);
   }
   if (ch != EOF) sexp_push_char(ctx, ch, in);
-  return (inexactp || fabs(res) > SEXP_MAX_FIXNUM) ?
+  return (inexactp || fabs(res) > (double)SEXP_MAX_FIXNUM) ?
     sexp_make_flonum(ctx, sign * res) :
     sexp_make_fixnum(sign * res);  /* always return inexact? */
 }

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))}
 

lib/chibi/regexp-test.sld

@@ -151,6 +151,9 @@
       (test-re '("abc  " "")
                '(: ($ (*? alpha)) (* any))
                "abc  ")
+      ;; (test-re-search '("a-z")
+      ;;                 '(: "a" (*? any) "z")
+      ;;                 "a-z-z")
       (test-re '("<em>Hello World</em>" "em>Hello World</em")
                '(: "<" ($ (* any)) ">" (* any))
                "<em>Hello World</em>")

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
@@ -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)
@@ -400,6 +402,16 @@
         ((= (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-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)))
@@ -409,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)
@@ -420,17 +432,17 @@
                           (null? expr))
                       (eval expr (repl-env rp))
                       expr))
-              (lambda res-list
+              (lambda res-values
                 (cond
-                 ((not (or (null? res-list)
+                 ((not (or (null? res-values)
-                           (equal? res-list (list (if #f #f)))))
+                           (equal? res-values (list undefined-value))))
-                  (push-history-value-maybe! res-list)
+                  (push-history-value-maybe! res-values)
-                  (write/ss (car res-list) out)
+                  (repl-print (car res-values) out)
                   (for-each
                    (lambda (res)
                      (write-char #\space out)
-                     (write/ss res out))
+                     (repl-print res out))
-                   (cdr res-list))
+                   (cdr res-values))
                   (newline out))))))
           expr-list))))))
 

lib/chibi/repl.sld

@@ -1,8 +1,9 @@
 
 (define-library (chibi repl)
-  (export repl $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 ast) (chibi modules) (chibi doc) (chibi generic)
           (chibi string) (chibi io) (chibi optional)
           (chibi process) (chibi term edit-line)
           (srfi 1)

lib/chibi/scribble-test.sld

@@ -15,6 +15,9 @@
       (test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
       (test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
       (test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
+      (test-scribble '(123.456) "\\123.456")
+      (test-scribble '((123.456)) "\\(123.456)")
+      (test-scribble '((123.456)) "\\(123.456 )")
       (test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
       (test-scribble '((foo "blah blah" "\n" "     yada yada")) "\\foo{blah blah
      yada yada}")

lib/chibi/scribble.scm

@@ -53,9 +53,11 @@
 
 (define (read-float-tail in acc)
   (let lp ((res acc) (k 0.1))
-    (let ((ch (read-char in)))
+    (let ((ch (peek-char in)))
       (cond ((or (eof-object? ch) (char-delimiter? ch)) res)
-            ((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1)))
+            ((char-numeric? ch)
+             (read-char in)
+             (lp (+ res (* k (char-digit ch))) (* k 0.1)))
             (else (error "invalid numeric syntax"))))))
 
 (define (read-number in acc base)
@@ -67,7 +69,7 @@
        ((eqv? #\. ch)
         (read-char in)
         (if (= base 10)
-            (begin (read-char in) (read-float-tail in (inexact acc)))
+            (read-float-tail in (inexact acc))
             (error "non-base-10 floating point")))
        (else (error "invalid numeric syntax"))))))
 

lib/chibi/snow/commands.scm

@@ -794,10 +794,18 @@
     (http-post uri params))))
 
 (define (remote-command cfg name path params)
-  (let ((uri (remote-uri cfg name path)))
+  (let* ((uri (remote-uri cfg name path))
-    (sxml-display-as-text
+         (response
-     (read (snow-post cfg uri (cons '(fmt . "sexp") params))))
+          (port->string (snow-post cfg uri (cons '(fmt . "sexp") params)))))
+    (guard (exn (else
+                 (display "ERROR: couldn't display sxml response: ")
+                 (write response)
                  (newline)))
+      (let ((sxml (call-with-input-string response read)))
+        (if (null? sxml)
+            (display "WARN: () response from server")
+            (sxml-display-as-text sxml))
+        (newline)))))
 
 (define (command/reg-key cfg spec)
   (let* ((keys (call-with-input-file

lib/chibi/sxml.scm

@@ -167,7 +167,7 @@
                        sxml)))
     (let lp ((sxml sxml))
       (cond
-       ((pair? sxml)
+       ((proper-list? sxml)
         (let ((tag (car sxml)))
           (cond
            ;; skip headers and the menu
@@ -176,16 +176,18 @@
                      (pair? (cdr sxml))
                      (pair? (cadr sxml))
                      (eq? '@ (car (cadr sxml)))
-                     (equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
+                     (equal? '(id . "menu") (assq 'id (cdr (cadr sxml))))))
+            )
            ;; recurse other tags, appending newlines for new sections
            ((symbol? tag)
             (if (memq tag '(h1 h2 h3 h4 h5 h6))
                 (newline out))
-            (for-each
+            (let ((ls (if (and (pair? (cdr sxml))
-             lp
+                               (pair? (cadr sxml))
-             (if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
+                               (eq? '@ (car (cadr sxml))))
                           (cddr sxml)
-                 (cdr sxml)))
+                          (cdr sxml))))
+              (for-each lp ls))
             (if (memq tag '(p li br h1 h2 h3 h4 h5 h6))
                 (newline out)))
            (else

lib/chibi/sxml.sld

@@ -4,5 +4,5 @@
 (define-library (chibi sxml)
   (export sxml->xml sxml-display-as-html sxml-display-as-text sxml-strip
           html-escape html-tag->string)
-  (import (scheme base) (scheme write))
+  (import (scheme base) (scheme list) (scheme write))
   (include "sxml.scm"))

lib/chibi/test.scm

@@ -144,10 +144,11 @@
      (test name (call-with-values (lambda () expect) (lambda results results))
        (call-with-values (lambda () expr) (lambda results results))))))
 
-;;> \macro{(test-error [name] expr)}
+;;> \macro{(test-error [name [pred]] expr)}
 
 ;;> Like \scheme{test} but evaluates \var{expr} and checks that it
-;;> raises an error.
+;;> raises an error. If \var{pred} is provided, the raised error
+;;> object must additionally satisfy the given type test.
 
 (define-syntax test-error
   (syntax-rules ()
@@ -155,8 +156,12 @@
      (test-error #f expr))
     ((_ name expr)
      (test-propagate-info name #f expr ((expect-error . #t))))
+    ((_ name pred expr)
+     (test-propagate-info name #f expr ((expect-error . #t)
+                                        (error-type-test . ,pred)
+                                        (error-type-test-expr . pred))))
     ((test a ...)
-     (test-syntax-error 'test-error "1 or 2 arguments required"
+     (test-syntax-error 'test-error "1, 2, or 3 arguments required"
                         (test a ...)))))
 
 ;;> Low-level macro to pass alist info to the underlying \var{test-run}.
@@ -521,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)))
 
@@ -535,6 +541,12 @@
            (expect))))
     (guard
         (exn
+         ((and (assq-ref info 'expect-error)
+               (assq-ref info 'error-type-test))
+          => (lambda (pred)
+               ((current-test-reporter)
+                (if (pred exn) 'PASS 'FAIL)
+                (append `((exception . ,exn)) info))))
          (else
           ((current-test-reporter)
            (if (assq-ref info 'expect-error) 'PASS 'ERROR)
@@ -573,14 +585,20 @@
      ((SKIP) "-")
      (else "."))))
 
-(define (display-expected/actual expected actual)
+(define (display-expected/actual expected actual format)
-  (let* ((e-str (write-to-string expected))
+  (let ((e-str (format expected))
-         (a-str (write-to-string actual))
+        (a-str (format actual)))
-         (diff (diff e-str a-str read-char)))
+    (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))))
+          (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))
+          ))))
 
 (define (test-print-explanation indent status info)
   (cond
@@ -595,12 +613,20 @@
     (display "assertion failed"))
    ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
     (display indent)
+    (if (assq-ref info 'exception)
+        (begin
+          (display "error should satisfy ")
+          (write (assq-ref info 'error-type-test-expr))
+          (display " but raised ")
+          (write (assq-ref info 'exception)))
+        (begin
           (display "expected an error but got ")
-    (write (assq-ref info 'result)))
+          (write (assq-ref info 'result)))))
    ((eq? status 'FAIL)
     (display indent)
-    (display-expected/actual
+    (display-expected/actual (assq-ref info 'expected)
-     (assq-ref info 'expected) (assq-ref info 'result))))
+                             (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))
@@ -845,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}.
 

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

lib/scheme/extras.scm

@@ -187,12 +187,22 @@
             (lp (cdr ls) (+ i v-len)))))))
 
 (define (vector-map proc vec . lov)
-  (if (null? lov)
+  (cond
+   ((null? lov)
     (let lp ((i (vector-length vec)) (res '()))
       (if (zero? i)
           (list->vector res)
-            (lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res))))
+          (lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res)))))
-      (list->vector (apply map proc (map vector->list (cons vec lov))))))
+   ((null? (cdr lov))
+    (let ((vec2 (car lov)))
+      (let lp ((i (vector-length vec)) (res '()))
+        (if (zero? i)
+            (list->vector res)
+            (lp (- i 1)
+                (cons (proc (vector-ref vec (- i 1)) (vector-ref vec2 (- i 1)))
+                      res))))))
+   (else
+    (list->vector (apply map proc (map vector->list (cons vec lov)))))))
 
 (define (vector-for-each proc vec . lov)
   (if (null? lov)

lib/srfi/159/color.sld

@@ -4,4 +4,5 @@
   (export as-red as-blue as-green as-cyan as-yellow
           as-magenta as-white as-black
           as-bold as-underline)
+  (begin (define (make-state-variable . o) #f))
   (include "../166/color.scm"))

lib/srfi/160/mini-test.sld

@@ -1,6 +1,6 @@
 
 (define-library (srfi 160 mini-test)
-  (import (scheme base)
+  (import (scheme base) (scheme inexact)
           (srfi 160 base) (srfi 160 f8) (srfi 160 f16)
           (chibi test))
   (export run-tests)
@@ -83,6 +83,10 @@
           (vector->f16vector '#(0 1 2 3) 1 3))
         (test '#(1.0 2.0)
             (f16vector->vector '#f16(0 1 2 3) 1 3))
+        (test '(-inf.0 -1.0 -0.0 0.0 1.0 +inf.0)
+            (f16vector->list
+             '#f16(-inf.0 -1.0 -0.0 0.0 1.0 +inf.0)))
+        (test-assert (nan? (f16vector-ref '#f16(+nan.0) 0)))
         )
 
       (test-end))))

lib/srfi/231/base.scm

@@ -334,6 +334,7 @@
 
 (define (array-freeze! array)
   (%array-setter-set! array #f)
+  (make-immutable! (array-body array))
   array)
 
 ;; Indexing

lib/srfi/231/base.sld

@@ -46,4 +46,9 @@
    specialized-getter specialized-setter
    array-freeze!
    )
+  (cond-expand
+   (chibi
+    (import (only (chibi) make-immutable!)))
+   (else
+    (begin (define-syntax make-immutable! (syntax-rules () ((_ x) #f))))))
   (include "base.scm"))

lib/srfi/231/test.sld

@@ -2188,6 +2188,19 @@
               (array-curry (list*->array 3 '(((4 7) (2 6)) ((1 0) (0 1))))
                            2)
               0)))
+        (let* ((A (array-copy
+                   (make-array (make-interval '#(0 0) '#(10 10))
+                               (lambda (i j) (inexact (+ (* i 10.) j))))
+                   f32-storage-class))
+               (A3 (array-ref (array-curry A 1) 3)))
+          (test 37. (array-ref A 3 7))
+          (test 37. (array-ref A3 7))
+          (array-set! A 0. 3 7)
+          (test 0. (array-ref A 3 7))
+          (test 0. (array-ref A3 7))
+          (array-freeze! A)
+          (test-error (array-set! A 1. 3 7))
+          (test-error (array-set! A3 1. 7)))
 
         ;; (test-error
         ;;  (array-curry (make-array (make-interval '#(0 0) '#(1 1)) list)  0))

lib/srfi/231/transforms.scm

@@ -47,16 +47,16 @@
   u64vector-ref u64vector-set! u64? u64vector? make-u64vector u64vector-length 0)
 
 (define-storage-class f32-storage-class
-  f32vector-ref f32vector-set! f32? f32vector? make-f32vector f32vector-length 0)
+  f32vector-ref f32vector-set! f32? f32vector? make-f32vector f32vector-length 0.)
 
 (define-storage-class f64-storage-class
-  f64vector-ref f64vector-set! f64? f64vector? make-f64vector f64vector-length 0)
+  f64vector-ref f64vector-set! f64? f64vector? make-f64vector f64vector-length 0.)
 
 (define-storage-class c64-storage-class
-  c64vector-ref c64vector-set! c64? c64vector? make-c64vector c64vector-length 0)
+  c64vector-ref c64vector-set! c64? c64vector? make-c64vector c64vector-length 0.+0.i)
 
 (define-storage-class c128-storage-class
-  c128vector-ref c128vector-set! c128? c128vector? make-c128vector c128vector-length 0)
+  c128vector-ref c128vector-set! c128? c128vector? make-c128vector c128vector-length 0.+0.i)
 
 (define-storage-class char-storage-class
   (lambda (vec i) (integer->char (u32vector-ref vec i)))

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?))

lib/srfi/35/internal.scm

@@ -0,0 +1,249 @@
+(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
+  (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 ()
+    ((_ 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?)
+
+;; (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)))

lib/srfi/35/internal.sld

@@ -0,0 +1,48 @@
+(define-library (srfi 35 internal)
+  (import (except (scheme base)
+                  define-record-type
+                  ;; exclude (srfi 1 immutable) duplicate imports:
+                  map cons list append reverse)
+          (scheme write)
+          (only (chibi)
+                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 make-condition-type
+          condition?
+          condition-type?
+          condition-subtype?
+          make-condition
+          make-compound-condition
+          condition-has-type?
+          condition-ref
+          simple-conditions
+          extract-condition
+          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"))

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))))

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)
+    (or (let ((i (field-index-of (type-slots rtd) field)))
-             (rtd-field-offset p field))
-        (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)))

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"))

sexp.c

@@ -2890,6 +2890,13 @@ sexp sexp_make_ratio (sexp ctx, sexp num, sexp den) {
 sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
   sexp tmp;
   sexp_gc_var2(num, den);
+  if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
+    /* Prevent overflow in the sexp_negate. */
+    if (sexp_ratio_numerator(rat) == sexp_make_fixnum(SEXP_MIN_FIXNUM))
+      sexp_ratio_numerator(rat) = sexp_fixnum_to_bignum(ctx, sexp_ratio_numerator(rat));
+    sexp_negate(sexp_ratio_numerator(rat));
+    sexp_negate(sexp_ratio_denominator(rat));
+  }
   num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
   if (den == SEXP_ZERO)
     return sexp_read_error(ctx, "zero denominator in ratio", rat, in);
@@ -2909,6 +2916,9 @@ sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
   sexp_ratio_numerator(rat)
     = sexp_quotient(ctx, sexp_ratio_numerator(rat), num);
   if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
+    /* Prevent overflow in the sexp_negate. */
+    if (sexp_ratio_numerator(rat) == sexp_make_fixnum(SEXP_MIN_FIXNUM))
+      sexp_ratio_numerator(rat) = sexp_fixnum_to_bignum(ctx, sexp_ratio_numerator(rat));
     sexp_negate(sexp_ratio_numerator(rat));
     sexp_negate(sexp_ratio_denominator(rat));
   }
@@ -3019,7 +3029,8 @@ sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp) {
   } else if (c=='/') {
     sexp_gc_preserve2(ctx, res, den);
     den = sexp_read_number(ctx, in, base, exactp);
-    if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
+    if (! (sexp_fixnump(den) || sexp_bignump(den) ||
+           (sexp_complexp(den) && sexp_exactp(sexp_complex_real(den)) && sexp_exactp(sexp_complex_imag(den)))))
       res = (sexp_exceptionp(den)
              ? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
     else {
@@ -3206,15 +3217,22 @@ static float int_as_float(const unsigned int n) {
 
 /* https://arxiv.org/abs/2112.08926 */
 double sexp_half_to_double(unsigned short x) {
-  unsigned int e = (x&0x7C00)>>10,
+  unsigned int e, m, v;
-    m = (x&0x03FF)<<13,
+  if (x == 31744) return INFINITY;
+  if (x == 32767) return NAN;
+  if (x == 64512) return -INFINITY;
+  e = (x&0x7C00)>>10;
+  m = (x&0x03FF)<<13;
   v = float_as_int((float)m)>>23;
   return int_as_float((x&0x8000)<<16 | (e!=0)*((e+112)<<23|m) | ((e==0)&(m!=0))*((v-37)<<23|((m<<(150-v))&0x007FE000)));
 }
 
 unsigned short sexp_double_to_half(double x) {
-  unsigned int b = float_as_int(x)+0x00001000,
+  unsigned int b, e, m;
-    e = (b&0x7F800000)>>23,
+  if (isnan(x)) return 32767;
+  if (isinf(x)) return x < 0 ? 64512 : 31744;
+  b = float_as_int(x)+0x00001000;
+  e = (b&0x7F800000)>>23;
   m = b&0x007FFFFF;
   return (b&0x80000000)>>16 | (e>112)*((((e-112)<<10)&0x7C00)|m>>13) | ((e<113)&(e>101))*((((0x007FF000+m)>>(125-e))+1)>>1) | (e>143)*0x7FFF;
 }

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)

vm.c

@@ -912,12 +912,12 @@ static sexp sexp_restore_stack (sexp ctx, sexp saved) {
   return SEXP_VOID;
 }
 
-#define _ARG1 stack[top-1]
+#define _ARG1 (stack[top-1])
-#define _ARG2 stack[top-2]
+#define _ARG2 (stack[top-2])
-#define _ARG3 stack[top-3]
+#define _ARG3 (stack[top-3])
-#define _ARG4 stack[top-4]
+#define _ARG4 (stack[top-4])
-#define _ARG5 stack[top-5]
+#define _ARG5 (stack[top-5])
-#define _ARG6 stack[top-6]
+#define _ARG6 (stack[top-6])
 #define _PUSH(x) (stack[top++]=(x))
 #define _POP() (stack[--top])
 
@@ -1869,7 +1869,12 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
       if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
         _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
 #else
+      if (tmp1 == sexp_make_fixnum(SEXP_MIN_FIXNUM) && tmp2 == SEXP_NEG_ONE) {
+        _ARG1 = sexp_fixnum_to_bignum(ctx, tmp1);
+        sexp_negate_exact(_ARG1);
+      } else {
         _ARG1 = sexp_fx_div(tmp1, tmp2);
+      }
 #endif
 #endif
     }
@@ -1896,9 +1901,11 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
       if (tmp2 == SEXP_ZERO)
         sexp_raise("divide by zero", SEXP_NULL);
+      if (tmp1 == sexp_make_fixnum(SEXP_MIN_FIXNUM) && tmp2 == SEXP_NEG_ONE) {
+        _ARG1 = sexp_fixnum_to_bignum(ctx, tmp1);
+        sexp_negate_exact(_ARG1);
+      } else {
         _ARG1 = sexp_fx_div(tmp1, tmp2);
-      if ((sexp_sint_t)tmp1 < 0 && (sexp_sint_t)tmp2 < 0 && (sexp_sint_t)_ARG1 < 0) {
-        _ARG1 = sexp_quotient(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
       }
     }
 #if SEXP_USE_BIGNUMS