Merge 31a3316bf2 into 77a4fbd5ba

Issue #1030.

.gitignore

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

doc/chibi.scrbl

@@ -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.
 
@@ -1613,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
@@ -1630,17 +1652,19 @@ 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}
+several other R7RS implementations and generic installation of libraries.
-command tells you which you currently have installed.  The following
+The \scheme{implementations} command tells you which you currently have
-are currently supported:
+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{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{larceny - version 0.98; you need to add "lib/Snow" to the paths in startup.sch}
 \item{sagittarius - version >= 0.98}
+\item{stklos - version > 2.10}
 ]

lib/chibi/repl.scm

@@ -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!)
@@ -429,27 +432,26 @@
                 (lambda ()
                   (if (or (identifier? expr)
                           (pair? expr)
-                          (null? expr))
+                          (null? expr)
-                      (eval expr (repl-env rp))
+                          (not (eq? eval (repl-eval rp))))
+                      ((or (repl-eval rp) eval) expr (repl-env rp))
                       expr))
               (lambda res-values
                 (cond
                  ((not (or (null? res-values)
                            (equal? res-values (list undefined-value))))
                   (push-history-value-maybe! res-values)
-                  (repl-print (car res-values) out)
+                  ((or (repl-printer rp) repl-print) (car res-values) out)
                   (for-each
                    (lambda (res)
                      (write-char #\space out)
-                     (repl-print res out))
+                     ((or (repl-printer rp) repl-print) res out))
                    (cdr res-values))
                   (newline out))))))
           expr-list))))))
 
-(define (repl/eval-string rp str)
+(define (repl-string->sexps rp str)
-  (repl/eval
+  (protect (exn (else (print-exception exn (current-error-port))))
-   rp
-   (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))
@@ -458,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
@@ -466,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
@@ -489,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/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
+    (if (null? body)
-     (each
+        (c-wrap-stmt
-      (c-braced-block
+         (each type (if (and name (not (equal? name ""))) (each " " name) "")))
-       (each type
+        (c-wrap-stmt
-             (if (and name (not (equal? name "")))
+         (each
-                 (each " " name)
+          (c-braced-block
-                 nothing))
+           (each type
-       (each
+                 (if (and name (not (equal? name "")))
-        (c-in-stmt
+                     (each " " name)
-         (if (list? body)
+                     nothing))
-             (apply c-begin (map c-wrap-stmt (map c-param body)))
+           (each
-             (c-wrap-stmt (c-expr body))))))
+            (c-in-stmt
-      (if (pair? o) (each " " (apply c-begin o)) nothing)))))
+             (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?
+      (or (equal? (car spec) 'generic)
-           (yes-or-no? cfg "Implementation " (car spec) " does not "
+          (and confirm?
-                       " seem to be available, install anyway?"))))
+               (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 '()))
@@ -1361,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")))
@@ -1370,6 +1374,11 @@
                       (string-trim (process->string '(icyc -p "(Cyc-installation-dir 'sld)"))
                                    char-whitespace?)))))
        (list (or dir "/usr/local/share/cyclone/"))))
+    ((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
@@ -1398,6 +1407,10 @@
                    "(begin (display (getenv \"LARCENY_ROOT\")) (exit))"))
         char-whitespace?)
        "lib/Snow")))
