From: Mark H Weaver Date: Fri, 13 Sep 2013 04:24:04 +0000 (-0400) Subject: Merge remote-tracking branch 'origin/stable-2.0' X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/c04bf4337b88ea45641065b7fe70dd0973b8ce94?hp=6871327742d3e1a0966aa8fed04c911311c12c2a Merge remote-tracking branch 'origin/stable-2.0' Conflicts: module/srfi/srfi-9.scm module/web/server.scm --- 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 +;;;; 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. +;;; + + ;;; 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