diff options
author | Andy Wingo <wingo@pobox.com> | 2011-07-25 18:26:37 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-07-25 18:26:37 +0200 |
commit | ab4bc85398a14b62b58694bab83c63be286b2fd5 (patch) | |
tree | 84bfe7b0b6064016bcfadb76ec95d07410654fe8 /module | |
parent | f29c300507da21a667f5b82e75300f8009eab9cc (diff) | |
parent | f4b7d918eff9770f09893b023fd834f5c0bc33d1 (diff) | |
download | guile-ab4bc85398a14b62b58694bab83c63be286b2fd5.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
test-suite/tests/srfi-4.test
Diffstat (limited to 'module')
28 files changed, 438 insertions, 136 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index b21b73c77..0787f2004 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -146,7 +146,6 @@ BRAINFUCK_LANG_SOURCES = \ language/brainfuck/spec.scm SCRIPTS_SOURCES = \ - scripts/PROGRAM.scm \ scripts/autofrisk.scm \ scripts/compile.scm \ scripts/disassemble.scm \ @@ -154,6 +153,7 @@ SCRIPTS_SOURCES = \ scripts/doc-snarf.scm \ scripts/frisk.scm \ scripts/generate-autoload.scm \ + scripts/help.scm \ scripts/lint.scm \ scripts/list.scm \ scripts/punify.scm \ @@ -356,6 +356,7 @@ LIB_SOURCES = \ texinfo/serialize.scm WEB_SOURCES = \ + web/client.scm \ web/http.scm \ web/request.scm \ web/response.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 9c3a3e165..3bf492280 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3414,6 +3414,15 @@ module '(ice-9 q) '(make-q q-length))}." '(#:warnings (unbound-variable arity-mismatch format))) (define* (load-in-vicinity dir path #:optional reader) + (define (canonical->suffix canon) + (cond + ((string-prefix? "/" canon) canon) + ((and (> (string-length canon) 2) + (eqv? (string-ref canon 1) #\:)) + ;; Paths like C:... transform to /C... + (string-append "/" (substring canon 0 1) (substring canon 2))) + (else canon))) + ;; Returns the .go file corresponding to `name'. Does not search load ;; paths, only the fallback path. If the .go file is missing or out of ;; date, and auto-compilation is enabled, will try auto-compilation, just @@ -3425,11 +3434,12 @@ module '(ice-9 q) '(make-q q-length))}." ;; partially duplicates functionality from (system base compile). ;; (define (compiled-file-name canon-path) + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. (and %compile-fallback-path (string-append %compile-fallback-path - ;; no need for '/' separator here, canon-path is absolute - canon-path + (canonical->suffix canon-path) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) (warn "invalid %load-compiled-extensions" diff --git a/module/oop/goops.scm b/module/oop/goops.scm index e48c220f2..a27aab5fb 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -398,13 +398,11 @@ names)) (goops-error "no prefixes supplied")))) -(define (make-generic . name) - (let ((name (and (pair? name) (car name)))) - (make <generic> #:name name))) +(define* (make-generic #:optional name) + (make <generic> #:name name)) -(define (make-extended-generic gfs . name) - (let* ((name (and (pair? name) (car name))) - (gfs (if (pair? gfs) gfs (list gfs))) +(define* (make-extended-generic gfs #:optional name) + (let* ((gfs (if (list? gfs) gfs (list gfs))) (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs))) (let ((ans (if gws? (let* ((sname (and name (make-setter-name name))) @@ -441,18 +439,17 @@ (delq! eg (slot-ref gf 'extended-by)))) gfs)) -(define (ensure-generic old-definition . name) - (let ((name (and (pair? name) (car name)))) - (cond ((is-a? old-definition <generic>) old-definition) - ((procedure-with-setter? old-definition) - (make <generic-with-setter> - #:name name - #:default (procedure old-definition) - #:setter (setter old-definition))) - ((procedure? old-definition) - (if (generic-capability? old-definition) old-definition - (make <generic> #:name name #:default old-definition))) - (else (make <generic> #:name name))))) +(define* (ensure-generic old-definition #:optional name) + (cond ((is-a? old-definition <generic>) old-definition) + ((procedure-with-setter? old-definition) + (make <generic-with-setter> + #:name name + #:default (procedure old-definition) + #:setter (setter old-definition))) + ((procedure? old-definition) + (if (generic-capability? old-definition) old-definition + (make <generic> #:name name #:default old-definition))) + (else (make <generic> #:name name)))) ;; same semantics as <generic> (define-syntax define-accessor @@ -466,34 +463,32 @@ (define (make-setter-name name) (string->symbol (string-append "setter:" (symbol->string name)))) -(define (make-accessor . name) - (let ((name (and (pair? name) (car name)))) - (make <accessor> - #:name name - #:setter (make <generic> - #:name (and name (make-setter-name name)))))) - -(define (ensure-accessor proc . name) - (let ((name (and (pair? name) (car name)))) - (cond ((and (is-a? proc <accessor>) - (is-a? (setter proc) <generic>)) - proc) - ((is-a? proc <generic-with-setter>) - (upgrade-accessor proc (setter proc))) - ((is-a? proc <generic>) - (upgrade-accessor proc (make-generic name))) - ((procedure-with-setter? proc) - (make <accessor> - #:name name - #:default (procedure proc) - #:setter (ensure-generic (setter proc) name))) - ((procedure? proc) - (ensure-accessor (if (generic-capability? proc) - (make <generic> #:name name #:default proc) - (ensure-generic proc name)) - name)) - (else - (make-accessor name))))) +(define* (make-accessor #:optional name) + (make <accessor> + #:name name + #:setter (make <generic> + #:name (and name (make-setter-name name))))) + +(define* (ensure-accessor proc #:optional name) + (cond ((and (is-a? proc <accessor>) + (is-a? (setter proc) <generic>)) + proc) + ((is-a? proc <generic-with-setter>) + (upgrade-accessor proc (setter proc))) + ((is-a? proc <generic>) + (upgrade-accessor proc (make-generic name))) + ((procedure-with-setter? proc) + (make <accessor> + #:name name + #:default (procedure proc) + #:setter (ensure-generic (setter proc) name))) + ((procedure? proc) + (ensure-accessor (if (generic-capability? proc) + (make <generic> #:name name #:default proc) + (ensure-generic proc name)) + name)) + (else + (make-accessor name)))) (define (upgrade-accessor generic setter) (let ((methods (slot-ref generic 'methods)) diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm deleted file mode 100644 index 56e5cf334..000000000 --- a/module/scripts/PROGRAM.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; PROGRAM --- Does something - -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public License -;; as published by the Free Software Foundation; either version 3, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this software; see the file COPYING.LESSER. If -;; not, write to the Free Software Foundation, Inc., 51 Franklin -;; Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: J.R.Hacker - -;;; Commentary: - -;; Usage: PROGRAM [ARGS] -;; -;; PROGRAM does something. -;; -;; TODO: Write it! - -;;; Code: - -(define-module (scripts PROGRAM) - :export (PROGRAM)) - -(define (PROGRAM . args) - #t) - -(define main PROGRAM) - -;;; PROGRAM ends here diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm index b842b03ff..b2527b9e9 100644 --- a/module/scripts/api-diff.scm +++ b/module/scripts/api-diff.scm @@ -1,6 +1,6 @@ ;;; api-diff --- diff guile-api.alist files -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -46,6 +46,9 @@ :autoload (srfi srfi-13) (string-tokenize) :export (api-diff)) +(define %include-in-guild-list #f) +(define %summary "Show differences between two scan-api files.") + (define (read-alist-file file) (with-input-from-file file (lambda () (read)))) diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm index 943c90227..9bce06e2a 100644 --- a/module/scripts/autofrisk.scm +++ b/module/scripts/autofrisk.scm @@ -1,6 +1,6 @@ ;;; autofrisk --- Generate module checks for use with auto* tools -;; Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2009, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -62,6 +62,9 @@ :use-module (scripts frisk) :export (autofrisk)) +(define %include-in-guild-list #f) +(define %summary "Generate snippets for use in configure.ac files.") + (define *recognized-keys* '(files-glob non-critical-external non-critical-internal diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index f9d6cca99..0651c6804 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -37,6 +37,8 @@ #:use-module (ice-9 format) #:export (compile)) +(define %summary "Compile a file.") + (define (fail . messages) (format (current-error-port) "error: ~{~a~}~%" messages) diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm index 8907f6d08..7dab2dde9 100644 --- a/module/scripts/disassemble.scm +++ b/module/scripts/disassemble.scm @@ -1,6 +1,6 @@ ;;; Disassemble --- Disassemble .go files into something human-readable -;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc. +;; Copyright 2005, 2008, 2009, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -32,6 +32,8 @@ #:renamer (symbol-prefix-proc 'asm:)) #:export (disassemble)) +(define %summary "Disassemble a compiled .go file.") + (define (disassemble . files) (for-each (lambda (file) (asm:disassemble (load-objcode file))) diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm index 5bd249ce9..81d7907af 100644 --- a/module/scripts/display-commentary.scm +++ b/module/scripts/display-commentary.scm @@ -1,6 +1,6 @@ ;;; display-commentary --- As advertized -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -33,6 +33,8 @@ :use-module (ice-9 documentation) :export (display-commentary)) +(define %summary "Display the Commentary section from a file or module.") + (define (display-commentary-one file) (format #t "~A commentary:\n~A" file (file-commentary file))) diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm index b7fbc996e..fa3dfb312 100644 --- a/module/scripts/doc-snarf.scm +++ b/module/scripts/doc-snarf.scm @@ -1,6 +1,6 @@ ;;; doc-snarf --- Extract documentation from source files -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -83,6 +83,8 @@ This procedure foos, or bars, depending on the argument @var{braz}. :use-module (ice-9 rdelim) :export (doc-snarf)) +(define %summary "Snarf out documentation from a file.") + (define command-synopsis '((version (single-char #\v) (value #f)) (help (single-char #\h) (value #f)) diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm index c452ede25..a8f79232d 100644 --- a/module/scripts/frisk.scm +++ b/module/scripts/frisk.scm @@ -1,6 +1,6 @@ ;;; frisk --- Grok the module interfaces of a body of files -;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -103,6 +103,9 @@ mod-up-ls mod-down-ls mod-int? edge-type edge-up edge-down)) +(define %include-in-guild-list #f) +(define %summary "Show dependency information for a module.") + (define *default-module* '(guile-user)) (define (grok-proc default-module note-use!) diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm index 781931015..90f524b06 100644 --- a/module/scripts/generate-autoload.scm +++ b/module/scripts/generate-autoload.scm @@ -1,6 +1,6 @@ ;;; generate-autoload --- Display define-module form with autoload info -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -59,6 +59,9 @@ (define-module (scripts generate-autoload) :export (generate-autoload)) +(define %include-in-guild-list #f) +(define %summary "Generate #:autoload clauses for a module.") + (define (autoload-info file) (let ((p (open-input-file file))) (let loop ((form (read p)) (module-name #f) (exports '())) diff --git a/module/scripts/help.scm b/module/scripts/help.scm new file mode 100644 index 000000000..107d39485 --- /dev/null +++ b/module/scripts/help.scm @@ -0,0 +1,148 @@ +;;; Help --- Show help on guild commands + +;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +;;; Commentary: + +;; Usage: help +;; +;; Show help for Guild scripts. + +;;; Code: + +(define-module (scripts help) + #:use-module (ice-9 format) + #:use-module (ice-9 documentation) + #:use-module ((srfi srfi-1) #:select (fold append-map)) + #:export (main)) + +(define %summary "Show a brief help message.") + + +(define (directory-files dir) + (if (and (file-exists? dir) (file-is-directory? dir)) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + (begin + (closedir dir-stream) + acc) + (loop (readdir dir-stream) + (if (or (string=? "." new) ; ignore + (string=? ".." new)) ; ignore + acc + (cons new acc)))))) + '())) + +(define (strip-extensions path) + (or-map (lambda (ext) + (and + (string-suffix? ext path) + ;; We really can't be adding e.g. ChangeLog-2008 to the set + ;; of runnable scripts, just because "" is a valid + ;; extension, by default. So hack around that here. + (not (string-null? ext)) + (substring path 0 + (- (string-length path) (string-length ext))))) + (append %load-compiled-extensions %load-extensions))) + +(define (unique l) + (cond ((null? l) l) + ((null? (cdr l)) l) + ((equal? (car l) (cadr l)) (unique (cdr l))) + (else (cons (car l) (unique (cdr l)))))) + +(define (find-submodules head) + (let ((shead (map symbol->string head))) + (unique + (sort + (append-map (lambda (path) + (fold (lambda (x rest) + (let ((stripped (strip-extensions x))) + (if stripped (cons stripped rest) rest))) + '() + (directory-files + (fold (lambda (x y) (in-vicinity y x)) path shead)))) + %load-path) + string<?)))) + +(define (list-commands all?) + (display "\ +Usage: guild COMMAND [ARGS] +Run command-line scripts provided by GNU Guile and related programs. + +Commands: +") + + (for-each + (lambda (name) + (let* ((modname `(scripts ,(string->symbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if (and mod + (or all? + (let ((v (module-variable mod '%include-in-guild-list))) + (if v (variable-ref v) #t)))) + (if summary + (format #t " ~A ~23t~a\n" name summary) + (format #t " ~A\n" name))))) + (find-submodules '(scripts))) + (format #t " +For help on a specific command, try \"guild help COMMAND\". + +Report guild bugs to ~a +GNU Guile home page: <http://www.gnu.org/software/guile/> +General help using GNU software: <http://www.gnu.org/gethelp/> +For complete documentation, run: info guile 'Using Guile Tools' +" %guile-bug-report-address)) + +(define (module-commentary mod) + (file-commentary + (%search-load-path (module-filename mod)))) + +(define (main . args) + (cond + ((null? args) + (list-commands #f)) + ((or (equal? args '("--all")) (equal? args '("-a"))) + (list-commands #t)) + ((not (string-prefix? "-" (car args))) + ;; help for particular command + (let* ((name (car args)) + (mod (resolve-module `(scripts ,(string->symbol name)) + #:ensure #f))) + (if mod + (let ((commentary (module-commentary mod))) + (if commentary + (display commentary) + (format #t "No documentation found for command \"~a\".\n" + name))) + (begin + (format #t "No command named \"~a\".\n" name) + (exit 1))))) + (else + (display "Usage: guild help + guild help --all + guild help COMMAND + +Show a help on guild commands. With --all, show arcane incantations as +well. With COMMAND, show more detailed help for a particular command. +") + (exit 1)))) diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm index aa74fb6a7..cea425ea9 100644 --- a/module/scripts/lint.scm +++ b/module/scripts/lint.scm @@ -105,6 +105,9 @@ #:use-module (ice-9 format) #:export (lint)) +(define %include-in-guild-list #f) +(define %summary "Check for bugs and style errors in a Scheme file.") + (define (lint filename) (let ((module-name (scan-file-for-module-name filename)) (free-vars (uniq (scan-file-for-free-variables filename)))) diff --git a/module/scripts/list.scm b/module/scripts/list.scm index c4891b6a8..0f1d715dd 100644 --- a/module/scripts/list.scm +++ b/module/scripts/list.scm @@ -26,9 +26,11 @@ ;;; Code: (define-module (scripts list) - #:use-module ((srfi srfi-1) #:select (fold append-map)) #:export (list-scripts)) +(define %include-in-guild-list #f) +(define %summary "An alias for \"help\".") + (define (directory-files dir) (if (and (file-exists? dir) (file-is-directory? dir)) @@ -50,6 +52,10 @@ (or-map (lambda (ext) (and (string-suffix? ext path) + ;; We really can't be adding e.g. ChangeLog-2008 to the set + ;; of runnable scripts, just because "" is a valid + ;; extension, by default. So hack around that here. + (not (string-null? ext)) (substring path 0 (- (string-length path) (string-length ext))))) (append %load-compiled-extensions %load-extensions))) @@ -80,4 +86,5 @@ (format #t "~A\n" x)) (find-submodules '(scripts)))) -(define main list-scripts) +(define (main . args) + (apply (@@ (scripts help) main) args)) diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm index 1627722d3..6b33ac5ee 100644 --- a/module/scripts/punify.scm +++ b/module/scripts/punify.scm @@ -41,6 +41,9 @@ (define-module (scripts punify) :export (punify)) +(define %include-in-guild-list #f) +(define %summary "Strip comments and whitespace from a Scheme file.") + (define (write-punily form) (cond ((and (list? form) (not (null? form))) (let ((first (car form))) diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm index c0a54f28c..08f3fb9a1 100644 --- a/module/scripts/read-rfc822.scm +++ b/module/scripts/read-rfc822.scm @@ -1,6 +1,6 @@ ;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout -;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -49,6 +49,9 @@ :autoload (srfi srfi-13) (string-join) :export (read-rfc822 read-rfc822-silently)) +(define %include-in-guild-list #f) +(define %summary "Validate an RFC822-style file.") + (define from-line-rx (make-regexp "^From ")) (define header-name-rx (make-regexp "^([^:]+):[ \t]*")) (define header-cont-rx (make-regexp "^[ \t]+")) diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm index b48a88f9b..1bca6a4c4 100644 --- a/module/scripts/read-scheme-source.scm +++ b/module/scripts/read-scheme-source.scm @@ -1,6 +1,6 @@ ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -91,6 +91,9 @@ quoted? clump)) +(define %include-in-guild-list #f) +(define %summary "Print a parsed representation of a Scheme file.") + ;; Try to figure out what FORM is and its various attributes. ;; Call proc NOTE! with key (a symbol) and value. ;; diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm index 64221fbe1..d0933bb0b 100644 --- a/module/scripts/read-text-outline.scm +++ b/module/scripts/read-text-outline.scm @@ -1,6 +1,6 @@ ;;; read-text-outline --- Read a text outline and display it as a sexp -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -118,6 +118,9 @@ :autoload (ice-9 rdelim) (read-line) :autoload (ice-9 getopt-long) (getopt-long)) +(define %include-in-guild-list #f) +(define %summary "Convert textual outlines to s-expressions.") + (define (?? symbol) (let ((name (symbol->string symbol))) (string=? "?" (substring name (1- (string-length name)))))) diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm index 9236f8742..86d07fc3e 100644 --- a/module/scripts/scan-api.scm +++ b/module/scripts/scan-api.scm @@ -1,6 +1,6 @@ ;;; scan-api --- Scan and group interpreter and libguile interface elements -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -65,6 +65,9 @@ :use-module (ice-9 regex) :export (scan-api)) +(define %include-in-guild-list #f) +(define %summary "Generate an API description for a Guile extension.") + (define put set-object-property!) (define get object-property) diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index f92c833ed..6ca07a1f4 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -26,6 +26,9 @@ :use-module (ice-9 match) :export (snarf-check-and-output-texi)) +(define %include-in-guild-list #f) +(define %summary "Transform snarfed .doc files into texinfo documentation.") + ;;; why aren't these in some module? (define-macro (when cond . body) diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm index 05c305ebd..4e59f536d 100644 --- a/module/scripts/snarf-guile-m4-docs.scm +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -1,6 +1,6 @@ ;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -35,6 +35,9 @@ :use-module (ice-9 rdelim) :export (snarf-guile-m4-docs)) +(define %include-in-guild-list #f) +(define %summary "Snarf out texinfo documentation from .m4 files.") + (define (display-texi lines) (display "@deffn {Autoconf Macro}") (for-each (lambda (line) diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm index ee4f88c1f..8b119e0ec 100644 --- a/module/scripts/summarize-guile-TODO.scm +++ b/module/scripts/summarize-guile-TODO.scm @@ -1,6 +1,6 @@ ;;; summarize-guile-TODO --- Display Guile TODO list in various ways -;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -73,6 +73,9 @@ :autoload (ice-9 common-list) (remove-if-not) :export (summarize-guile-TODO)) +(define %include-in-guild-list #f) +(define %summary "A quaint relic of the past.") + (define put set-object-property!) (define get object-property) diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm index ab97afbc7..975a9c4a4 100644 --- a/module/scripts/use2dot.scm +++ b/module/scripts/use2dot.scm @@ -1,6 +1,6 @@ ;;; use2dot --- Display module dependencies as a DOT specification -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -53,6 +53,8 @@ :select (make-frisker edge-type edge-up edge-down)) :export (use2dot)) +(define %summary "Print a module's dependencies in graphviz format.") + (define *default-module* '(guile-user)) (define (q s) ; quote diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 1b6e73f32..943999040 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -103,6 +103,16 @@ ;;; ;;; See also boot-9.scm:load. (define (compiled-file-name file) + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. + (define (canonical->suffix canon) + (cond + ((string-prefix? "/" canon) canon) + ((and (> (string-length canon) 2) + (eqv? (string-ref canon 1) #\:)) + ;; Paths like C:... transform to /C... + (string-append "/" (substring canon 0 1) (substring canon 2))) + (else canon))) (define (compiled-extension) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) @@ -113,9 +123,7 @@ (and %compile-fallback-path (let ((f (string-append %compile-fallback-path - ;; no need for '/' separator here, canonicalize-path - ;; will give us an absolute path - (canonicalize-path file) + (canonical->suffix (canonicalize-path file)) (compiled-extension)))) (and (false-if-exception (ensure-writable-dir (dirname f))) f)))) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 109b533f8..a2f2a6f84 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -485,21 +485,19 @@ Disassemble a file." "time EXP Time execution." (let* ((gc-start (gc-run-time)) - (tms-start (times)) + (real-start (get-internal-real-time)) + (run-start (get-internal-run-time)) (result (repl-eval repl (repl-parse repl form))) - (tms-end (times)) + (run-end (get-internal-run-time)) + (real-end (get-internal-real-time)) (gc-end (gc-run-time))) - (define (get proc start end) - (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second))) + (define (diff start end) + (/ (- end start) 1.0 internal-time-units-per-second)) (repl-print repl result) - (display "clock utime stime cutime cstime gctime\n") - (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get identity gc-start gc-end)) + (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n" + (diff real-start real-end) + (diff run-start run-end) + (diff gc-start gc-end)) result)) (define-meta-command (profile repl (form) . opts) diff --git a/module/web/client.scm b/module/web/client.scm new file mode 100644 index 000000000..6a04497cf --- /dev/null +++ b/module/web/client.scm @@ -0,0 +1,116 @@ +;;; Web client + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: +;;; +;;; (web client) is a simple HTTP URL fetcher for Guile. +;;; +;;; In its current incarnation, (web client) is synchronous. If you +;;; want to fetch a number of URLs at once, probably the best thing to +;;; do is to write an event-driven URL fetcher, similar in structure to +;;; the web server. +;;; +;;; Another option, good but not as performant, would be to use threads, +;;; possibly via par-map or futures. +;;; +;;; Code: + +(define-module (web client) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 rdelim) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (open-socket-for-uri + http-get)) + +(define (open-socket-for-uri uri) + (let* ((ai (car (getaddrinfo (uri-host uri) + (cond + ((uri-port uri) => number->string) + (else (symbol->string (uri-scheme uri))))))) + (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (set-port-encoding! s "ISO-8859-1") + (connect s (addrinfo:addr ai)) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF) + ;; Enlarge the receive buffer. + (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) + s)) + +(define (decode-string bv encoding) + (if (string-ci=? encoding "utf-8") + (utf8->string bv) + (let ((p (open-bytevector-input-port bv))) + (set-port-encoding! p encoding) + (let ((res (read-delimited "" p))) + (close-port p) + res)))) + +(define (text-type? type) + (let ((type (symbol->string type))) + (or (string-prefix? "text/" type) + (string-suffix? "/xml" type) + (string-suffix? "+xml" type)))) + +;; Logically the inverse of (web server)'s `sanitize-response'. +;; +(define (decode-response-body response body) + ;; `body' is either #f or a bytevector. + (cond + ((not body) body) + ((bytevector? body) + (let ((rlen (response-content-length response)) + (blen (bytevector-length body))) + (cond + ((and rlen (not (= rlen blen))) + (error "bad content-length" rlen blen)) + ((response-content-type response) + => (lambda (type) + (cond + ((text-type? (car type)) + (decode-string body (or (assq-ref (cdr type) 'charset) + "iso-8859-1"))) + (else body)))) + (else body)))) + (else + (error "unexpected body type" body)))) + +(define* (http-get uri #:key (port (open-socket-for-uri uri)) + (version '(1 . 1)) (keep-alive? #f) (extra-headers '()) + (decode-body? #t)) + (let ((req (build-request uri #:version version + #:headers (if keep-alive? + extra-headers + (cons '(connection close) + extra-headers))))) + (write-request req port) + (force-output port) + (if (not keep-alive?) + (shutdown port 1)) + (let* ((res (read-response port)) + (body (read-response-body res))) + (if (not keep-alive?) + (close-port port)) + (values res + (if decode-body? + (decode-response-body res body) + body))))) diff --git a/module/web/request.scm b/module/web/request.scm index 84119205f..c9204a4bf 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -151,21 +151,31 @@ (validate-headers? #t)) "Construct an HTTP request object. If @var{validate-headers?} is true, the headers are each run through their respective validators." - (cond - ((not (and (pair? version) - (non-negative-integer? (car version)) - (non-negative-integer? (cdr version)))) - (bad-request "Bad version: ~a" version)) - ((not (uri? uri)) - (bad-request "Bad uri: ~a" uri)) - ((and (not port) (memq method '(POST PUT))) - (bad-request "Missing port for message ~a" method)) - ((not (list? meta)) - (bad-request "Bad metadata alist" meta)) - (else - (if validate-headers? - (validate-headers headers)))) - (make-request method uri version headers meta port)) + (let ((needs-host? (and (equal? version '(1 . 1)) + (not (assq-ref headers 'host))))) + (cond + ((not (and (pair? version) + (non-negative-integer? (car version)) + (non-negative-integer? (cdr version)))) + (bad-request "Bad version: ~a" version)) + ((not (uri? uri)) + (bad-request "Bad uri: ~a" uri)) + ((and (not port) (memq method '(POST PUT))) + (bad-request "Missing port for message ~a" method)) + ((not (list? meta)) + (bad-request "Bad metadata alist" meta)) + ((and needs-host? (not (uri-host uri))) + (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a" + uri)) + (else + (if validate-headers? + (validate-headers headers)))) + (make-request method uri version + (if needs-host? + (acons 'host (cons (uri-host uri) (uri-port uri)) + headers) + headers) + meta port))) (define* (read-request port #:optional (meta '())) "Read an HTTP request from @var{port}, optionally attaching the given |