diff options
author | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-01-10 00:41:42 +0100 |
commit | 91ee7515da0bad91330ce5c87b250d6cf12a2789 (patch) | |
tree | ce023c92c0d9bf895c1265b107b270c35ba59b94 /module | |
parent | 0bdd43515eb3c62839512181cf33e5aea383e661 (diff) | |
parent | 0e947e1d14597651c5762a4209225c472bdaef45 (diff) | |
download | guile-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.scm | 9 | ||||
-rw-r--r-- | module/ice-9/ftw.scm | 133 | ||||
-rw-r--r-- | module/ice-9/test.scm | 2 | ||||
-rw-r--r-- | module/language/elisp/runtime/macros.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 2 | ||||
-rw-r--r-- | module/srfi/srfi-1.scm | 2 | ||||
-rw-r--r-- | module/system/base/compile.scm | 2 | ||||
-rw-r--r-- | module/system/base/target.scm | 6 | ||||
-rw-r--r-- | module/web/http.scm | 26 |
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 ;; |