[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-198-gc04bf43
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-198-gc04bf43 |
|
Date: |
Fri, 13 Sep 2013 04:24:11 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c04bf4337b88ea45641065b7fe70dd0973b8ce94
The branch, master has been updated
via c04bf4337b88ea45641065b7fe70dd0973b8ce94 (commit)
via 803c087e6b72f59ed9e529c1e1ca4fbe34e8eda5 (commit)
via 76702cdcefb1d4a149b78fa0a474d22bed348e75 (commit)
via 3b2226ec916b648b23a2ae30ce1a657d16d61314 (commit)
via 361553b49d89b2668cff967401d602ab930a26c4 (commit)
via 89ffbb1c2e8d06ec35b8c994e65b9bb7ad29e52a (commit)
via f3f7a02600f14b039f6ef8ee6572342bdc76519c (commit)
via 55e29bb55bcc0e128a962ccae9e26876ccfab6c6 (commit)
via 9c85fd02218705033f18befafa04d9c8c6b76297 (commit)
via 112fc7c2a554a93a63f4cac1419f644f907431db (commit)
via c4b7ba688aba07254059f830f972756bcad0eb9b (commit)
via 0bf4a5fc2ea456ed74d45f52e2f1dd08d5e1fb9e (commit)
from 6871327742d3e1a0966aa8fed04c911311c12c2a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c04bf4337b88ea45641065b7fe70dd0973b8ce94
Merge: 6871327 803c087
Author: Mark H Weaver <address@hidden>
Date: Fri Sep 13 00:24:04 2013 -0400
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
module/srfi/srfi-9.scm
module/web/server.scm
-----------------------------------------------------------------------
Summary of changes:
THANKS | 2 +
doc/ref/api-io.texi | 1 +
module/ice-9/and-let-star.scm | 52 +++++++++++++++++++---------------------
module/ice-9/boot-9.scm | 2 +
module/ice-9/psyntax.scm | 6 ++++
module/srfi/srfi-9.scm | 5 +++-
module/web/client.scm | 32 +++++++++++++-----------
module/web/server.scm | 10 +++----
test-suite/tests/srfi-9.test | 10 +++++--
9 files changed, 68 insertions(+), 52 deletions(-)
diff --git a/THANKS b/THANKS
index c517cf7..222bcfd 100644
--- a/THANKS
+++ b/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
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 19ed3fc..5ca3506 100644
--- a/doc/ref/api-io.texi
+++ b/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
diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm
index bfd597b..ff15a7a 100644
--- a/module/ice-9/and-let-star.scm
+++ b/module/ice-9/and-let-star.scm
@@ -1,7 +1,6 @@
-;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile
-;;;; written by Michael Livshin <address@hidden>
+;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
;;;;
-;;;; 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)
- (cond
- ((null? vars)
- (if (null? body)
- #t
- `(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))
+(define-syntax and-let*
+ (lambda (form)
+ (syntax-case form ()
+ ((_ (c ...) body ...)
+ #`(%and-let* #,form (c ...) body ...)))))
(cond-expand-provide (current-module) '(srfi-2))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index cf0dcd8..87c38af 100644
--- a/module/ice-9/boot-9.scm
+++ b/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))))))))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0ad3db5..4b66b8b 100644
--- a/module/ice-9/psyntax.scm
+++ b/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,
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 2f092fe..7275eaf 100644
--- a/module/srfi/srfi-9.scm
+++ b/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))))))))))
diff --git a/module/web/client.scm b/module/web/client.scm
index 24132c6..3f6c45b 100644
--- a/module/web/client.scm
+++ b/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)
- #:headers
- (assoc-set! (copy-tree (request-headers r))
- k v)
- #:port (request-port r))))
+ (let ((r (set-field r (request-headers)
+ (assoc-set! (copy-tree (request-headers r))
+ k v))))
(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.
diff --git a/module/web/server.scm b/module/web/server.scm
index affc2e6..471bb98 100644
--- a/module/web/server.scm
+++ b/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)
- #:code (response-code r)
- #:headers
- (extend-alist (response-headers r) k v)
- #:port (response-port r))))
+ (let ((r (set-field r (response-headers)
+ (extend-alist (response-headers r) k v))))
(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.
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index e951fc6..e1812bf 100644
--- a/test-suite/tests/srfi-9.test
+++ b/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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-198-gc04bf43,
Mark H Weaver <=