Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Various snow bugfixes.

Browse source
This commit is contained in:
Alex Shinn 2015-04-21 00:01:46 +09:00
parent eb1a982842
commit 6a3179ec42
16 changed files with 175 additions and 151 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
lib/chibi/doc.scm
View file

@ -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
(map (lambda (x)
(let ((val (module-ref mod x)))
`(,x ,val ,(object-source val))))
exports)))
(srcs
(append
(cond
((find-module-file (module-name->file mod-name))
=> (lambda (f)
(reverse (extract-file-docs mod f defs strict? 'module))))
(cond ((find-module-file (module-name->file mod-name)) => list)
(else '()))
(reverse
(append-map (lambda (x)
(extract-file-docs mod x defs strict? 'module))
(module-include-library-declarations mod)))
(reverse
(append-map (lambda (x) (extract-file-docs mod x defs strict?))
(module-includes mod)))
(reverse
(append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
(module-shared-includes mod))))))))
(module-include-library-declarations mod))))
(extract-module-docs-from-files
mod srcs (module-includes mod) (module-shared-includes mod)
strict? exports))))
;;> As above, but extracts docs for the module defined in \var{file},
;;> which need not be in the search path.
(define (extract-module-file-docs file strict? . o)
(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))))))

2
lib/chibi/doc.sld
View file

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

2
lib/chibi/modules.sld
View file

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

26
lib/chibi/net/server-util.scm
View file

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

1
lib/chibi/net/server-util.sld
View file

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

9
lib/chibi/process.scm
View file

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

2
lib/chibi/process.sld
View file

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

29
lib/chibi/snow/commands.scm
View file

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

2
lib/chibi/snow/commands.sld
View file

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

43
lib/chibi/snow/utils.scm
View file

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

2
lib/chibi/snow/utils.sld
View file

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

43
lib/chibi/temp-file.scm Normal file
View file

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

5
lib/chibi/temp-file.sld Normal file
View file

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

72
lib/chibi/zlib.scm
View file

@ -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)
(call-with-process-io
cmd
(lambda (pid proc-in proc-out proc-err)
(let ((len (bytevector-length bvec))
(out (open-output-bytevector)))
(let lp ((i 0))
(cond
((u8-ready? proc-out)
(let ((u8 (read-u8 proc-out)))
(cond
((eof-object? u8)
(get-output-bytevector out))
(else
(write-u8 u8 out)
(lp i)))))
((< i len)
(write-u8 (bytevector-u8-ref bvec i) proc-in)
(if (= len (+ i 1))
(close-output-port proc-in))
(lp (+ i 1)))
(else
;; Once we've completed sending the input we busy wait
;; until all output has been read. We can't just waitpid
;; here because the remaining output may still overflow the
;; pipe buffer.
(lp i))))))))
;; (define (process-pipe-bytevector cmd bvec)
;; (call-with-process-io
;; cmd
;; (lambda (pid proc-in proc-out proc-err)
;; (let ((len (bytevector-length bvec))
;; (out (open-output-bytevector)))
;; (let lp ((i 0))
;; (cond
;; ((u8-ready? proc-out)
;; (let ((u8 (read-u8 proc-out)))
;; (cond
;; ((eof-object? u8)
;; (get-output-bytevector out))
;; (else
;; (write-u8 u8 out)
;; (lp i)))))
;; ((< i len)
;; (write-u8 (bytevector-u8-ref bvec i) proc-in)
;; (lp (+ i 1)))
;; (else
;; ;; Once we've completed sending the input we busy wait
;; ;; until all output has been read. We can't just waitpid
;; ;; here because the remaining output may still overflow the
;; ;; pipe buffer.
;; (close-output-port proc-in)
;; (let lp ()
;; (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.

3
lib/chibi/zlib.sld
View file

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

3
tools/snow-chibi
View file

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