Merge remote-tracking branch 'origin/master' into snow-chibi-gambit

Makefile

@@ -415,12 +415,7 @@ install-base: all
 	$(INSTALL) -m0644 doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/
 	-if type $(LDCONFIG) >/dev/null 2>/dev/null; then $(LDCONFIG) >/dev/null 2>/dev/null; fi
 
-install-bash-completion:
+install: install-base
-	if [ -d "/etc/bash_completion.d" ]; then \
-			cp tools/snow-chibi-completion.bash /etc/bash_completion.d/snow-chibi; \
-		fi
-
-install: install-base install-bash-completion
 ifneq "$(IMAGE_FILES)" ""
 	echo "Generating images"
 	-[ -z "$(DESTDIR)" ] && LD_LIBRARY_PATH="$(SOLIBDIR):$(LD_LIBRARY_PATH)" DYLD_LIBRARY_PATH="$(SOLIBDIR):$(DYLD_LIBRARY_PATH)" CHIBI_MODULE_PATH="$(MODDIR):$(BINMODDIR)" $(BINDIR)/chibi-scheme$(EXE) -mchibi.repl -d $(MODDIR)/chibi.img
@@ -502,7 +497,6 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
 	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
 	-$(RM) $(DESTDIR)$(PKGCONFDIR)/chibi-scheme.pc
-	-$(RM) /etc/bash_completion.d/snow-chibi
 
 dist: distclean
 	$(RM) chibi-scheme-$(CHIBI_VERSION).tgz

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,18 +1652,20 @@ 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{gambit}
+\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{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")))
@@ -1373,6 +1377,11 @@
     ((gambit)
      (list (string-append (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
@@ -1401,6 +1410,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"
@@ -1493,6 +1506,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))))))
 
@@ -1634,7 +1651,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
@@ -1646,8 +1670,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
@@ -1688,7 +1711,9 @@
    ((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 '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)))
@@ -1699,6 +1724,8 @@
    ((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 '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)))
@@ -1714,12 +1741,16 @@
                            (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 '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

@@ -29,6 +29,8 @@
             ,(delay
                (process->sexp
                 '(gsc -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
@@ -46,7 +48,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))
@@ -66,6 +72,7 @@
     ((gambit) (cond-expand (gambit #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/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-completion.bash

@@ -1,12 +0,0 @@
-#/usr/bin/env bash
-
-_snow_chibi_completions() {
-    if [ "${#COMP_WORDS[@]}" -gt "2" ]
-    then
-        COMPREPLY=($(compgen -f -- "${COMP_WORDS[COMP_CWORD]}"))
-    else
-        COMPREPLY=($(compgen -W "search show install upgrade remove status package gen-key reg-key sign verify upload index update implementations help" "${COMP_WORDS[COMP_CWORD]}"))
-    fi
-}
-
-complete -o bashdefault -F _snow_chibi_completions snow-chibi

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