+    ((stklos)
+     (list (make-path
+            (process->string
+             '(stklos -e "(display (install-path #:libdir))")))))
     (else
      (list (make-path (or (conf-get cfg 'install-prefix) "/usr/local")
                       "share/snow"
@@ -1486,6 +1499,10 @@
              `(larceny -r7rs -path ,(string-append install-dir ":" lib-path)
                        -program ,file)
              `(larceny -r7rs -path ,install-dir -program ,file)))
+        ((stklos)
+         (if lib-path
+             `(stklos -A ,install-dir -A ,lib-path ,file)
+             `(stklos -A ,install-dir ,file)))
         (else
          #f))))))
 
@@ -1626,7 +1643,14 @@
     (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)
+    (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
@@ -1638,8 +1662,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
@@ -1679,7 +1702,9 @@
   (cond
    ((eq? impl 'chicken) (get-install-library-dir impl cfg))
    ((eq? impl 'cyclone) (get-install-library-dir impl cfg))
+   ((eq? impl 'generic) (get-install-library-dir impl cfg))
    ((eq? impl 'guile) (get-guile-site-dir))
+   ((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)))
@@ -1689,6 +1714,8 @@
   (cond
    ((eq? impl 'chicken) (get-install-library-dir impl cfg))
    ((eq? impl 'cyclone) (get-install-library-dir impl cfg))
+   ((eq? impl 'generic) (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)))
@@ -1704,10 +1731,14 @@
                            (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 'guile)
     (get-guile-site-ccache-dir))
+   ((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)))

lib/chibi/snow/utils.scm

@@ -25,6 +25,8 @@
             ,(delay
                (process->sexp
                 '(foment -e "(write (features))"))))
+    (generic "generic" #f #f
+            ,(delay (write-string "generic\n")))
     (gauche "gosh" (gosh -E "print (gauche-version)") "0.9.4"
             ,(delay
                (process->sexp
@@ -42,7 +44,11 @@
     (sagittarius "sagittarius" #f #f
                  ,(delay
                     (process->sexp
-                     '(sagittarius -I "(scheme base)" -e "(write (features))"))))))
+                     '(sagittarius -I "(scheme base)" -e "(write (features))"))))
+    (stklos "stklos" (stklos --version) #f
+                 ,(delay
+                    (process->sexp
+                     '(stklos -e "(write (features))"))))))
 
 (define (impl->version impl cmd)
   (let* ((lines (process->string-list cmd))
@@ -61,6 +67,7 @@
     ((chibi) (cond-expand (chibi #t) (else #f)))
     ((gauche) (cond-expand (gauche #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/syntax-case.scm

@@ -77,7 +77,7 @@
 
 (define (make-pattern-variable pvar)
   (lambda (expr)
-    (error "reference to pattern variable outside syntax" pvar)))
+    (syntax-violation #f "reference to pattern variable outside syntax" pvar)))
 
 (define (pattern-variable x)
   (and-let*
@@ -163,7 +163,9 @@
                     ((out envs)
                      (gen-template (car tmpl) (cons '() envs) ell? level)))
         (if (null? (car envs))
-            (error "too many ellipses following syntax template" (car tmpl)))
+            (syntax-violation 'syntax
+                              "too many ellipses following syntax template"
+                              (car tmpl)))
         (values `(,(rename 'fold-right) (,(rename 'lambda) (,@(car envs) ,(rename 'stx))
                                          (,(rename 'cons) ,out ,(rename 'stx)))
                   ,out* ,@(car envs))
@@ -180,7 +182,9 @@
       (values `(,(rename 'list->vector) ,out) envs)))
    ((identifier? tmpl)
     (cond ((ell? tmpl)
-           (error "misplaced ellipsis in syntax template" tmpl))
+           (syntax-violation 'syntax
+                             "misplaced ellipsis in syntax template"
+                             tmpl))
           ((pattern-variable tmpl) =>
            (lambda (binding)
              (values (car binding)
@@ -199,7 +203,7 @@
     (cond ((zero? level)
            envs)
           ((null? envs)
-           (error "too few ellipses following syntax template" id))
+           (syntax-violation #f "too few ellipses following syntax template" id))
           (else
            (let ((outer-envs (loop (- level 1) (cdr envs))))
              (cond ((member x (car envs) bound-identifier=?)
@@ -214,7 +218,7 @@
      (let ((expr (cadr expr))
            (lit* (car (cddr expr)))
            (clause* (reverse (cdr (cddr expr))))
-           (error #'(error "syntax error" e)))
+           (error #`(syntax-violation #f "syntax error" e)))
        #`(let ((e #,expr))
            #,(if (null? clause*)
                  error
@@ -294,7 +298,7 @@
                            (fail)))
                    vars))
           ((ellipsis-identifier? pattern)
-           (error "misplaced ellipsis" pattern))
+           (syntax-violation #f "misplaced ellipsis" pattern))
           ((free-identifier=? pattern #'_)
            (values (lambda (k)
                      (k))
@@ -370,8 +374,19 @@
        #'(syntax-case (list e0 ...) ()
            ((p ...) (let () e1 e2 ...)))))))
 
-(define (syntax-violation who message . form*)
+(define (syntax-violation who message form . maybe-subform)
-  (apply error message form*))
+  (raise (condition (make-syntax-violation form
+                                           (if (null? maybe-subform)
+                                               #f
+                                               (car maybe-subform)))
+                    (cond (who => make-who-condition)
+                          ((identifier? form)
+                           (make-who-condition (syntax->datum form)))
+                          ((and (pair? form)
+                                (identifier? (car form)))
+                           (make-who-condition (syntax->datum (car form))))
+                          (else (condition)))
+                    (make-message-condition message))))
 
 (define-syntax define-current-ellipsis
   (lambda (stx)

lib/chibi/syntax-case.sld

@@ -14,6 +14,7 @@
                 procedure-arity procedure-variadic?
                 procedure-variable-transformer?
                 make-variable-transformer)
+          (rnrs conditions)
           (only (meta) environment)
           (srfi 1)
           (srfi 2)

lib/meta-7.scm

@@ -355,6 +355,60 @@
 (define-syntax define-library define-library-transformer)
 (define-syntax module define-library-transformer)
 
+(define r6rs-library-transformer
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (clean-up-r6rs-library-name name)
+       (define (srfi-number->exact-integer component)
+         (if (symbol? component)
+             (let* ((symbol-name (symbol->string component)))
+               (if (and (char=? (string-ref symbol-name 0) #\:)
+                        (every char-numeric?
+                               (cdr (string->list symbol-name))))
+                   (string->number maybe-number-as-string)
+                   #f))
+             #f))
+       (apply append
+              (map
+               (lambda (component)
+                 (cond ((list? component) ; ignore version numbers
+                        '())
+                       ((srfi-number->exact-integer component) => list)
+                       (else (list component))))
+               name)))
+     (define (clean-up-r6rs-import import-spec)
+       (cond ((identifier? import-spec) import-spec)
+             ((memq (car import-spec)
+                    '(only except prefix rename))
+              (cons (car import-spec)
+                    (cons (clean-up-r6rs-library-name (cadr import-spec))
+                          (cddr import-spec))))
+             ((memq (car import-spec)
+                    '(library for))
+              (clean-up-r6rs-library-name (cadr import-spec)))
+             (else (clean-up-r6rs-library-name import-spec))))
+
+     (if (not (eq? (car expr) 'library))
+       (error "r6rs-library-transformer: I expect to process declarations called library, but this was a new one to me" (car expr)))
+     (if (not (and (list? expr)
+                   (>= (length expr) 3)
+                   (list? (list-ref expr 1))
+                   (list? (list-ref expr 2))
+                   (eq? (car (list-ref expr 2)) 'export)
+                   (list? (list-ref expr 3))
+                   (eq? (car (list-ref expr 3)) 'import)))
+       (error "r6rs-library-transformer: the form of a library declaration is (library <name> (export <export-spec> ...) (import <import-spec> ...) <defexpr> ...)" expr))
+     (let ((library-name (clean-up-r6rs-library-name (list-ref expr 1)))
+           (exports (cdr (list-ref expr 2)))
+           (imports (map clean-up-r6rs-import (cdr (list-ref expr 3))))
+           (body (cddr (cddr expr))))
+       `(define-library ,library-name
+          (export ,@exports)
+          (import ,@imports)
+          (begin ,@body))))))
+
+(define-syntax library r6rs-library-transformer)
+
 (define-syntax pop-this-path
   (er-macro-transformer
    (lambda (expr rename compare)

lib/rnrs/base.sld

@@ -0,0 +1,267 @@
+(library (rnrs base)
+  (export *
+          +
+          -
+          ...
+          /
+          <
+          <=
+          =
+          =>
+          >
+          >=
+          _
+          abs
+          acos
+          and
+          angle
+          append
+          apply
+          asin
+          assert
+          assertion-violation
+          atan
+          begin
+          boolean=?
+          boolean?
+          caaaar
+          caaadr
+          caaar
+          caadar
+          caaddr
+          caadr
+          caar
+          cadaar
+          cadadr
+          cadar
+          caddar
+          cadddr
+          caddr
+          cadr
+          call-with-current-continuation
+          call-with-values
+          call/cc
+          car
+          case
+          cdaaar
+          cdaadr
+          cdaar
+          cdadar
+          cdaddr
+          cdadr
+          cdar
+          cddaar
+          cddadr
+          cddar
+          cdddar
+          cddddr
+          cdddr
+          cddr
+          cdr
+          ceiling
+          char->integer
+          char<=?
+          char<?
+          char=?
+          char>=?
+          char>?
+          char?
+          complex?
+          cond
+          cons
+          cos
+          define
+          define-syntax
+          denominator
+          div
+          div-and-mod
+          div0
+          div0-and-mod0
+          dynamic-wind
+          else
+          eq?
+          equal?
+          eqv?
+          error
+          even?
+          exact
+          exact-integer-sqrt
+          exact?
+          exp
+          expt
+          finite?
+          floor
+          for-each
+          gcd
+          identifier-syntax
+          if
+          imag-part
+          inexact
+          inexact?
+          infinite?
+          integer->char
+          integer-valued?
+          integer?
+          lambda
+          lcm
+          length
+          let
+          let*
+          let*-values
+          let-syntax
+          let-values
+          letrec
+          letrec*
+          letrec-syntax
+          list
+          list->string
+          list->vector
+          list-ref
+          list-tail
+          list?
+          log
+          magnitude
+          make-polar
+          make-rectangular
+          make-string
+          make-vector
+          map
+          max
+          min
+          mod
+          mod0
+          nan?
+          negative?
+          not
+          null?
+          number->string
+          number?
+          numerator
+          odd?
+          or
+          pair?
+          positive?
+          procedure?
+          quasiquote
+          quote
+          rational-valued?
+          rational?
+          rationalize
+          real-part
+          real-valued?
+          real?
+          reverse
+          round
+          set!
+          sin
+          sqrt
+          string
+          string->list
+          string->number
+          string->symbol
+          string-append
+          string-copy
+          string-for-each
+          string-length
+          string-ref
+          string<=?
+          string<?
+          string=?
+          string>=?
+          string>?
+          string?
+          substring
+          symbol->string
+          symbol=?
+          symbol?
+          syntax-rules
+          tan
+          truncate
+          unquote
+          unquote-splicing
+          values
+          vector
+          vector->list
+          vector-fill!
+          vector-for-each
+          vector-length
+          vector-map
+          vector-ref
+          vector-set!
+          vector?
+          zero?)
+  (import (except (scheme base)
+                  define-syntax
+                  let-syntax
+                  letrec-syntax
+                  syntax-rules)
+          (scheme cxr)
+          (scheme inexact)
+          (scheme complex)
+          (rnrs conditions)
+          (only (srfi 1) every)
+          (rename (srfi 141)
+                  (euclidean-quotient div)
+                  (euclidean-remainder mod)
+                  (euclidean/ div-and-mod)
+                  (balanced-quotient div0)
+                  (balanced-remainder mod0)
+                  (balanced/ div0-and-mod0))
+          (rename (chibi syntax-case)
+                  (splicing-let-syntax let-syntax)
+                  (splicing-letrec-syntax letrec-syntax))
+          (except (chibi ast) error)
+          (chibi show))
+
+  (define-syntax syntax-rules
+    (lambda (x)
+      (syntax-case x ()
+        ((_ (lit ...) ((k . p) t) ...)
+         (every identifier? #'(lit ... k ...))
+         #'(lambda (x)
+             (syntax-case x (lit ...)
+               ((_ . p) #'t) ...))))))
+
+  (define-syntax identifier-syntax
+    (lambda (x)
+      (syntax-case x (set!)
+        ((_ e)
+         #'(lambda (x)
+             (syntax-case x ()
+               (id (identifier? #'id) #'e)
+               ((_ x (... ...)) #'(e x (... ...))))))
+        ((_ (id exp1) ((set! var val) exp2))
+         (and (identifier? #'id) (identifier? #'var))
+         #'(make-variable-transformer
+            (lambda (x)
+              (syntax-case x (set!)
+                ((set! var val) #'exp2)
+                ((id x (... ...)) #'(exp1 x (... ...)))
+                (id (identifier? #'id) #'exp1))))))))
+
+  (define-syntax assert
+    (syntax-rules ()
+      ((_ expr)
+         (if (not expr)
+             (assertion-violation #f "assertion failed" (quote expr))))))
+
+  (define (%error make-base who message irritants)
+    (assert (or (not who) (symbol? who) (string? who)))
+    (assert (string? message))
+    (raise (condition (make-base)
+                      (if who (make-who-condition who) (condition))
+                      (make-message-condition message)
+                      (make-irritants-condition irritants))))
+  (define (error who message . irritants)
+    (%error make-error who message irritants))
+  (define (assertion-violation who message . irritants)
+    (%error make-assertion-violation who message irritants))
+
+  (define (real-valued? n) (zero? (imag-part n)))
+  (define (rational-valued? n)
+    (and (real-valued? n)
+         (not (nan? n))
+         (not (infinite? n))))
+  (define (integer-valued? n)
+    (and (rational-valued? n)
+         (integer? (real-part n)))))

lib/rnrs/conditions.sld

@@ -0,0 +1,101 @@
+(library (rnrs conditions)
+  (export &condition
+          (rename make-compound-condition condition)
+          simple-conditions
+          condition-predicate
+          condition-accessor
+          (rename define-condition-type/constructor define-condition-type)
+
+          ;; 7.3 Standard condition types
+          &message
+          make-message-condition
+          message-condition?
+          condition-message
+
+          &warning
+          make-warning
+          warning?
+
+          &serious
+          make-serious-condition
+          serious-condition?
+
+          &error
+          make-error
+          error?
+
+          &violation
+          make-violation
+          violation?
+
+          &assertion
+          make-assertion-violation
+          assertion-violation?
+
+          &irritants
+          make-irritants-condition
+          irritants-condition?
+          condition-irritants
+
+          &who
+          make-who-condition
+          who-condition?
+          condition-who
+
+          &non-continuable
+          make-non-continuable-violation
+          non-continuable-violation?
+
+          &implementation-restriction
+          make-implementation-restriction-violation
+          implementation-restriction-violation?
+
+          &lexical
+          make-lexical-violation
+          lexical-violation?
+
+          &syntax
+          make-syntax-violation
+          syntax-violation?
+          syntax-violation-form
+          syntax-violation-subform
+
+          &undefined
+          make-undefined-violation
+          undefined-violation?)
+  (import (srfi 35 internal))
+
+  (define-condition-type/constructor &warning &condition
+    make-warning warning?)
+
+  (define-condition-type/constructor &violation &serious
+    make-violation violation?)
+
+  (define-condition-type/constructor &assertion &violation
+    make-assertion-violation assertion-violation?)
+
+  (define-condition-type/constructor &irritants &condition
+    make-irritants-condition irritants-condition?
+    (irritants condition-irritants))
+
+  (define-condition-type/constructor &who &condition
+    make-who-condition who-condition?
+    (who condition-who))
+
+  (define-condition-type/constructor &non-continuable &violation
+    make-non-continuable-violation non-continuable-violation?)
+
+  (define-condition-type/constructor &implementation-restriction &violation
+    make-implementation-restriction-violation
+    implementation-restriction-violation?)
+
+  (define-condition-type/constructor &lexical &violation
+    make-lexical-violation lexical-violation?)
+
+  (define-condition-type/constructor &syntax &violation
+    make-syntax-violation syntax-violation?
+    (form syntax-violation-form)
+    (subform syntax-violation-subform))
+
+  (define-condition-type/constructor &undefined &violation
+    make-undefined-violation undefined-violation?))

lib/rnrs/control.sld

@@ -0,0 +1,6 @@
+(library (rnrs control)
+  (export when unless
+          do
+          case-lambda)
+  (import (scheme base)
+          (scheme case-lambda)))

lib/rnrs/eval.sld

@@ -0,0 +1,4 @@
+(library (rnrs eval)
+  (export eval
+          environment)
+  (import (scheme eval)))

lib/rnrs/lists.sld

@@ -0,0 +1,35 @@
+(library (rnrs lists)
+  (export find
+          (rename every for-all)
+          (rename any exists)
+          filter partition
+          fold-left
+          fold-right
+          (rename remove remp)
+          (rename rnrs:remove remove)
+          remv
+          remq
+          (rename find-tail memp)
+          member
+          memv
+          memq
+          assp
+          assoc
+          assv
+          assq
+          cons*)
+  (import (scheme base)
+          (srfi 1))
+
+  (define (fold-left kons knil . lss)
+    (apply fold
+           (lambda args
+             (apply kons (last args) (drop-right args 1)))
+           knil lss))
+
+  (define (rnrs:remove obj ls) (remove (lambda (x) (equal? x obj)) ls))
+  (define (remv obj ls) (remove (lambda (x) (eqv? x obj)) ls))
+  (define (remq obj ls) (remove (lambda (x) (eq? x obj)) ls))
+
+  (define (assp proc alist)
+    (find (lambda (x) (proc (car x))) alist)))

lib/rnrs/mutable-pairs.sld

@@ -0,0 +1,3 @@
+(library (rnrs mutable-pairs)
+  (export set-car! set-cdr!)
+  (import (scheme base)))

lib/rnrs/mutable-strings.sld

@@ -0,0 +1,4 @@
+(library (rnrs mutable-strings)
+  (export string-set!
+          string-fill!)
+  (import (scheme base)))

lib/rnrs/programs.sld

@@ -0,0 +1,4 @@
+(library (rnrs programs)
+  (export command-line
+          exit)
+  (import (scheme process-context)))

lib/rnrs/sorting.sld

@@ -0,0 +1,5 @@
+(library (rnrs sorting)
+  (export (rename list-stable-sort list-sort)
+          (rename vector-stable-sort vector-sort)
+          (rename vector-stable-sort! vector-sort!))
+  (import (srfi 132)))

lib/rnrs/syntax-case.sld

@@ -0,0 +1,17 @@
+(library (rnrs syntax-case)
+  (export make-variable-transformer
+          syntax-case
+          syntax
+          identifier?
+          bound-identifier=?
+          free-identifier=?
+          syntax->datum
+          datum->syntax
+          generate-temporaries
+          with-syntax
+          quasisyntax
+          unsyntax
+          unsyntax-splicing
+          syntax-violation)
+  (import (chibi ast)
+          (chibi syntax-case)))

lib/srfi/231/test.sld

@@ -3351,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 
@@ -3787,16 +3787,19 @@
                             '#(2 1))
               (make-interval '#(8))
               #t)))
-        (test '(() ())
+        (let ((a (specialized-array-reshape
-            (array->list*
+                  (make-specialized-array (make-interval '#(1 2 0 4)))
-             (specialized-array-reshape
+                  (make-interval '#(2 0 4)))))
-              (make-specialized-array (make-interval '#(1 2 0 4)))
+          (test '((0 0 0) (2 0 4))
-              (make-interval '#(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
+              (array-extract ;; Restrict to the first element
-               (make-specialized-array-from-data  ;; One-dimensional array
+               (make-specialized-array-from-data ;; One-dimensional array
                 (vector 'foo 'bar 'baz))
                (make-interval '#(1)))
               (make-interval '#()))))

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