Merge pull request #1031 from Retropikzel/snow-chibi-kawa

snow-chibi Kawa improvements

.gitignore

@@ -84,3 +84,6 @@ js/chibi.*
 
 build-lib/chibi/char-set/derived.scm
 build-lib/chibi/char-set/width.scm
+
+# vim swapfiles
+*.swp

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,
-DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
+Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
+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},
@@ -1008,6 +1008,13 @@ your platform) and the generated .so file can be loaded directly with
 \scheme{load}, or portably using \scheme{(include-shared "file")} in a
 module definition (note that include-shared uses no suffix).
 
+You can do this in one step with the \scheme{-c} flag (described
+below), and it will compile for you automatically:
+
+\command{
+chibi-ffi -c file.stub
+}
+
 The goal of this interface is to make access to C types and functions
 easy, without requiring the user to write any C code.  That means the
 stubber needs to be intelligent about various C calling conventions
@@ -1015,6 +1022,15 @@ and idioms, such as return values passed in actual parameters.
 Writing C by hand is still possible, and several of the core modules
 provide C interfaces directly without using the stubber.
 
+\subsection{Options}
+
+\itemlist[
+\item{\command{-c/--compile} - automatically compile a shared library}
+\item{\command{--cc <compiler>} - specify the c compiler executable, default cc}
+\item{\command{-f/--flags <flag>} - add a flag to pass to the c compiler, can be used multiple times}
+\item{\command{--features <feature>} - comma-delimited list of features to set before loading the stub file, e.g. debug}
+]
+
 \subsection{Includes and Initializations}
 
 \itemlist[
@@ -1022,6 +1038,7 @@ provide C interfaces directly without using the stubber.
 \item{\scheme{(c-system-include header)} - includes the system file \var{header}}
 \item{\scheme{(c-declare args ...)} - outputs \var{args} directly in the top-level C source}
 \item{\scheme{(c-init args ...)} - evaluates \var{args} as C code after all other library initializations have been performed, with \cvar{ctx} and \cvar{env} in scope}
+\item{\scheme{(c-link lib)} - when automatically compiling with the -c flag, link the given library with -llib}
 ]
 
 \subsection{Struct Interface}
@@ -1054,7 +1071,7 @@ The remaining slots are similar to the
 except they are prefixed with a C type (described below).  The
 \var{c_field_name} should be a field name of \var{struct_name}.
 \var{getter-name} will then be bound to a procedure of one argument, a
-\{struct_name} type, which returns the given field.  If provided,
+\var{struct_name} type, which returns the given field.  If provided,
 \var{setter-name} will be bound to a procedure of two arguments to
 mutate the given field.
 
@@ -1403,7 +1420,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}}
 
@@ -1444,6 +1461,20 @@ loading (since it loads many libraries) - if you have any difficulties
 with image files on your platform you can run
 \command{snow-chibi --noimage} to disable this feature.
 
+\subsection{Snow Configuration}
+
+Snow is configured in the file $HOME/.snow/config.scm. A common example,
+for use with packaging your own code, may look like the one below:
+(Note that the empty list is \emph{not} quoted! This file is not evaluated,
+but is simply read as an alist of configurations. See
+https://snow-fort.org/doc/author/ for more details.)
+\schemeblock{
+((authors "Alysssa P. Hacker <aphacker@mit.edu>")
+ (maintainers "Alyssa P. Hacker <aphacker@mit.edu>, Eva Luator <eluator@mit.edu")
+ (license agpl)) ;; or gpl mit bsd etc.
+}
+
+
 \subsubsection{Querying Packages and Status}
 
 By default \scheme{snow-chibi} looks for packages in the public
@@ -1599,6 +1630,11 @@ can specify any option, for example:
    (license gpl))))
 }
 
+\itemlist[
+\item{\scheme{--foreign-depends} - specify foreign libraries the library
+depends on (comma-delimited) (for example ffi,sqlite3 for -lffi -lsqlite3)}
+]
+
 Top-level snow options are represented as a flat alist.  Options
 specific to a command are nested under \scheme{(command (name ...))},
 with most options here being for \scheme{package}.  Here unless
