summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-01-10 00:41:42 +0100
committerAndy Wingo <wingo@pobox.com>2012-01-10 00:41:42 +0100
commit91ee7515da0bad91330ce5c87b250d6cf12a2789 (patch)
treece023c92c0d9bf895c1265b107b270c35ba59b94 /module
parent0bdd43515eb3c62839512181cf33e5aea383e661 (diff)
parent0e947e1d14597651c5762a4209225c472bdaef45 (diff)
downloadguile-91ee7515da0bad91330ce5c87b250d6cf12a2789.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/__scm.h libguile/array-map.c libguile/procprop.c libguile/tags.h module/ice-9/deprecated.scm module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm test-suite/standalone/test-num2integral.c test-suite/tests/regexp.test
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm9
-rw-r--r--module/ice-9/ftw.scm133
-rw-r--r--module/ice-9/test.scm2
-rw-r--r--module/language/elisp/runtime/macros.scm2
-rw-r--r--module/language/tree-il/fix-letrec.scm2
-rw-r--r--module/srfi/srfi-1.scm2
-rw-r--r--module/system/base/compile.scm2
-rw-r--r--module/system/base/target.scm6
-rw-r--r--module/web/http.scm26
9 files changed, 114 insertions, 70 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5395ed1f9..1de5edf5b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,7 +1,8 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+;;;; 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
@@ -2979,7 +2980,7 @@ module '(ice-9 q) '(make-q q-length))}."
;; 0 by printing a newline, but we then advance it by printing
;; the prompt. However the port-column of the output port
;; does not typically correspond with the actual column on the
- ;; screen, because the input is is echoed back! Since the
+ ;; screen, because the input is echoed back! Since the
;; input is line-buffered and thus ends with a newline, the
;; output will really start on column zero. So, here we zero
;; it out. See bug 9664.
@@ -3463,7 +3464,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;; {`load'.}
;;;
;;; Load is tricky when combined with relative paths, compilation, and
-;;; the filesystem. If a path is relative, what is it relative to? The
+;;; the file system. If a path is relative, what is it relative to? The
;;; path of the source file at the time it was compiled? The path of
;;; the compiled file? What if both or either were installed? And how
;;; do you get that information? Tricky, I say.
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 5f6115427..96422b5e4 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -1,6 +1,6 @@
;;;; ftw.scm --- file system tree walk
-;;;; Copyright (C) 2002, 2003, 2006, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 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
@@ -389,7 +389,14 @@
;;; `file-system-fold' & co.
;;;
-(define* (file-system-fold enter? leaf down up skip init file-name
+(define-syntax-rule (errno-if-exception expr)
+ (catch 'system-error
+ (lambda ()
+ expr)
+ (lambda args
+ (system-error-errno args))))
+
+(define* (file-system-fold enter? leaf down up skip error init file-name
#:optional (stat lstat))
"Traverse the directory at FILE-NAME, recursively. Enter
sub-directories only when (ENTER? PATH STAT RESULT) returns true. When
@@ -397,7 +404,11 @@ a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is
the path of the sub-directory and STAT the result of (stat PATH); when
it is left, call (UP PATH STAT RESULT). For each file in a directory,
call (LEAF PATH STAT RESULT). When ENTER? returns false, call (SKIP
-PATH STAT RESULT). Return the result of these successive applications.
+PATH STAT RESULT). When an `opendir' or STAT call raises an exception,
+call (ERROR PATH STAT ERRNO RESULT), with ERRNO being the operating
+system error number that was raised.
+
+Return the result of these successive applications.
When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned.
The optional STAT parameter defaults to `lstat'."
@@ -409,7 +420,7 @@ The optional STAT parameter defaults to `lstat'."
(let loop ((name file-name)
(path "")
- (dir-stat (false-if-exception (stat file-name)))
+ (dir-stat (errno-if-exception (stat file-name)))
(result init)
(visited vlist-null))
@@ -419,57 +430,60 @@ The optional STAT parameter defaults to `lstat'."
(string-append path "/" name)))
(cond
- ((not dir-stat)
+ ((integer? dir-stat)
;; FILE-NAME is not readable.
- (leaf full-name dir-stat result))
+ (error full-name #f dir-stat result))
((visited? visited dir-stat)
(values result visited))
((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time
(if (enter? full-name dir-stat result)
- (let ((dir (false-if-exception (opendir full-name)))
+ (let ((dir (errno-if-exception (opendir full-name)))
(visited (mark visited dir-stat)))
- (if dir
- (let liip ((entry (readdir dir))
- (result (down full-name dir-stat result))
- (subdirs '()))
- (cond ((eof-object? entry)
- (begin
- (closedir dir)
- (let ((r+v
- (fold (lambda (subdir result+visited)
- (call-with-values
- (lambda ()
- (loop (car subdir)
- full-name
- (cdr subdir)
- (car result+visited)
- (cdr result+visited)))
- cons))
- (cons result visited)
- subdirs)))
- (values (up full-name dir-stat (car r+v))
- (cdr r+v)))))
- ((or (string=? entry ".")
- (string=? entry ".."))
- (liip (readdir dir)
- result
- subdirs))
- (else
- (let* ((child (string-append full-name "/" entry))
- (st (false-if-exception (stat child))))
- (if (and st (eq? (stat:type st) 'directory))
- (liip (readdir dir)
- result
- (alist-cons entry st subdirs))
- (liip (readdir dir)
- (leaf child st result)
- subdirs))))))
-
- ;; Directory FULL-NAME not readable.
- ;; XXX: It's up to the user to distinguish between not
- ;; readable and not ENTER?.
- (values (skip full-name dir-stat result)
- visited)))
+ (cond
+ ((directory-stream? dir)
+ (let liip ((entry (readdir dir))
+ (result (down full-name dir-stat result))
+ (subdirs '()))
+ (cond ((eof-object? entry)
+ (begin
+ (closedir dir)
+ (let ((r+v
+ (fold (lambda (subdir result+visited)
+ (call-with-values
+ (lambda ()
+ (loop (car subdir)
+ full-name
+ (cdr subdir)
+ (car result+visited)
+ (cdr result+visited)))
+ cons))
+ (cons result visited)
+ subdirs)))
+ (values (up full-name dir-stat (car r+v))
+ (cdr r+v)))))
+ ((or (string=? entry ".")
+ (string=? entry ".."))
+ (liip (readdir dir)
+ result
+ subdirs))
+ (else
+ (let* ((child (string-append full-name "/" entry))
+ (st (errno-if-exception (stat child))))
+ (if (integer? st) ; CHILD is a dangling symlink?
+ (liip (readdir dir)
+ (error child #f st result)
+ subdirs)
+ (if (eq? (stat:type st) 'directory)
+ (liip (readdir dir)
+ result
+ (alist-cons entry st subdirs))
+ (liip (readdir dir)
+ (leaf child st result)
+ subdirs))))))))
+ (else
+ ;; Directory FULL-NAME not readable, but it is stat'able.
+ (values (error full-name dir-stat dir result)
+ visited))))
(values (skip full-name dir-stat result)
(mark visited dir-stat))))
(else
@@ -480,13 +494,14 @@ The optional STAT parameter defaults to `lstat'."
#:optional (enter? (lambda (n s) #t))
(stat lstat))
"Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is
-the result of (stat FILE-NAME) and CHILDREN are similar structures for
+the result of (STAT FILE-NAME) and CHILDREN are similar structures for
each file contained in FILE-NAME when it designates a directory. The
optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should
return true to allow recursion into directory NAME; the default value is
a procedure that always returns #t. When a directory does not match
ENTER?, it nonetheless appears in the resulting tree, only with zero
-children. The optional STAT parameter defaults to `lstat'."
+children. The optional STAT parameter defaults to `lstat'. Return #f
+when FILE-NAME is not readable."
(define (enter?* name stat result)
(enter? name stat))
(define (leaf name stat result)
@@ -504,8 +519,15 @@ children. The optional STAT parameter defaults to `lstat'."
rest))))
(define skip ; keep an entry for skipped directories
leaf)
+ (define (error name stat errno result)
+ (if (string=? name file-name)
+ result
+ (leaf name stat result)))
- (caar (file-system-fold enter?* leaf down up skip '(()) file-name stat)))
+ (match (file-system-fold enter?* leaf down up skip error '(())
+ file-name stat)
+ (((tree)) tree)
+ ((()) #f))) ; FILE-NAME is unreadable
(define* (scandir name #:optional (select? (const #t))
(entry<? string-locale<?))
@@ -532,7 +554,12 @@ of file names is sorted according to ENTRY<?, which defaults to
;; All the sub-directories are skipped.
(cons (basename name) result))
- (and=> (file-system-fold enter? leaf down up skip #f name stat)
+ (define (error name* stat errno result)
+ (if (string=? name name*) ; top-level NAME is unreadable
+ result
+ (cons (basename name*) result)))
+
+ (and=> (file-system-fold enter? leaf down up skip error #f name stat)
(lambda (files)
(sort files entry<?))))
diff --git a/module/ice-9/test.scm b/module/ice-9/test.scm
index f6080e4cf..179cfc35e 100644
--- a/module/ice-9/test.scm
+++ b/module/ice-9/test.scm
@@ -17,7 +17,7 @@
;;;; "test.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer
;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
-;;; won't pass. Made the the tests (test-cont), (test-sc4), and
+;;; won't pass. Made the tests (test-cont), (test-sc4), and
;;; (test-delay) start to run automatically.
;;; This includes examples from
diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm
index a62f721e7..b28706781 100644
--- a/module/language/elisp/runtime/macros.scm
+++ b/module/language/elisp/runtime/macros.scm
@@ -81,7 +81,7 @@
(progn ,@(cdr cur))
,rest))))))))
-;;; The and and or forms can also be easily defined with macros.
+;;; The `and' and `or' forms can also be easily defined with macros.
(built-in-macro and
(case-lambda
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 2a18342d3..f83d77e76 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -238,7 +238,7 @@
c)
(list body)))
(else
- ;; Otherwise for plain letrec, evaluate the the "complex"
+ ;; Otherwise for plain letrec, evaluate the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index d2347b0d1..d2531b59d 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -652,7 +652,7 @@ has just one element then that's the return value."
(define map! map)
(define (filter-map proc list1 . rest)
- "Apply PROC to to the elements of LIST1... and return a list of the
+ "Apply PROC to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
(check-arg procedure? proc filter-map)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 953c93602..0bc11a30f 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -93,7 +93,7 @@
;;; This function is among the trickiest I've ever written. I tried many
;;; variants. In the end, simple is best, of course.
;;;
-;;; After turning this around a number of times, it seems that the the
+;;; After turning this around a number of times, it seems that the
;;; desired behavior is that .go files should exist in a path, for
;;; searching. That is orthogonal to this function. For writing .go
;;; files, either you know where they should go, in which case you tell
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index a81b3d9f5..304056de2 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -1,6 +1,6 @@
;;; Compilation targets
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 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
@@ -82,9 +82,9 @@
(cond ((string-match "^i[0-9]86$" cpu) 4)
((string-match "64$" cpu) 8)
((string-match "64[lbe][lbe]$" cpu) 8)
- ((member cpu '("sparc" "powerpc" "mips")) 4)
+ ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4)
((string-match "^arm.*" cpu) 4)
- (else "unknown CPU word size" cpu))))
+ (else (error "unknown CPU word size" cpu)))))
(define (triplet-cpu t)
(substring t 0 (string-index t #\-)))
diff --git a/module/web/http.scm b/module/web/http.scm
index afe70a7fd..b060af91e 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -805,9 +805,6 @@ ordered alist."
(display-digits (date-second date) 2 port)
(display " GMT" port)))
-(define (write-uri uri port)
- (display (uri->string uri) port))
-
(define (parse-entity-tag val)
(if (string-prefix? "W/" val)
(cons (parse-qstring val 2) #f)
@@ -1082,7 +1079,18 @@ three values: the method, the URI, and the version."
"Write the first line of an HTTP request to @var{port}."
(display method port)
(display #\space port)
- (write-uri uri port)
+ (let ((path (uri-path uri))
+ (query (uri-query uri)))
+ (if (not (string-null? path))
+ (display path port))
+ (if query
+ (begin
+ (display "?" port)
+ (display query port)))
+ (if (and (string-null? path)
+ (not query))
+ ;; Make sure we display something.
+ (display "/" port)))
(display #\space port)
(write-http-version version port)
(display "\r\n" port))
@@ -1506,7 +1514,15 @@ phrase\"."
;; Expires = HTTP-date
;;
-(declare-date-header! "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+ (lambda (str)
+ (if (member str '("0" "-1"))
+ *date-in-the-past*
+ (parse-date str)))
+ date?
+ write-date)
;; Last-Modified = HTTP-date
;;