summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--THANKS2
-rw-r--r--doc/ref/api-io.texi1
-rw-r--r--module/ice-9/and-let-star.scm52
-rw-r--r--module/ice-9/boot-9.scm2
-rw-r--r--module/ice-9/psyntax.scm6
-rw-r--r--module/srfi/srfi-9.scm5
-rw-r--r--module/web/client.scm32
-rw-r--r--module/web/server.scm10
-rw-r--r--test-suite/tests/srfi-9.test10
9 files changed, 68 insertions, 52 deletions
diff --git a/THANKS b/THANKS
index c517cf724..222bcfd3a 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 19ed3fca6..5ca3506a9 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 bfd597b1e..ff15a7a1e 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 <mike@olan.com>
+;;;; 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 cf0dcd8d8..87c38af8a 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 0ad3db562..4b66b8b04 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 2f092fe3b..7275eafcf 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 24132c674..3f6c45bfe 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 affc2e6b6..471bb98de 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 e951fc67f..e1812bfbf 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