@@ -1616,17 +1652,22 @@ conventions, you can thus simply run \scheme{snow-chibi package
 \subsubsection{Other Implementations}
 
 Although the command is called \scheme{snow-chibi}, it supports
-several other R7RS implementations.  The \scheme{implementations}
-command tells you which you currently have installed.  The following
-are currently supported:
+several other R7RS implementations and generic installation of libraries.
+The \scheme{implementations} command tells you which you currently have
+installed. The following are currently supported:
 
 \itemlist[
 \item{chibi - version >= 0.7.3}
 \item{chicken - version >= 4.9.0 with the \scheme{r7rs} egg}
 \item{cyclone - version >= 0.5.3}
 \item{foment - version >= 0.4}
+\item{gambit - version >= 4.9.3}
+\item{generic; By default libraries are installed into /usr/local/lib/snow or %LOCALAPPDATA%/lib/snow on windows}
 \item{gauche - version >= 0.9.4}
-\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa}}
+\item{kawa - version >= 2.0; you need to add the install dir to the search path, e.g. \scheme{-Dkawa.import.path=/usr/local/share/kawa/lib/*.sld}}
 \item{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
+\item{sagittarius - version >= 0.9.13}
+\item{racket - version >= 8.16 with the \scheme{r7rs} pkg}
 \item{sagittarius - version >= 0.98}
+\item{stklos - version > 2.10}
 ]

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)
-               || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
+    } else if ((sexp_flonum_value(z) > (double)SEXP_MAX_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

@@ -40,5 +40,10 @@
       (test 'error
           (guard (exn (else 'error))
             (run-application zoo-app-spec
-                           '("zoo" "--soap" "wash" "--animals" "rhino"))))
+                             '("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
@@ -176,12 +176,15 @@
 
 (define-record-type Repl
   (make-repl
-   in out escape module env meta-env make-prompt history-file history raw?)
+   in out escape module reader eval printer env meta-env make-prompt history-file history raw?)
   repl?
   (in repl-in repl-in-set!)
   (out repl-out repl-out-set!)
   (escape repl-escape repl-escape-set!)
   (module repl-module repl-module-set!)
+  (reader repl-reader repl-reader-set!)
+  (eval repl-eval repl-eval-set!)
+  (printer repl-printer repl-printer-set!)
   (env repl-env repl-env-set!)
   (meta-env repl-meta-env  repl-meta-env-set!)
   (make-prompt repl-make-prompt repl-make-prompt-set!)
@@ -296,6 +299,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 +405,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 +424,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)
@@ -417,27 +432,26 @@
                 (lambda ()
                   (if (or (identifier? expr)
                           (pair? expr)
-                          (null? expr))
-                      (eval expr (repl-env rp))
+                          (null? expr)
+                          (not (eq? eval (repl-eval rp))))
+                      ((or (repl-eval rp) 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)
+                  ((or (repl-printer rp) repl-print) (car res-values) out)
                   (for-each
                    (lambda (res)
                      (write-char #\space out)
-                     (write/ss res out))
-                   (cdr res-list))
+                     ((or (repl-printer rp) repl-print) res out))
+                   (cdr res-values))
                   (newline out))))))
           expr-list))))))
 
-(define (repl/eval-string rp str)
-  (repl/eval
-   rp
-   (protect (exn (else (print-exception exn (current-error-port))))
+(define (repl-string->sexps rp str)
+  (protect (exn (else (print-exception exn (current-error-port))))
      ;; Ugly wrapper to account for the implicit state mutation
      ;; implied by the #!fold-case read syntax.
      (let ((in (repl-in rp))
@@ -446,7 +460,10 @@
        (set-port-line! in2 (port-line in))
        (let ((expr-list (read/ss/all in2)))
          (set-port-fold-case! in (port-fold-case? in2))
-         expr-list)))))
+         expr-list))))
+
+(define (repl/eval-string rp str)
+  (repl/eval rp ((repl-reader rp) rp str)))
 
 (define (keywords->repl ls)
   (let-keywords* ls
@@ -454,6 +471,9 @@
        (out out: (current-output-port))
        (escape escape: #\@)
        (module module: #f)
+       (reader reader: repl-string->sexps)
+       (eval eval: eval)
+       (printer printer: repl-print)
        (env
         environment:
         (if module
@@ -477,7 +497,8 @@
              (member (get-environment-variable "TERM") '("emacs" "dumb")))
        (meta-env meta-env: (module-env (load-module '(meta)))))
     (make-repl
-     in out escape module env meta-env make-prompt history-file history raw?)))
+     in out escape module reader eval printer env meta-env
+     make-prompt history-file history raw?)))
 
 (define (repl/edit-line rp)
   (let ((prompt ((repl-make-prompt rp) (repl-module rp)))

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/show/c-test.sld

@@ -413,6 +413,12 @@ default:
                                     (%attribute packed)
                                     ))))
 
+      (test "struct foo {\n    int a;\n    struct bar b;\n};\n"
+          (show #f (c-expr
+                    '(struct foo
+                             ((int a)
+                              ((struct bar) b))))))
+
       (test "class employee {
     short age;
     char *name;

lib/chibi/show/c.scm

@@ -584,23 +584,28 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; data structures
 
+;; Either a type declaration (struct [name] body ...) or just a type
+;; reference (struct name).
 (define (c-struct/aux type x . o)
   (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
-         (body (if name (car o) x))
+         (body (if name (if (pair? o) (car o) '()) x))
          (o (if (null? o) o (cdr o))))
-    (c-wrap-stmt
-     (each
-      (c-braced-block
-       (each type
-             (if (and name (not (equal? name "")))
-                 (each " " name)
-                 nothing))
-       (each
-        (c-in-stmt
-         (if (list? body)
-             (apply c-begin (map c-wrap-stmt (map c-param body)))
-             (c-wrap-stmt (c-expr body))))))
-      (if (pair? o) (each " " (apply c-begin o)) nothing)))))
+    (if (null? body)
+        (c-wrap-stmt
+         (each type (if (and name (not (equal? name ""))) (each " " name) "")))
+        (c-wrap-stmt
+         (each
+          (c-braced-block
+           (each type
+                 (if (and name (not (equal? name "")))
+                     (each " " name)
+                     nothing))
+           (each
+            (c-in-stmt
+             (if (list? body)
+                 (apply c-begin (map c-wrap-stmt (map c-param body)))
+                 (c-wrap-stmt (c-expr body))))))
+          (if (pair? o) (each " " (apply c-begin o)) nothing))))))
 
 (define (c-struct . args) (apply c-struct/aux "struct" args))
 (define (c-union . args) (apply c-struct/aux "union" args))

lib/chibi/snow/commands.scm

@@ -24,9 +24,10 @@
                    (else
                     (warn msg)
                     #f))))))
-      (and confirm?
-           (yes-or-no? cfg "Implementation " (car spec) " does not "
-                       " seem to be available, install anyway?"))))
+      (or (equal? (car spec) 'generic)
+          (and confirm?
+               (yes-or-no? cfg "Implementation " (car spec) " does not "
+                           " seem to be available, install anyway?")))))
 
 (define (conf-selected-implementations cfg)
   (let ((requested (conf-get-list cfg 'implementations '(chibi))))
@@ -129,7 +130,8 @@
          declarations ...)
        (let* ((dir (library-path-base file name))
               (lib-file (path-relative file dir))
-              (lib-dir (path-directory lib-file)))
+              (lib-dir (path-directory lib-file))
+              (foreign-depends (conf-get-list cfg 'foreign-depends)))
          (define (resolve file)
            (let ((dest-path (if (equal? lib-dir ".")
                                 file
@@ -158,7 +160,8 @@
                (warn "couldn't find ffi stub or c source" base)
                '()))))
          (let lp ((ls declarations)
-                  (info `(,@(cond
+                  (info `((foreign-depends ,@foreign-depends)
+                          ,@(cond
                              ((conf-get cfg '(command package author))
                               => (lambda (x) (list (list 'author x))))
                              (else '()))
@@ -794,10 +797,18 @@
     (http-post uri params))))
 
 (define (remote-command cfg name path params)
-  (let ((uri (remote-uri cfg name path)))
-    (sxml-display-as-text
-     (read (snow-post cfg uri (cons '(fmt . "sexp") params))))
-    (newline)))
+  (let* ((uri (remote-uri cfg name path))
+         (response
+          (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
@@ -1353,7 +1364,8 @@
        (list
         (if (file-exists? dir)  ; repository-path should always exist
             dir
-            (make-path (or (conf-get cfg 'install-prefix)) "lib" impl
+            (make-path (or (conf-get cfg 'install-prefix) "lib")
+                       impl
                        (get-chicken-binary-version cfg))))))
     ((cyclone)
      (let ((dir (let ((lib-path (get-environment-variable "CYCLONE_LIBRARY_PATH")))
@@ -1362,6 +1374,14 @@
                       (string-trim (process->string '(icyc -p "(Cyc-installation-dir 'sld)"))
                                    char-whitespace?)))))
        (list (or dir "/usr/local/share/cyclone/"))))
+    ((gambit)
+     (list (make-path (get-environment-variable "HOME")
+                      ".gambit_userlib")))
+    ((generic)
+     (list (make-path (or (conf-get cfg 'install-prefix)
+                          (cond-expand (windows (get-environment-variable "LOCALAPPDATA"))
+                                       (else "/usr/local"))
+                          "/lib/snow"))))
     ((gauche)
      (list
       (let ((dir (string-trim
@@ -1381,6 +1401,8 @@
         (if (string? path)
             path
             "/usr/local/share/guile/"))))
+    ((kawa)
+     (list "/usr/local/share/kawa/lib"))
     ((larceny)
      (list
       (make-path
@@ -1390,6 +1412,19 @@
                    "(begin (display (getenv \"LARCENY_ROOT\")) (exit))"))
         char-whitespace?)
        "lib/Snow")))
+    ((sagittarius)
+     (list (make-path
+            (process->string
+             '(sagittarius -I "(sagittarius)" -e "(display (car (load-path))) (exit)")))))
+    ((stklos)
+     (list (make-path
+            (process->string
+             '(stklos -e "(display (install-path #:libdir))")))))
+     ((racket)
+      (list
+       (make-path
+        (process->string
+         '(racket -I racket/base -e "(display (find-system-path 'collects-dir))")))))
     (else
      (list (make-path (or (conf-get cfg 'install-prefix) "/usr/local")
                       "share/snow"
@@ -1456,6 +1491,10 @@
          (if lib-path
              `(foment -A ,install-dir -A ,lib-path ,file)
              `(foment -A ,install-dir ,file)))
+        ((gambit)
+         (if lib-path
+             `(gsi -s:search=,install-dir ,lib-path ,file)
+             `(gsi -s:search=,install-dir ,file)))
         ((gauche)
          (if lib-path
              `(gosh -A ,install-dir -A ,lib-path ,file)
@@ -1478,6 +1517,18 @@
              `(larceny -r7rs -path ,(string-append install-dir ":" lib-path)
                        -program ,file)
              `(larceny -r7rs -path ,install-dir -program ,file)))
+        ((sagittarius)
+         (if lib-path
+             `(sagittarius -A ,install-dir -A ,lib-path ,file)
+             `(sagittarius -A ,install-dir ,file)))
+        ((racket)
+         (if lib-path
+             `(racket -I r7rs -S ,install-dir -S ,lib-path --script ,file)
+             `(racket -I r7rs -S ,install-dir --script ,file)))
+        ((stklos)
+         (if lib-path
+             `(stklos -A ,install-dir -A ,lib-path ,file)
+             `(stklos -A ,install-dir ,file)))
         (else
          #f))))))
 
@@ -1611,6 +1662,7 @@
 ;; package information for each builtin library
 (define native-srfi-support
   '((foment 60)
+    (gambit 0 4 6 8 9 16 18 21 22 23 27 30 39 62 88 193)
     (gauche 0 1 4 5 7 9 11 13 14 19 26 27 29 31 37 42 43 55)
     (guile 0 1 2 4 6 8 9 10 11 13 14 16 17 18 19 23 26 27 28 30 31 34
            35 37 38 39 41 42 43 45 46 55 60 61 62 64 67 69 71 87 88
@@ -1618,7 +1670,19 @@
     (kawa 1 2 13 14 34 37 60 69 95)
     (larceny 0 1 2 4 5 6 7 8 9 11 13 14 16 17 19 22 23 25 26 27 28 29
              30 31 37 38 39 41 42 43 45 48 51 54 56 59 60 61 62 63 64
-             66 67 69 71 74 78 86 87 95 96 98)))
+             66 67 69 71 74 78 86 87 95 96 98)
+    (sagittarius 0 1 2 4 6 8 11 13 14 16 17 18 19 22 23 25 26 27 29 31 37 38 39
+                 41 42 43 45 49 57 60 61 64 69 78 86 87 98 99 100 101 105 106
+                 110 111 112 113 114 115 116 117 120 121 123 124 125 126 127
+                 128 129 130 131 132 133 134 135 139 141 142 143 144 145 146
+                 151 152 154 156 158 159 160 193 195 197 210 219 230)
+    (stklos 0 1 2 4 5 6 7 8 9 10 11 13 14 15 16 17 18 19 22 23 25 26 27 28 29
+            30 31 34 35 36 37 38 39 41 43 45 46 48 51 54 55 59 60 61 62 64 66
+            69 70 74 87 88 89 94 95 96 98 100 111 112 113 115 116 117 118 125
+            127 128 129 130 132 133 134 135 137 138 141 143 144 145 151 152 154
+            156 158 160 161 162 169 170 171 173 174 175 176 178 180 185 189 190
+            192 193 195 196 207 208 214 215 216 217 219 221 222 223 224 227 228
+            229 230 232 233 234 235 236 238 244 253 258 260)))
 
 (define native-self-support
   '((kawa base expressions hashtable quaternions reflect regex
@@ -1630,8 +1694,7 @@
             parameter parseopt portutil procedure process redefutil
             regexp reload selector sequence serializer signal singleton
             sortutil stringutil syslog termios test threads time
-            treeutil uvector validator version vport)
-    ))
+            treeutil uvector validator version vport)))
 
 ;; Currently we make assumptions about default installed libraries of
 ;; the form (scheme *), (srfi *) and (<impl> *), but don't make any
@@ -1671,7 +1734,13 @@
   (cond
    ((eq? impl 'chicken) (get-install-library-dir impl cfg))
    ((eq? impl 'cyclone) (get-install-library-dir impl cfg))
+   ((eq? impl 'gambit) (get-install-library-dir impl cfg))
+   ((eq? impl 'generic) (get-install-library-dir impl cfg))
    ((eq? impl 'guile) (get-guile-site-dir))
+   ((eq? impl 'kawa) (get-install-library-dir impl cfg))
+   ((eq? impl 'sagittarius) (get-install-library-dir impl cfg))
+   ((eq? impl 'racket) (get-install-library-dir impl cfg))
+   ((eq? impl 'stklos) (get-install-library-dir impl cfg))
    ((conf-get cfg 'install-source-dir))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "share/snow" impl)))
@@ -1681,6 +1750,12 @@
   (cond
    ((eq? impl 'chicken) (get-install-library-dir impl cfg))
    ((eq? impl 'cyclone) (get-install-library-dir impl cfg))
+   ((eq? impl 'gambit) (get-install-library-dir impl cfg))
+   ((eq? impl 'generic) (get-install-library-dir impl cfg))
+   ((eq? impl 'kawa) (get-install-library-dir impl cfg))
+   ((eq? impl 'sagittarius) (get-install-library-dir impl cfg))
+   ((eq? impl 'racket) (get-install-library-dir impl cfg))
+   ((eq? impl 'stklos) (get-install-library-dir impl cfg))
    ((conf-get cfg 'install-data-dir))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "share/snow" impl)))
@@ -1696,10 +1771,22 @@
                            (get-chicken-binary-version cfg))))
           (else
            (car (get-install-dirs impl cfg)))))
+   ((eq? impl 'generic)
+    (car (get-install-dirs impl cfg)))
    ((eq? impl 'cyclone)
     (car (get-install-dirs impl cfg)))
+   ((eq? impl 'gambit)
+    (car (get-install-dirs impl cfg)))
    ((eq? impl 'guile)
     (get-guile-site-ccache-dir))
+   ((eq? impl 'kawa)
+    (car (get-install-dirs impl cfg)))
+   ((eq? impl 'sagittarius)
+    (car (get-install-dirs impl cfg)))
+   ((eq? impl 'racket)
+    (car (get-install-dirs impl cfg)))
+   ((eq? impl 'stklos)
+    (car (get-install-dirs impl cfg)))
    ((conf-get cfg 'install-prefix)
     => (lambda (prefix) (make-path prefix "lib" impl)))
    (else snow-binary-module-directory)))
@@ -1714,7 +1801,7 @@
 (define (get-library-extension impl cfg)
   (or (conf-get cfg 'library-extension)
       (case impl
-        ((gauche kawa) "scm")
+        ((gauche) "scm")
         (else "sld"))))
 
 (define (install-with-sudo? cfg path)
@@ -1798,6 +1885,8 @@
           (library-include-files impl cfg (make-path dir library-file)))
          (install-dir (get-install-source-dir impl cfg))
          (install-lib-dir (get-install-library-dir impl cfg)))
+    ;; ensure the install directory exists
+    (create-directory* install-dir)
     ;; install the library file
     (let ((path (make-path install-dir dest-library-file)))
       (install-directory cfg (path-directory path))
@@ -1862,6 +1951,23 @@
           (cons dest-so-path
                 (default-installer impl cfg library dir)))))
 
+(define (gambit-installer impl cfg library dir)
+  (let* ((library-file (get-library-file cfg library))
+         (install-dir (get-install-library-dir impl cfg))
+         (so-path (string-append (path-strip-extension library-file) ".so"))
+         (dest-so-path (make-path install-dir so-path))
+         (o-path (string-append (path-strip-extension library-file) ".o"))
+         (dest-o-path (make-path install-dir o-path))
+         (installed-files (default-installer impl cfg library dir)))
+    (install-directory cfg (path-directory dest-so-path))
+    (when (file-exists? so-path)
+      (install-file cfg (make-path dir so-path) dest-so-path)
+      (set! installed-files (cons so-path installed-files)))
+    (when (file-exists? o-path)
+      (install-file cfg (make-path dir o-path) dest-o-path)
+      (set! installed-files (cons o-path installed-files)))
+    installed-files))
+
 (define (guile-installer impl cfg library dir)
   (let* ((source-scm-file (get-library-file cfg library))
          (source-go-file (string-append
@@ -1903,19 +2009,64 @@
          (library-shared-include-files
           impl cfg (make-path dir source-scm-file))))))))
 
+(define (kawa-installer impl cfg library dir)
+  (let* ((class-file (path-replace-extension
+                       (get-library-file cfg library) "class"))
+         (source-class-file (make-path dir class-file))
+         (install-dir (get-install-source-dir impl cfg))
+         (dest-class-file (make-path install-dir class-file))
+         (path (make-path install-dir dest-class-file))
+         (installed-files (default-installer impl cfg library dir)))
+    (cond ((file-exists? source-class-file)
+           (install-file cfg source-class-file dest-class-file)
+           (cons dest-class-file installed-files))
+          (else installed-files))))
+
+;; Racket can only load files with .rkt suffix. So for each library we create
+;; a file that sets language to r7rs and includes the .sld file
+(define (racket-installer impl cfg library dir)
+  (let* ((source-rkt-file
+           (make-path dir
+           (string-append (path-strip-extension (get-library-file cfg library))
+                          ".rkt")))
+         (install-dir (get-install-source-dir impl cfg))
+         (dest-rkt-file
+           (make-path install-dir
+                      (string-append (library->path cfg library) ".rkt")))
+         (path (make-path install-dir dest-rkt-file))
+         (include-filename (string-append
+                             (path-strip-directory (path-strip-extension path))
+                             ".sld"))
+         (installed-files (default-installer impl cfg library dir)))
+    (with-output-to-file
+      source-rkt-file
+      (lambda ()
+        (map display
+             (list "#lang r7rs" #\newline
+                   "(import (scheme base))" #\newline
+                   "(include \"" include-filename "\")" #\newline))))
+    (install-file cfg source-rkt-file dest-rkt-file)
+    (cons dest-rkt-file installed-files)))
+
 ;; installers should return the list of installed files
 (define (lookup-installer installer)
   (case installer
     ((chicken) chicken-installer)
     ((cyclone) cyclone-installer)
+    ((gambit) gambit-installer)
     ((guile) guile-installer)
+    ((kawa) kawa-installer)
+    ((racket) racket-installer)
     (else default-installer)))
 
 (define (installer-for-implementation impl cfg)
   (case impl
     ((chicken) 'chicken)
     ((cyclone) 'cyclone)
+    ((gambit) 'gambit)
     ((guile) 'guile)
+    ((kawa) 'kawa)
+    ((racket) 'racket)
     (else 'default)))
 
 (define (install-library impl cfg library dir)
@@ -2080,6 +2231,30 @@
                               " - install anyway?"))
               library))))))
 
+(define (gambit-builder impl cfg library dir)
+  (let* ((library-file (get-library-file cfg library))
+         (src-library-file (make-path dir library-file))
+         (library-dir (path-directory src-library-file))
+         (dest-so-file (string-append (library->path cfg library) ".so"))
+         (dest-o-file (string-append (library->path cfg library) ".o"))
+         (dest-dir (path-directory (make-path dir dest-so-file))))
+    ;; ensure the build directory exists
+    (create-directory* dest-dir)
+    (with-directory
+      dir
+      (lambda ()
+        (let ((res (system 'gsc '-o dest-so-file '-dynamic src-library-file)))
+          (and (or (and (pair? res) (zero? (cadr res)))
+                   (yes-or-no? cfg "gambit failed to build .so file: "
+                               (library-name library)
+                               " - install anyway?"))
+               (let ((res (system 'gsc '-o dest-o-file '-obj src-library-file)))
+                 (and (or (and (pair? res) (zero? (cadr res)))
+                          (yes-or-no? cfg "gambit failed to build .o file: "
+                                      (library-name library)
+                                      " - install anyway?"))
+                      library))))))))
+
 (define (guile-builder impl cfg library dir)
   (let* ((library-file (get-library-file cfg library))
          (src-library-file (make-path dir library-file))
@@ -2096,17 +2271,30 @@
        (and (system 'guild 'compile '-O0 '--r7rs '-o dest-library-file src-library-file)
             library)))))
 
+(define (kawa-builder impl cfg library dir)
+  (let* ((src-library-file (make-path dir (get-library-file cfg library)))
+         (res (system 'kawa
+                      '-d dir
+                      '-C src-library-file)))
+    (and (or (and (pair? res) (zero? (cadr res)))
+             (yes-or-no? cfg ".class file failed to build: "
+                         (library-name library)
+                         " - install anyway?"))
+         library)))
+
 (define (lookup-builder builder)
   (case builder
     ((chibi) chibi-builder)
     ((chicken) chicken-builder)
     ((cyclone) cyclone-builder)
+    ((gambit) gambit-builder)
     ((guile) guile-builder)
+    ((kawa) kawa-builder)
     (else default-builder)))
 
 (define (builder-for-implementation impl cfg)
   (case impl
-    ((chibi chicken cyclone guile) impl)
+    ((chibi chicken cyclone gambit guile kawa) impl)
     (else 'default)))
 
 (define (build-library impl cfg library dir)

lib/chibi/snow/utils.scm

@@ -25,6 +25,12 @@
             ,(delay
                (process->sexp
                 '(foment -e "(write (features))"))))
+    (gambit "gsc" (gsc -v) #f
+            ,(delay
+               (process->sexp
+                '(gsc -e "(display (features))"))))
+    (generic "generic" #f #f
+            ,(delay (write-string "generic\n")))
     (gauche "gosh" (gosh -E "print (gauche-version)") "0.9.4"
             ,(delay
                (process->sexp
@@ -39,10 +45,18 @@
               '(kawa -e "(write (features))"))))
     (larceny "larceny" (larceny --version) "v0.98"
              ,(delay '()))
-    (sagittarius "sagittarius" #f #f
+    (racket "racket" (racket --version) #f
+          ,(delay
+             (process->sexp
+              '(racket -I r7rs -e "(import (scheme base) (scheme write)) (display (features))"))))
+    (sagittarius "sagittarius" (sagittarius --version) #f
                  ,(delay
                     (process->sexp
-                     '(sagittarius -I "(scheme base)" -e "(write (features))"))))))
+                     '(sagittarius -I "(scheme base)" -e "(write (features)) (exit)"))))
+    (stklos "stklos" (stklos --version) #f
+                 ,(delay
+                    (process->sexp
+                     '(stklos -e "(write (features))"))))))
 
 (define (impl->version impl cmd)
   (let* ((lines (process->string-list cmd))
@@ -59,8 +73,11 @@
 (define (target-is-host? impl)
   (case impl
     ((chibi) (cond-expand (chibi #t) (else #f)))
+    ((gambit) (cond-expand (gambit #t) (else #f)))
     ((gauche) (cond-expand (gauche #t) (else #f)))
+    ((racket) (cond-expand (racket #t) (else #f)))
     ((sagittarius) (cond-expand (sagittarius #t) (else #f)))
+    ((stklos) (cond-expand (stklos #t) (else #f)))
     (else #f)))
 
 (define (impl->features impl)

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
-             lp
-             (if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
-                 (cddr sxml)
-                 (cdr sxml)))
+            (let ((ls (if (and (pair? (cdr sxml))
+                               (pair? (cadr sxml))
+                               (eq? '@ (car (cadr sxml))))
+                          (cddr 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)
-  (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
@@ -595,12 +613,20 @@
     (display "assertion failed"))
    ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
     (display indent)
-    (display "expected an error but got ")
-    (write (assq-ref info 'result)))
+    (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)))))
    ((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))
@@ -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)))))
+   ((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))) res))))
-      (list->vector (apply map proc (map vector->list (cons vec lov))))))
+            (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)
@@ -82,7 +82,11 @@
         (test '#f16(1 2)
           (vector->f16vector '#(0 1 2 3) 1 3))
         (test '#(1.0 2.0)
-          (f16vector->vector '#f16(0 1 2 3) 1 3))
+            (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))
@@ -3338,7 +3351,7 @@
                (make-interval (quote #(1 -6 -1 3))
                               (quote #(5 -5 5 8)))
                '(3 1 6 2 8 0 8 1 2 6 7 2 9 4 6 5 2 4 5 4 5 2 6 6 0 6 4 2 1 3 4 6 9 6 7 2 4 8 4 3 5 5 8 0 6 4 6 3 7 6 3 4 1 6 2 3 1 9 1 0 3 1 5 0 3 5 8 1 8 0 2 3 1 5 0 4 9 5 3 2 0 7 6 5 5 9 4 8 5 3 2 5 1 4 8 4 5 7 4 6 1 5 8 2 0 1 5 0 8 3 0 4 6 1 7 1 7 1 6 9)))))
-        (test-assert
+        '(test-assert
             (array-append
              0
              (list 
@@ -3774,16 +3787,19 @@
                             '#(2 1))
               (make-interval '#(8))
               #t)))
-        (test '(() ())
-            (array->list*
-             (specialized-array-reshape
-              (make-specialized-array (make-interval '#(1 2 0 4)))
-              (make-interval '#(2 0 4)))))
+        (let ((a (specialized-array-reshape
+                  (make-specialized-array (make-interval '#(1 2 0 4)))
+                  (make-interval '#(2 0 4)))))
+          (test '((0 0 0) (2 0 4))
+              (list (interval-lower-bounds->list (array-domain a))
+                    (interval-upper-bounds->list (array-domain a))))
+          (test '(() ())
+              (array->list* a)))
         (test 'foo
             (array->list*
              (specialized-array-reshape ;; Reshape to a zero-dimensional array
-              (array-extract            ;; Restrict to the first element
-               (make-specialized-array-from-data  ;; One-dimensional array
+              (array-extract ;; Restrict to the first element
+               (make-specialized-array-from-data ;; One-dimensional array
                 (vector 'foo 'bar 'baz))
                (make-interval '#(1)))
               (make-interval '#()))))

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

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,16 +3217,23 @@ 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,
-    m = (x&0x03FF)<<13,
-    v = float_as_int((float)m)>>23;
+  unsigned int e, m, v;
+  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,
-    e = (b&0x7F800000)>>23,
-    m = b&0x007FFFFF;
+  unsigned int b, e, m;
+  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;
 }
 #endif

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)

tools/snow-chibi.scm

@@ -90,6 +90,7 @@
     (chibi-path filename "path to chibi-scheme executable")
     (cc string "path to c compiler")
     (cflags string "flags for c compiler")
+    (foreign-depends (list string) "foreign libraries library depends on")
     (use-curl? boolean ("use-curl") "use curl for file uploads")
     (sexp? boolean ("sexp") "output information in sexp format")
     ))

vm.c

@@ -912,12 +912,12 @@ static sexp sexp_restore_stack (sexp ctx, sexp saved) {
   return SEXP_VOID;
 }
 
-#define _ARG1 stack[top-1]
-#define _ARG2 stack[top-2]
-#define _ARG3 stack[top-3]
-#define _ARG4 stack[top-4]
-#define _ARG5 stack[top-5]
-#define _ARG6 stack[top-6]
+#define _ARG1 (stack[top-1])
+#define _ARG2 (stack[top-2])
+#define _ARG3 (stack[top-3])
+#define _ARG4 (stack[top-4])
+#define _ARG5 (stack[top-5])
+#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
-      _ARG1 = sexp_fx_div(tmp1, tmp2);
+      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);
-      _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 (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_USE_BIGNUMS