Various snow bugfixes.

lib/chibi/doc.scm

@@ -877,6 +877,24 @@ div#footer {padding-bottom: 50px}
         ((macro? x) (macro-source x))
         (else #f)))
 
+;; helper for below functions
+(define (extract-module-docs-from-files mod srcs includes stubs strict? exports)
+  (let ((defs (map (lambda (x)
+                     (let ((val (and mod (module-ref mod x))))
+                       `(,x ,val ,(object-source val))))
+                   exports)))
+    (append
+     (reverse
+      (append-map (lambda (x)
+                    (extract-file-docs mod x defs strict? 'module))
+                  srcs))
+     (reverse
+      (append-map (lambda (x) (extract-file-docs mod x defs strict?))
+                  includes))
+     (reverse
+      (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+                  stubs)))))
+
 ;;> Extract the literate Scribble docs from module \var{mod-name} and
 ;;> return them as sxml.  If \var{strict?} is true ignore docs for
 ;;> unexported values, defined by the optional \var{exports} which
@@ -885,26 +903,44 @@ div#footer {padding-bottom: 50px}
 (define (extract-module-docs mod-name strict? . o)
   (let ((mod (load-module mod-name)))
     (if (not mod)
-        (error "couldn't find module" mod-name)
+        (error "couldn't find module" mod-name))
     (let* ((exports (if (pair? o) (car o) (module-exports mod)))
-               (defs
+           (srcs
-                 (map (lambda (x)
-                        (let ((val (module-ref mod x)))
-                          `(,x ,val ,(object-source val))))
-                      exports)))
             (append
-           (cond
+             (cond ((find-module-file (module-name->file mod-name)) => list)
-            ((find-module-file (module-name->file mod-name))
-             => (lambda (f)
-                  (reverse (extract-file-docs mod f defs strict? 'module))))
                    (else '()))
-           (reverse
+             (module-include-library-declarations mod))))
-            (append-map (lambda (x)
+      (extract-module-docs-from-files
-                          (extract-file-docs mod x defs strict? 'module))
+       mod srcs (module-includes mod) (module-shared-includes mod)
-                        (module-include-library-declarations mod)))
+       strict? exports))))
-           (reverse
+
-            (append-map (lambda (x) (extract-file-docs mod x defs strict?))
+;;> As above, but extracts docs for the module defined in \var{file},
-                        (module-includes mod)))
+;;> which need not be in the search path.
-           (reverse
+
-            (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+(define (extract-module-file-docs file strict? . o)
-                        (module-shared-includes mod))))))))
+  (let ((forms (file->sexp-list file)))
+    (if (not (and (pair? forms) (pair? (car forms))
+                  (memq (caar forms) '(define-library library))))
+        (error "file doesn't define a library" file))
+    (let* ((mod-form (car forms))
+           (mod-name (cadr mod-form)))
+      (load file (vector-ref (find-module '(meta)) 1))
+      (let ((mod (load-module mod-name)))
+        (define (get-forms name)
+          (append-map
+           (lambda (x) (if (and (pair? x) (eq? name (car x))) (cdr x) '()))
+           (cddr mod-form)))
+        (define (get-exports)
+          (if mod (module-exports mod) (get-forms 'exports)))
+        (define (get-decls)
+          (if mod
+              (module-include-library-declarations mod)
+              (get-forms 'include-library-declarations)))
+        (define (get-includes)
+          (if mod (module-includes mod) (get-forms 'include)))
+        (define (get-shared-includes)
+          (if mod (module-shared-includes mod) (get-forms 'shared-include)))
+        (let* ((exports (if (pair? o) (car o) (get-exports)))
+               (srcs (cons file (get-decls))))
+          (extract-module-docs-from-files
+           mod srcs (get-includes) (get-shared-includes) strict? exports))))))

lib/chibi/doc.sld

@@ -9,6 +9,6 @@
   (export procedure-docs print-procedure-docs
           print-module-docs print-module-binding-docs
           generate-docs expand-docs fixup-docs
-          extract-module-docs extract-file-docs
+          extract-module-docs extract-module-file-docs extract-file-docs
           make-default-doc-env make-module-doc-env)
   (include "doc.scm"))

lib/chibi/modules.sld

@@ -6,6 +6,6 @@
           analyze-module containing-module load-module module-exports
           module-name->file procedure-analysis find-module
           available-modules-in-directory available-modules
-          modules-exporting-identifier)
+          modules-exporting-identifier file->sexp-list)
   (import (chibi) (meta) (srfi 1) (chibi ast) (chibi filesystem))
   (include "modules.scm"))

lib/chibi/net/server-util.scm

@@ -91,29 +91,3 @@
         (if (equal? mtype "text/html")
             (string-append mtype "; charset=UTF-8")
             mtype)))))
-
-(define (call-with-temp-file template proc)
-  (let ((base (string-append
-               "/tmp/" (path-strip-extension template)
-               "-" (number->string (current-process-id)) "-"
-               (number->string (round (current-seconds))) "-"))
-        (ext (path-extension template)))
-    (let lp ((i 0))
-      (let ((path (string-append base (number->string i) "." ext)))
-        (cond
-         ((> i 100)  ;; give up after too many tries regardless
-          (error "Repeatedly failed to generate temp file in /tmp"))
-         ((file-exists? path)
-          (lp (+ i 1)))
-         (else
-          (let ((fd (open path
-                          (bitwise-ior open/write open/create open/exclusive))))
-            (if (not fd)
-                (if (file-exists? path) ;; created between test and open
-                    (lp (+ i 1))
-                    (error "Couldn't generate temp file in /tmp " path))
-                (let* ((out (open-output-file-descriptor fd #o700))
-                       (res (proc path out)))
-                  (close-output-port out)
-                  (delete-file path)
-                  res)))))))))

lib/chibi/net/server-util.sld

@@ -2,6 +2,7 @@
 (define-library (chibi net server-util)
   (import (chibi) (chibi io) (chibi net) (chibi string) (chibi uri)
           (chibi process) (chibi time) (chibi pathname) (chibi filesystem)
+          (chibi temp-file)
           (srfi 33) (srfi 69))
   (export line-handler command-handler parse-command
           get-host file-mime-type call-with-temp-file)

lib/chibi/process.scm

@@ -111,6 +111,15 @@
                    (open-input-file-descriptor (car out-pipe))
                    (open-input-file-descriptor (car err-pipe)))))))))
 
+(define (process->bytevector command)
+  (call-with-process-io
+   command
+   (lambda (pid in out err)
+     (close-output-port in)
+     (let ((res (port->bytevector out)))
+       (waitpid pid 0)
+       res))))
+
 (define (process->string command)
   (call-with-process-io
    command

lib/chibi/process.sld

@@ -14,7 +14,7 @@
           signal/user2      signal/child       signal/continue
           signal/stop       signal/tty-stop    signal/tty-input
           signal/tty-output wait/no-hang
-          call-with-process-io
+          call-with-process-io process->bytevector
           process->string process->sexp process->string-list
           process->output+error process->output+error+status)
   (import (chibi) (chibi io) (chibi string) (chibi filesystem))

lib/chibi/snow/commands.scm

@@ -317,29 +317,6 @@
                                         ".sld"))))
          (and (file-exists? dep-file) dep-file))))
 
-(define (extract-module-file-docs cfg path)
-  (define (object-source x)
-    (cond ((bytecode? x)
-           (let ((src (bytecode-source x)))
-             (if (and (vector? src) (positive? (vector-length src)))
-                 (vector-ref src 0)
-                 src)))
-          ((procedure? x) (object-source (procedure-code x)))
-          ((macro? x) (macro-source x))
-          (else #f)))
-  (let* ((lib+files (extract-library cfg path))
-         (lib-name (library-name (car lib+files)))
-         (exports (cond ((assq 'export (cdar lib+files)) => cdr) (else '())))
-         (mod (guard (exn (else #f))
-                (begin
-                  (load path (environment '(meta)))
-                  (load-module lib-name))))
-         (defs (map (lambda (x)
-                      (let ((val (and mod (module-ref mod x))))
-                        `(,x ,val ,(object-source val))))
-                    exports)))
-    (reverse (extract-file-docs mod path defs #f 'module))))
-
 (define (package-docs cfg spec libs lib-dirs)
   (guard (exn (else (warn "package-docs failed" exn)
                     '()))
@@ -349,7 +326,7 @@
       (filter-map
        (lambda (lib)
          (let ((lib-name (library-file-name lib))
-               (docs (extract-module-file-docs cfg lib)))
+               (docs (extract-module-file-docs lib #f)))
            (and (pair? docs)
                 (not (and (= 1 (length docs)) (eq? 'subsection (caar docs))))
                 `(inline
@@ -551,7 +528,9 @@
                                   (if (pair? test) (cadr test) test))))
                         '())
                   ,@test-depends)
-                (reverse (if test (cons test (append docs files)) files)))))))))
+                (reverse (if test
+                             (cons test (append docs files))
+                             (append docs files))))))))))
 
 (define (create-package spec files path)
   (gzip

lib/chibi/snow/commands.sld

@@ -17,6 +17,7 @@
   (import (scheme base)
           (scheme eval)
           (scheme file)
+          (scheme load)
           (scheme process-context)
           (scheme time)
           (scheme read)
@@ -49,6 +50,7 @@
           (chibi sxml)
           (chibi system)
           (chibi tar)
+          (chibi temp-file)
           (chibi uri)
           (chibi zlib))
   (include "commands.scm"))

lib/chibi/snow/utils.scm

@@ -8,46 +8,3 @@
       (let ((n (read-u8 in)))
         (cond ((eof-object? n) (close-input-port in) (close-output-port out))
               (else (write-u8 n out) (lp)))))))
