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

Conflicts:
	module/srfi/srfi-9.scm
	module/web/server.scm

THANKS

@@ -60,6 +60,7 @@ For fixes or providing information which led to a fix:
         Michael Carmack
           Jozef Chraplewski
               R Clayton
+      Alexandru Cojocaru
         Tristan Colgate
         Stephen Compall
           Brian Crowder
@@ -73,6 +74,7 @@ For fixes or providing information which led to a fix:
           David Fang
           Barry Fishman
        Kevin J. Fletcher
+ Josep Portella Florit
         Charles Gagnon
              Fu-gangqiang
           Aidan Gauland

doc/ref/api-io.texi

@@ -2107,6 +2107,7 @@ index @var{start} and limiting to @var{count} octets.
 
 @deffn {Scheme Procedure} put-char port char
 Writes @var{char} to the port. The @code{put-char} procedure returns
+an unspecified value.
 @end deffn
 
 @deffn {Scheme Procedure} put-string port string

module/ice-9/and-let-star.scm

@@ -1,7 +1,6 @@
-;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile
+;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
-;;;; written by Michael Livshin <mike@olan.com>
 ;;;;
-;;;; 	Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 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
@@ -20,30 +19,29 @@
 (define-module (ice-9 and-let-star)
   :export-syntax (and-let*))
 
