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

Moved scm_i_struct_hash from struct.c to hash.c and made it static.

The port's alist is now a field of 'scm_t_port'.

Conflicts:
	libguile/arrays.c
	libguile/hash.c
	libguile/ports.c
	libguile/print.h
	libguile/read.c

module/ice-9/boot-9.scm

@@ -3137,8 +3137,11 @@ module '(ice-9 q) '(make-q q-length))}."
                 (lambda (option)
                   (apply (lambda (name value documentation)
                            (display name)
-                           (if (< (string-length (symbol->string name)) 8)
-                               (display #\tab))
+                           (let ((len (string-length (symbol->string name))))
+                             (when (< len 16)
+                               (display #\tab)
+                               (when (< len 8)
+                                 (display #\tab))))
                            (display #\tab)
                            (display value)
                            (display #\tab)
@@ -3509,7 +3512,9 @@ module '(ice-9 q) '(make-q q-length))}."
 (define-syntax define-public
   (syntax-rules ()
     ((_ (name . args) . body)
-     (define-public name (lambda args . body)))
+     (begin
+       (define name (lambda args . body))
+       (export name)))
     ((_ name val)
      (begin
        (define name val)
@@ -3899,7 +3904,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 ;;; Currently, the following feature identifiers are supported:
 ;;;
-;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
 ;;;
 ;;; Remember to update the features list when adding more SRFIs.
 ;;;
@@ -3919,6 +3924,7 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-39  ;; parameterize
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
+    srfi-105 ;; curly infix expressions
     ))
 
 ;; This table maps module public interfaces to the list of features.

module/ice-9/command-line.scm

@@ -1,6 +1,6 @@
 ;;; Parsing Guile's command-line
 
-;;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1994-1998, 2000-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
@@ -325,7 +325,7 @@ If FILE begins with `-' the -s switch is mandatory.
 
            ((string=? arg "--listen")   ; start a repl server
             (parse args
-                (cons '(@@ (system repl server) (spawn-server)) out)))
+                   (cons '((@@ (system repl server) spawn-server)) out)))
            
            ((string-prefix? "--listen=" arg) ; start a repl server
             (parse
@@ -336,14 +336,12 @@ If FILE begins with `-' the -s switch is mandatory.
                  ((string->number where) ; --listen=PORT
                   => (lambda (port)
                        (if (and (integer? port) (exact? port) (>= port 0))
-                           `(@@ (system repl server)
-                                (spawn-server
-                                 (make-tcp-server-socket #:port ,port)))
+                           `((@@ (system repl server) spawn-server)
+                             ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
                            (error "invalid port for --listen"))))
                  ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
-                  `(@@ (system repl server)
-                       (spawn-server
-                        (make-unix-domain-server-socket #:path ,where))))
+                  `((@@ (system repl server) spawn-server)
+                    ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
                  (else
                   (error "unknown argument to --listen"))))
               out)))

module/ice-9/curried-definitions.scm

@@ -16,7 +16,8 @@
 
 (define-module (ice-9 curried-definitions)
   #:replace ((cdefine . define)
-             (cdefine* . define*)))
+             (cdefine* . define*)
+             define-public))
 
 (define-syntax cdefine
   (syntax-rules ()
@@ -39,3 +40,14 @@
        (lambda* rest body body* ...)))
     ((_ . rest)
      (define* . rest))))
+
+(define-syntax define-public
+  (syntax-rules ()
+    ((_ (name . args) . body)
+     (begin
+       (cdefine (name . args) . body)
+       (export name)))
+    ((_ name val)
+     (begin
+       (define name val)
+       (export name)))))

module/ice-9/format.scm

@@ -427,15 +427,15 @@
                      (case modifier
                        ((at)
                         (format:out-str
-                         (with-output-to-string 
-                           (lambda ()
-                             (truncated-print (next-arg)
+                         (call-with-output-string
+                           (lambda (p)
+                             (truncated-print (next-arg) p
                                               #:width width)))))
                        ((colon-at)
                         (format:out-str
-                         (with-output-to-string 
-                           (lambda ()
-                             (truncated-print (next-arg)
+                         (call-with-output-string
+                           (lambda (p)
+                             (truncated-print (next-arg) p
                                               #:width
                                               (max (- width
                                                       output-col)
@@ -779,7 +779,7 @@
     (define (format:obj->str obj slashify)
       (let ((res (if slashify
                      (object->string obj)
-                     (with-output-to-string (lambda () (display obj))))))
+                     (call-with-output-string (lambda (p) (display obj p))))))
         (if (and format:read-proof (string-prefix? "#<" res))
             (object->string res)
             res)))

module/ice-9/regex.scm

@@ -172,8 +172,9 @@
     (let loop ((start 0)
                (value init)
                (abuts #f))              ; True if start abuts a previous match.
+      (define bol (if (zero? start) 0 regexp/notbol))
       (let ((m (if (> start (string-length string)) #f
-                   (regexp-exec regexp string start flags))))
+                   (regexp-exec regexp string start (logior flags bol)))))
         (cond
          ((not m) value)
          ((and (= (match:start m) (match:end m)) abuts)

module/language/tree-il/primitives.scm

@@ -516,6 +516,27 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+  (case-lambda
+    ((src a b)
+     ;; Simplify cases where either A or B is constant.
+     (define (maybe-simplify a b)
+       (and (const? a)
+            (let ((v (const-exp a)))
+              (and (or (memq v '(#f #t () #nil))
+                       (symbol? v)
+                       (and (integer? v)
+                            (exact? v)
+                            (<= v most-positive-fixnum)
+                            (>= v most-negative-fixnum)))
+                   (make-primcall src 'eq? (list a b))))))
+     (or (maybe-simplify a b) (maybe-simplify b a)))
+    (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv?   maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
 (hashq-set! *primitive-expand-table*
             '@dynamic-wind
             (case-lambda

module/srfi/srfi-19.scm

@@ -1113,13 +1113,13 @@
    (cons #\1 (lambda (date pad-with port)
                (display (date->string date "~Y-~m-~d") port)))
    (cons #\2 (lambda (date pad-with port)
-               (display (date->string date "~k:~M:~S~z") port)))
+               (display (date->string date "~H:~M:~S~z") port)))
    (cons #\3 (lambda (date pad-with port)
-               (display (date->string date "~k:~M:~S") port)))
+               (display (date->string date "~H:~M:~S") port)))
    (cons #\4 (lambda (date pad-with port)
-               (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+               (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
    (cons #\5 (lambda (date pad-with port)
-               (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+               (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
 
 
 (define (get-formatter char)

module/srfi/srfi-31.scm

@@ -1,6 +1,6 @@
 ;;; srfi-31.scm --- special form for recursive evaluation
 
-;; 	Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2004, 2006, 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
@@ -19,17 +19,15 @@
 ;;; Original author: Rob Browning <rlb@defaultvalue.org>
 
 (define-module (srfi srfi-31)
-  :export-syntax (rec))
+  #:export (rec))
 
-(define-macro (rec arg-form . body)
-  (cond
-   ((and (symbol? arg-form) (= 1 (length body)))
-    ;; (rec S (cons 1 (delay S)))
-    `(letrec ((,arg-form ,(car body)))
-       ,arg-form))
-   ;; (rec (f x) (+ x 1))
-   ((list? arg-form)
-    `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
-       ,(car arg-form)))
-   (else
-    (error "syntax error in rec form" `(rec ,arg-form ,@body)))))
+(define-syntax rec
+  (syntax-rules ()
+    "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+    ((_ (name . formals) body ...)                ; procedure
+     (letrec ((name (lambda formals body ...)))
+       name))
+    ((_ name expr)                                ; arbitrary object
+     (letrec ((name expr))
+       name))))

module/system/base/compile.scm

@@ -1,6 +1,6 @@
 ;;; High-level compiler interface
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -72,7 +72,7 @@
 ;; before the check, so that we avoid races (possibly due to parallel
 ;; compilation).
 ;;
-(define (ensure-writable-dir dir)
+(define (ensure-directory dir)
   (catch 'system-error
     (lambda ()
       (mkdir dir))
@@ -80,13 +80,12 @@
       (let ((errno (and (pair? rest) (car rest))))
         (cond
          ((eqv? errno EEXIST)
-          (let ((st (stat dir)))
-            (if (or (not (eq? (stat:type st) 'directory))
-                    (not (access? dir W_OK)))
-                (error "directory not writable" dir))))
+          ;; Assume it's a writable directory, to avoid TOCTOU errors,
+          ;; as well as UID/EUID mismatches that occur with access(2).
+          #t)
          ((eqv? errno ENOENT)
-          (ensure-writable-dir (dirname dir))
-          (ensure-writable-dir dir))
+          (ensure-directory (dirname dir))
+          (ensure-directory dir))
          (else
           (throw k subr fmt args rest)))))))
 
@@ -125,7 +124,7 @@
                  %compile-fallback-path
                  (canonical->suffix (canonicalize-path file))
                  (compiled-extension))))
-         (and (false-if-exception (ensure-writable-dir (dirname f)))
+         (and (false-if-exception (ensure-directory (dirname f)))
               f))))
 
 (define* (compile-file file #:key
@@ -144,7 +143,7 @@
       ;; Choose the input encoding deterministically.
       (set-port-encoding! in (or enc "UTF-8"))
 
-      (ensure-writable-dir (dirname comp))
+      (ensure-directory (dirname comp))
       (call-with-output-file/atomic comp
         (lambda (port)
           ((language-printer (ensure-language to))

module/texinfo.scm

@@ -384,8 +384,14 @@ Examples:
 
 ;; Like a DTD for texinfo
 (define (command-spec command)
-  (or (assq command texi-command-specs)
-      (parser-error #f "Unknown command" command)))
+  (let ((spec (assq command texi-command-specs)))
+    (cond
+     ((not spec)
+      (parser-error #f "Unknown command" command))
+     ((eq? (cadr spec) 'ALIAS)
+      (command-spec (cddr spec)))
+     (else
+      spec))))
 
 (define (inline-content? content)
   (case content
@@ -647,11 +653,10 @@ Examples:
     (arguments->attlist port (read-arguments port stop-char) arg-names))
 
   (let* ((spec (command-spec command))
+         (command (car spec))
          (type (cadr spec))
          (arg-names (cddr spec)))
     (case type
-      ((ALIAS)
-       (complete-start-command arg-names port))
       ((INLINE-TEXT)
        (assert-curr-char '(#\{) "Inline element lacks {" port)
        (values command '() type))
@@ -954,7 +959,9 @@ Examples:
                          (loop port expect-eof? end-para need-break? seed)))
                       ((START)          ; Start of an @-command
                        (let* ((head (token-head token))
-                              (type (cadr (command-spec head)))
+                              (spec (command-spec head))
+                              (head (car spec))
+                              (type (cadr spec))
                               (inline? (inline-content? type))
                               (seed ((if (and inline? (not need-break?))
                                          identity end-para) seed))
@@ -1045,8 +1052,9 @@ Examples:
    (lambda (command args content seed)      ; fdown
      '())
    (lambda (command args parent-seed seed)  ; fup
-     (let ((seed (reverse-collect-str-drop-ws seed))
-           (spec (command-spec command)))
+     (let* ((seed (reverse-collect-str-drop-ws seed))
+            (spec (command-spec command))
+            (command (car spec)))
        (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
            (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
                  parent-seed)
@@ -1062,8 +1070,10 @@ Examples:
   (let ((parser (make-dom-parser)))
     ;; duplicate arguments->attlist to avoid unnecessary splitting
     (lambda (command port)
-      (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
-            (arg-names (cddr (command-spec command))))
+      (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+             (spec (command-spec command))
+             (command (car spec))
+             (arg-names (cddr spec)))
         (cond
          ((not arg-names)
           (if (null? args) '()

module/web/client.scm

@@ -1,6 +1,6 @@
 ;;; Web client
 
-;; 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
@@ -42,19 +42,37 @@
             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))
+  "Return an open input/output port for a connection to URI."
+  (define addresses
+    (let ((port (uri-port uri)))
+      (getaddrinfo (uri-host uri)
+                   (cond (port => number->string)
+                         (else (symbol->string (uri-scheme uri))))
+                   (if port
+                       AI_NUMERICSERV
+                       0))))
+
+  (let loop ((addresses addresses))
+    (let* ((ai (car addresses))
+           (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                       (addrinfo:protocol ai))))
+      (set-port-encoding! s "ISO-8859-1")
+
+      (catch 'system-error
+        (lambda ()
+          (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)
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (close s)
+          (if (null? addresses)
+              (apply throw args)
+              (loop (cdr addresses))))))))
 
 (define (decode-string bv encoding)
   (if (string-ci=? encoding "utf-8")

module/web/uri.scm

@@ -364,7 +364,9 @@ Percent-encoding first writes out the given character to a bytevector
 within the given @var{encoding}, then encodes each byte as
 @code{%@var{HH}}, where @var{HH} is the hexadecimal representation of
 the byte."
-  (if (string-index str unescaped-chars)
+  (define (needs-escaped? ch)
+    (not (char-set-contains? unescaped-chars ch)))
+  (if (string-index str needs-escaped?)
       (call-with-output-string*
        (lambda (port)
          (string-for-each
@@ -377,6 +379,8 @@ the byte."
                     (if (< i len)
                         (let ((byte (bytevector-u8-ref bv i)))
                           (display #\% port)
+                          (when (< byte 16)
+                            (display #\0 port))
                           (display (number->string byte 16) port)
                           (lp (1+ i))))))))
           str)))