-
-(define (call-with-temp-file template proc)
-  (let ((base (string-append
-               "/tmp/" (path-strip-extension template)
-               "-" (number->string (current-process-id)) "-"
-               (number->string (exact (round (current-second)))) "-"))
-        (ext (or (path-extension template) "tmp")))
-    (let lp ((i 0))
-      (let ((path (string-append base (number->string i) "." ext)))
-        (cond
-         ((> i 100)  ;; give up after too many tries regardless
-          (die 2 "Repeatedly failed to generate temp file in /tmp"))
-         ((file-exists? path)
-          (lp (+ i 1)))
-         (else
-          (let ((fd (open path
-                          (bitwise-ior open/write open/create open/exclusive))))
-            (if (not fd)
-                (if (file-exists? path) ;; created between test and open
-                    (lp (+ i 1))
-                    (die 2 "Couldn't generate temp file in /tmp " path))
-                (let* ((out (open-output-file-descriptor fd #o700))
-                       (res (proc path out)))
-                  (close-output-port out)
-                  (delete-file path)
-                  res)))))))))
-
-(define (call-with-temp-dir template proc)
-  (let ((base (string-append
-               "/tmp/" template
-               "-" (number->string (current-process-id)) "-"
-               (number->string (exact (round (current-second)))) "-")))
-    (let lp ((i 0))
-      (let ((path (string-append base (number->string i))))
-        (cond
-         ((> i 100)  ;; give up after too many tries
-          (die 2 "Repeatedly failed to generate temp dir in /tmp " path))
-         ((file-exists? path)
-          (lp (+ i 1)))
-         ((create-directory path #o700)
-          (let ((res (proc path)))
-            (delete-file-hierarchy path)
-            res)))))))

lib/chibi/snow/utils.sld

@@ -1,6 +1,6 @@
 
 (define-library (chibi snow utils)
-  (export copy-file call-with-temp-file call-with-temp-dir)
+  (export copy-file)
   (import (scheme base)
           (scheme file)
           (scheme time)

lib/chibi/temp-file.scm

@@ -0,0 +1,43 @@
+
+(define (call-with-temp-file template proc)
+  (let ((base (string-append
+               "/tmp/" (path-strip-extension template)
+               "-" (number->string (current-process-id)) "-"
+               (number->string (exact (round (current-second)))) "-"))
+        (ext (or (path-extension template) "tmp")))
+    (let lp ((i 0))
+      (let ((path (string-append base (number->string i) "." ext)))
+        (cond
+         ((> i 100)  ;; give up after too many tries regardless
+          (error "Repeatedly failed to generate temp file in /tmp"))
+         ((file-exists? path)
+          (lp (+ i 1)))
+         (else
+          (let ((fd (open path
+                          (bitwise-ior open/write open/create open/exclusive))))
+            (if (not fd)
+                (if (file-exists? path) ;; created between test and open
+                    (lp (+ i 1))
+                    (error "Couldn't generate temp file in /tmp " path))
+                (let* ((out (open-output-file-descriptor fd #o700))
+                       (res (proc path out)))
+                  (close-output-port out)
+                  (delete-file path)
+                  res)))))))))
+
+(define (call-with-temp-dir template proc)
+  (let ((base (string-append
+               "/tmp/" template
+               "-" (number->string (current-process-id)) "-"
+               (number->string (exact (round (current-second)))) "-")))
+    (let lp ((i 0))
+      (let ((path (string-append base (number->string i))))
+        (cond
+         ((> i 100)  ;; give up after too many tries
+          (error "Repeatedly failed to generate temp dir in /tmp " path))
+         ((file-exists? path)
+          (lp (+ i 1)))
+         ((create-directory path #o700)
+          (let ((res (proc path)))
+            (delete-file-hierarchy path)
+            res)))))))

lib/chibi/temp-file.sld

@@ -0,0 +1,5 @@
+(define-library (chibi temp-file)
+  (export call-with-temp-file call-with-temp-dir)
+  (import (scheme base) (scheme time) (srfi 33)
+          (chibi filesystem) (chibi pathname) (chibi process))
+  (include "temp-file.scm"))

lib/chibi/zlib.scm

@@ -13,45 +13,59 @@
 
 ;; Utility to filter a bytevector to a process and return the
 ;; accumulated output as a new bytevector.
-(define (process-pipe-bytevector cmd bvec)
+;; (define (process-pipe-bytevector cmd bvec)
-  (call-with-process-io
+;;   (call-with-process-io
-   cmd
+;;    cmd
-   (lambda (pid proc-in proc-out proc-err)
+;;    (lambda (pid proc-in proc-out proc-err)
-     (let ((len (bytevector-length bvec))
+;;      (let ((len (bytevector-length bvec))
-           (out (open-output-bytevector)))
+;;            (out (open-output-bytevector)))
-       (let lp ((i 0))
+;;        (let lp ((i 0))
-         (cond
+;;          (cond
-          ((u8-ready? proc-out)
+;;           ((u8-ready? proc-out)
-           (let ((u8 (read-u8 proc-out)))
+;;            (let ((u8 (read-u8 proc-out)))
-             (cond
+;;              (cond
-              ((eof-object? u8)
+;;               ((eof-object? u8)
-               (get-output-bytevector out))
+;;                (get-output-bytevector out))
-              (else
+;;               (else
-               (write-u8 u8 out)
+;;                (write-u8 u8 out)
-               (lp i)))))
+;;                (lp i)))))
-          ((< i len)
+;;           ((< i len)
-           (write-u8 (bytevector-u8-ref bvec i) proc-in)
+;;            (write-u8 (bytevector-u8-ref bvec i) proc-in)
-           (if (= len (+ i 1))
+;;            (lp (+ i 1)))
-               (close-output-port proc-in))
+;;           (else
-           (lp (+ i 1)))
+;;            ;; Once we've completed sending the input we busy wait
-          (else
+;;            ;; until all output has been read.  We can't just waitpid
-           ;; Once we've completed sending the input we busy wait
+;;            ;; here because the remaining output may still overflow the
-           ;; until all output has been read.  We can't just waitpid
+;;            ;; pipe buffer.
-           ;; here because the remaining output may still overflow the
+;;            (close-output-port proc-in)
-           ;; pipe buffer.
+;;            (let lp ()
-           (lp i))))))))
+;;              (let ((u8 (read-u8 proc-out)))
+;;                (cond
+;;                 ((eof-object? u8)
+;;                  (get-output-bytevector out))
+;;                 (else
+;;                  (write-u8 u8 out)
+;;                  (lp))))))))))))
+
+;; Use a temp file to avoid dead-lock issues with pipes.
+(define (process-run-bytevector cmd bvec)
+  (call-with-temp-file "bvec"
+    (lambda (path out)
+      (write-bytevector bvec out)
+      (close-output-port out)
+      (process->bytevector (append cmd (list path))))))
 
 ;;> Gzip compress a string or bytevector in memory.
 
 (define (gzip x)
   (if (string? x)
       (gzip (string->utf8 x))
-      (process-pipe-bytevector '("gzip" "-c") x)))
+      (process-run-bytevector '("gzip" "-c") x)))
 
 ;;> Gunzip decompress a bytevector in memory.
 
 (define (gunzip bvec)
-  (process-pipe-bytevector '("gzip" "-c" "-d") bvec))
+  (process-run-bytevector '("gzip" "-c" "-d") bvec))
 
 ;;> Gunzip decompress a bytevector in memory if it has been
 ;;> compressed, or return as-is otherwise.

lib/chibi/zlib.sld

@@ -1,5 +1,6 @@
 
 (define-library (chibi zlib)
   (export gzip-file gunzip-file gzip gunzip maybe-gunzip)
-  (import (scheme base) (chibi io) (chibi process))
+  (import (scheme base) (scheme write)
+          (chibi io) (chibi process) (chibi temp-file))
   (include "zlib.scm"))

tools/snow-chibi

@@ -71,6 +71,8 @@
     (install-library-dir dirname "directory to install shared libraries in")
     (install-binary-dir dirname "directory to install programs in")
     (library-extension string "the extension to use for library files")
+    (library-separator string "the separator to use for library components")
+    (library-path (list string) "the path to search for local libraries")
     (installer symbol "name of installer to use")
     (implementations (list symbol) "impls to install for, or 'all'")
     (chibi-path filename "path to chibi-scheme executable")
@@ -119,6 +121,7 @@
     (doc-from-scribble boolean)
     (description string)
     (test existing-filename)
+    (test-library sexp)
     (sig-file existing-filename)
     (output filename)
     (output-dir dirname)