-(defmacro and-let* (vars . body)
+(define-syntax %and-let*
+  (lambda (form)
+    (syntax-case form ()
+      ((_ orig-form ())
+       #'#t)
+      ((_ orig-form () body bodies ...)
+       #'(begin body bodies ...))
+      ((_ orig-form ((var exp) c ...) body ...)
+       (identifier? #'var)
+       #'(let ((var exp))
+           (and var (%and-let* orig-form (c ...) body ...))))
+      ((_ orig-form ((exp) c ...) body ...)
+       #'(and exp (%and-let* orig-form (c ...) body ...)))
+      ((_ orig-form (var c ...) body ...)
+       (identifier? #'var)
+       #'(and var (%and-let* orig-form (c ...) body ...)))
+      ((_ orig-form (bad-clause c ...) body ...)
+       (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
 
-  (define (expand vars body)
+(define-syntax and-let*
-    (cond
+  (lambda (form)
-     ((null? vars)
+    (syntax-case form ()
-      (if (null? body)
+      ((_ (c ...) body ...)
-	  #t
+       #`(%and-let* #,form (c ...) body ...)))))
-	  `(begin ,@body)))
-     ((pair? vars)
-      (let ((exp (car vars)))
-        (cond
-         ((pair? exp)
-          (cond
-           ((null? (cdr exp))
-            `(and ,(car exp) ,(expand (cdr vars) body)))
-           (else
-            (let ((var (car exp)))
-              `(let (,exp)
-                 (and ,var ,(expand (cdr vars) body)))))))
-         (else
-          `(and ,exp ,(expand (cdr vars) body))))))
-     (else
-      (error "not a proper list" vars))))
-
-  (expand vars body))
 
 (cond-expand-provide (current-module) '(srfi-2))

module/ice-9/boot-9.scm

@@ -4328,6 +4328,8 @@ when none is available, reading FILE-NAME with READER."
                          (lambda (formals ...)
                            body ...))
                        args ...))
+                   ((_ a (... ...))
+                    (syntax-violation 'name "Wrong number of arguments" x))
                    (_
                     (identifier? x)
                     #'proc-name))))))))))

module/ice-9/psyntax.scm

@@ -43,6 +43,12 @@
 ;;; revision control logs corresponding to this file: 2009, 2010.
 
 
+;;; This code is based on "Syntax Abstraction in Scheme"
+;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
+;;; Lisp and Symbolic Computation 5:4, 295-326, 1992.
+;;; <http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf>
+
+
 ;;; This file defines the syntax-case expander, macroexpand, and a set
 ;;; of associated syntactic forms and procedures.  Of these, the
 ;;; following are documented in The Scheme Programming Language,

module/srfi/srfi-9.scm

@@ -1,6 +1,7 @@
 ;;; srfi-9.scm --- define-record-type
 
-;; 	Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
+;;   2013 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
@@ -122,6 +123,8 @@
                     #'((lambda (formals ...)
                          body ...)
                        args ...))
+                   ((_ a (... ...))
+                    (syntax-violation 'name "Wrong number of arguments" x))
                    (_
                     (identifier? x)
                     #'proc-name))))))))))

module/web/client.scm

@@ -41,6 +41,8 @@
   #:use-module (web uri)
   #:use-module (web http)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:export (current-http-proxy
             open-socket-for-uri
             http-get
@@ -103,11 +105,9 @@
               (loop (cdr addresses))))))))
 
 (define (extend-request r k v . additional)
-  (let ((r (build-request (request-uri r) #:version (request-version r)
+  (let ((r (set-field r (request-headers)
-                          #:headers
                       (assoc-set! (copy-tree (request-headers r))
-                                      k v)
+                                  k v))))
-                          #:port (request-port r))))
     (if (null? additional)
         r
         (apply extend-request r additional))))
@@ -136,6 +136,9 @@ as is the case by default with a request returned by `build-request'."
    ((not body)
     (let ((length (request-content-length request)))
       (if length
+          ;; FIXME make this stricter: content-length header should be
+          ;; prohibited if there's no body, even if the content-length
+          ;; is 0.
           (unless (zero? length)
             (error "content-length, but no body"))
           (when (assq 'transfer-encoding (request-headers request))
@@ -171,7 +174,6 @@ as is the case by default with a request returned by `build-request'."
                (rlen (if (= rlen blen)
                          request
                          (error "bad content-length" rlen blen)))
-               ((zero? blen) request)
                (else (extend-request request 'content-length blen))))
             body))))
 
@@ -204,7 +206,7 @@ as is the case by default with a request returned by `build-request'."
 (define* (request uri #:key
                   (body #f)
                   (port (open-socket-for-uri uri))
-                  (method "GET")
+                  (method 'GET)
                   (version '(1 . 1))
                   (keep-alive? #f)
                   (headers '())
@@ -227,7 +229,7 @@ as is the case by default with a request returned by `build-request'."
         (force-output (request-port request))
         (let ((response (read-response port)))
           (cond
-           ((equal? (request-method request) "HEAD")
+           ((eq? (request-method request) 'HEAD)
             (unless keep-alive?
               (close-port port))
             (values response #f))
@@ -282,7 +284,7 @@ true)."
     (issue-deprecation-warning
      "The #:extra-headers argument to http-get has been renamed to #:headers. "
      "Please update your code."))
-  (request uri #:method "GET" #:body body
+  (request uri #:method 'GET #:body body
            #:port port #:version version #:keep-alive? keep-alive?
            #:headers headers #:decode-body? decode-body?
            #:streaming? streaming?))
@@ -319,7 +321,7 @@ true)."
              #:streaming? streaming?)))
 
 (define-http-verb http-head
-  "HEAD"
+  'HEAD
   "Fetch message headers for the given URI using the HTTP \"HEAD\"
 method.
 
@@ -332,7 +334,7 @@ requests do not have a body.  The second value is only returned so that
 other procedures can treat all of the http-foo verbs identically.")
 
 (define-http-verb http-post
-  "POST"
+  'POST
   "Post data to the given URI using the HTTP \"POST\" method.
 
 This function is similar to ‘http-get’, except it uses the \"POST\"
@@ -342,7 +344,7 @@ arguments that are accepted by this function.
 Returns two values: the resulting response, and the response body.")
 
 (define-http-verb http-put
-  "PUT"
+  'PUT
   "Put data at the given URI using the HTTP \"PUT\" method.
 
 This function is similar to ‘http-get’, except it uses the \"PUT\"
@@ -352,7 +354,7 @@ arguments that are accepted by this function.
 Returns two values: the resulting response, and the response body.")
 
 (define-http-verb http-delete
-  "DELETE"
+  'DELETE
   "Delete data at the given URI using the HTTP \"DELETE\" method.
 
 This function is similar to ‘http-get’, except it uses the \"DELETE\"
@@ -362,7 +364,7 @@ arguments that are accepted by this function.
 Returns two values: the resulting response, and the response body.")
 
 (define-http-verb http-trace
-  "TRACE"
+  'TRACE
   "Send an HTTP \"TRACE\" request.
 
 This function is similar to ‘http-get’, except it uses the \"TRACE\"
@@ -372,7 +374,7 @@ arguments that are accepted by this function.
 Returns two values: the resulting response, and the response body.")
 
 (define-http-verb http-options
-  "OPTIONS"
+  'OPTIONS
   "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\"
 method.
 

module/web/server.scm

@@ -74,6 +74,7 @@
 
 (define-module (web server)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (web request)
@@ -167,11 +168,8 @@ values."
   (define (extend-alist alist k v)
     (let ((pair (assq k alist)))
       (acons k v (if pair (delq pair alist) alist))))
-  (let ((r (build-response #:version (response-version r)
+  (let ((r (set-field r (response-headers)
-                           #:code (response-code r)
+                      (extend-alist (response-headers r) k v))))
-                           #:headers
-                           (extend-alist (response-headers r) k v)
-                           #:port (response-port r))))
     (if (null? additional)
         r
         (apply extend-response r additional))))
@@ -234,6 +232,7 @@ on the procedure being called at any particular time."
     (error "unexpected body type"))
    ((and (response-must-not-include-body? response)
          body
+         ;; FIXME make this stricter: even an empty body should be prohibited.
          (not (zero? (bytevector-length body))))
     (error "response with this status code must not include body" response))
    (else
@@ -244,7 +243,6 @@ on the procedure being called at any particular time."
                (rlen (if (= rlen blen)
                          response
                          (error "bad content-length" rlen blen)))
-               ((zero? blen) response)
                (else (extend-response response 'content-length blen))))
             (if (eq? (request-method request) 'HEAD)
                 ;; Responses to HEAD requests must not include bodies.

test-suite/tests/srfi-9.test

@@ -1,7 +1,8 @@
 ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
 ;;;; Martin Grabmueller, 2001-05-10
 ;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012,
+;;;;   2013 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
@@ -41,15 +42,18 @@
 
 (define b (make-bar 123 456))
 
+(define exception:syntax-error-wrong-num-args
+  (cons 'syntax-error "Wrong number of arguments"))
+
 (with-test-prefix "constructor"
 
   ;; Constructors are defined using `define-integrable', meaning that direct
   ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
   ;; distinction below.
 
-  (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched
+  (pass-if-exception "foo 0 args (inline)" exception:syntax-error-wrong-num-args
      (compile '(make-foo) #:env (current-module)))
-  (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched
+  (pass-if-exception "foo 2 args (inline)" exception:syntax-error-wrong-num-args
      (compile '(make-foo 1 2) #:env (current-module)))
 
   (pass-if-exception "foo 0 args" exception:wrong-num-args