mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

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

Browse source 
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
This commit is contained in:
Andy Wingo 2012-01-10 00:41:42 +01:00
commit 91ee7515da
64 changed files with 1024 additions and 648 deletions
Download patch file Download diff file Expand all files Collapse all files

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

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

133
module/ice-9/ftw.scm
View file

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

2
module/ice-9/test.scm
View file

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

2
module/language/elisp/runtime/macros.scm
View file

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

2
module/language/tree-il/fix-letrec.scm
View file

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

2
module/srfi/srfi-1.scm
View file

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

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

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

6
module/system/base/target.scm
View file

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

26
module/web/http.scm
View file

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