mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	GUILE-VERSION
	test-suite/tests/srfi-4.test
This commit is contained in:
Andy Wingo 2011-07-25 18:26:37 +02:00
commit ab4bc85398
73 changed files with 1292 additions and 335 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/Makefile.am
View file

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

14
module/ice-9/boot-9.scm
View file

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

85
module/oop/goops.scm
View file

@ -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* (make-accessor #:optional 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* (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))

40
module/scripts/PROGRAM.scm
View file

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

5
module/scripts/api-diff.scm
View file

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

5
module/scripts/autofrisk.scm
View file

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

2
module/scripts/compile.scm
View file

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

4
module/scripts/disassemble.scm
View file

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

4
module/scripts/display-commentary.scm
View file

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

4
module/scripts/doc-snarf.scm
View file

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

5
module/scripts/frisk.scm
View file

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

5
module/scripts/generate-autoload.scm
View file

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

148
module/scripts/help.scm Normal file
View file

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

3
module/scripts/lint.scm
View file

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

11
module/scripts/list.scm
View file

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

3
module/scripts/punify.scm
View file

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

5
module/scripts/read-rfc822.scm
View file

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

5
module/scripts/read-scheme-source.scm
View file

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

5
module/scripts/read-text-outline.scm
View file

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

5
module/scripts/scan-api.scm
View file

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

5
module/scripts/snarf-check-and-output-texi.scm
View file

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

5
module/scripts/snarf-guile-m4-docs.scm
View file

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

5
module/scripts/summarize-guile-TODO.scm
View file

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

4
module/scripts/use2dot.scm
View file

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

14
module/system/base/compile.scm
View file

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

22
module/system/repl/command.scm
View file

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

116
module/web/client.scm Normal file
View file

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

40
module/web/request.scm
View file

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