summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-07-18 15:31:34 -0400
committerMark H Weaver <mhw@netris.org>2013-07-18 15:31:34 -0400
commitf82f62944a4e605d385f40b5a4a01e19677bc0b3 (patch)
tree7fc4a887fd5033748dc1e9603052514e5e58f2ca
parent902a4e779da1193ff9097c23b40fbd44ab2df6a3 (diff)
parent824b9ad8b792ab42c5cc614d66462dfaab489075 (diff)
downloadguile-f82f62944a4e605d385f40b5a4a01e19677bc0b3.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
-rw-r--r--Makefile.am3
-rw-r--r--doc/ref/web.texi14
-rw-r--r--libguile/_scm.h50
-rw-r--r--libguile/tags.h5
-rw-r--r--module/rnrs/arithmetic/bitwise.scm2
-rw-r--r--module/rnrs/arithmetic/fixnums.scm16
-rw-r--r--module/rnrs/arithmetic/flonums.scm2
-rw-r--r--module/web/client.scm14
-rw-r--r--module/web/http.scm25
-rw-r--r--test-suite/tests/r6rs-arithmetic-bitwise.test2
-rw-r--r--test-suite/tests/r6rs-arithmetic-fixnums.test14
-rw-r--r--test-suite/tests/r6rs-arithmetic-flonums.test2
12 files changed, 108 insertions, 41 deletions
diff --git a/Makefile.am b/Makefile.am
index 8cdcc7e4e..2ed837046 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -64,7 +64,8 @@ EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
gnulib-local/lib/localcharset.c.diff \
gnulib-local/m4/clock_time.m4.diff \
gnulib-local/build-aux/git-version-gen.diff \
- libguile/texi-fragments-to-docstrings
+ libguile/texi-fragments-to-docstrings \
+ gdbinit
TESTS = check-guile
TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 0d41f9f7a..c59f9580d 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1459,6 +1459,20 @@ fetcher, similar in structure to the web server (@pxref{Web Server}).
Another option, good but not as performant, would be to use threads,
possibly via par-map or futures.
+@deffn {Scheme Parameter} current-http-proxy
+Either @code{#f} or a non-empty string containing the URL of the HTTP
+proxy server to be used by the procedures in the @code{(web client)}
+module, including @code{open-socket-for-uri}. Its initial value is
+based on the @env{http_proxy} environment variable.
+
+@example
+(current-http-proxy) @result{} "http://localhost:8123/"
+(parameterize ((current-http-proxy #f))
+ (http-get "http://example.com/")) ; temporarily bypass proxy
+(current-http-proxy) @result{} "http://localhost:8123/"
+@end example
+@end deffn
+
@node Web Server
@subsection Web Server
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 7dd188d33..1ec93fbb4 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -3,7 +3,8 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
-/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2002, 2006, 2008, 2009, 2010,
+ * 2011, 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 License
@@ -93,18 +94,17 @@
#ifdef vms
# ifndef __GNUC__
# include <ssdef.h>
-# define SCM_SYSCALL(line) \
- do \
- { \
- errno = 0; \
- line; \
- if (EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) \
- { \
- SCM_ASYNC_TICK; \
- continue; \
- } \
- } \
- while(0)
+# define SCM_SYSCALL(line) \
+ do \
+ { \
+ errno = 0; \
+ line; \
+ if (EVMSERR == errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) \
+ SCM_ASYNC_TICK; \
+ else \
+ break; \
+ } \
+ while (1)
# endif /* ndef __GNUC__ */
#endif /* def vms */
#endif /* ndef SCM_SYSCALL */
@@ -112,18 +112,18 @@
#ifndef SCM_SYSCALL
# ifdef EINTR
# if (EINTR > 0)
-# define SCM_SYSCALL(line) \
- do \
- { \
- errno = 0; \
- line; \
- if (errno == EINTR) \
- { \
- SCM_ASYNC_TICK; \
- continue; \
- } \
- } \
- while(0)
+# define SCM_SYSCALL(line) \
+ do \
+ { \
+ errno = 0; \
+ line; \
+ if (errno == EINTR) \
+ { \
+ SCM_ASYNC_TICK; \
+ errno = EINTR; \
+ } \
+ } \
+ while (errno == EINTR)
# endif /* (EINTR > 0) */
# endif /* def EINTR */
#endif /* ndef SCM_SYSCALL */
diff --git a/libguile/tags.h b/libguile/tags.h
index fcfc01478..234d4c77c 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -87,14 +87,15 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
The 0?: constructions makes sure that the code is never executed,
and that there is no performance hit. However, the alternative is
compiled, and does generate a warning when used with the wrong
- pointer type.
+ pointer type. We use a volatile pointer type to avoid warnings
+ from clang.
The Tru64 and ia64-hp-hpux11.23 compilers fail on `case (0?0=0:x)'
statements, so for them type-checking is disabled. */
#if defined __DECC || defined __HP_cc
# define SCM_UNPACK(x) ((scm_t_bits) (x))
#else
-# define SCM_UNPACK(x) ((scm_t_bits) (0? (*(SCM*)0=(x)): x))
+# define SCM_UNPACK(x) ((scm_t_bits) (0? (*(volatile SCM *)0=(x)): x))
#endif
/*
diff --git a/module/rnrs/arithmetic/bitwise.scm b/module/rnrs/arithmetic/bitwise.scm
index ac870ff79..0acbc8cb6 100644
--- a/module/rnrs/arithmetic/bitwise.scm
+++ b/module/rnrs/arithmetic/bitwise.scm
@@ -1,6 +1,6 @@
;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 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
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index e6261999a..7a5a6215e 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -1,6 +1,6 @@
;;; fixnums.scm --- The R6RS fixnums arithmetic library
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 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
@@ -95,8 +95,11 @@
(rnrs exceptions (6))
(rnrs lists (6)))
- (define fixnum-width
- (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2))))))
+ (define fixnum-width
+ (let ((w (do ((i 0 (+ 1 i))
+ (n 1 (* 2 n)))
+ ((> n most-positive-fixnum)
+ (+ 1 i)))))
(lambda () w)))
(define (greatest-fixnum) most-positive-fixnum)
@@ -227,7 +230,12 @@
(assert-fixnum fx1 fx2 fx3)
(bitwise-if fx1 fx2 fx3))
- (define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
+ (define (fxbit-count fx)
+ (assert-fixnum fx)
+ (if (negative? fx)
+ (bitwise-not (logcount fx))
+ (logcount fx)))
+
(define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
(define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
(define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm
index fd04a4a0e..1c4b94ce7 100644
--- a/module/rnrs/arithmetic/flonums.scm
+++ b/module/rnrs/arithmetic/flonums.scm
@@ -1,6 +1,6 @@
;;; flonums.scm --- The R6RS flonums arithmetic library
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 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
diff --git a/module/web/client.scm b/module/web/client.scm
index 7d5ea4989..24132c674 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -39,8 +39,10 @@
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
+ #:use-module (web http)
#:use-module (srfi srfi-1)
- #:export (open-socket-for-uri
+ #:export (current-http-proxy
+ open-socket-for-uri
http-get
http-get*
http-head
@@ -50,6 +52,11 @@
http-trace
http-options))
+(define current-http-proxy
+ (make-parameter (let ((proxy (getenv "http_proxy")))
+ (and (not (equal? proxy ""))
+ proxy))))
+
(define (ensure-uri uri-or-string)
(cond
((string? uri-or-string) (string->uri uri-or-string))
@@ -58,7 +65,8 @@
(define (open-socket-for-uri uri-or-string)
"Return an open input/output port for a connection to URI."
- (define uri (ensure-uri uri-or-string))
+ (define http-proxy (current-http-proxy))
+ (define uri (ensure-uri (or http-proxy uri-or-string)))
(define addresses
(let ((port (uri-port uri)))
(delete-duplicates
@@ -84,6 +92,8 @@
(setvbuf s _IOFBF)
;; Enlarge the receive buffer.
(setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+ ;; If we're using a proxy, make a note of that.
+ (when http-proxy (set-http-proxy-port?! s #t))
s)
(lambda args
;; Connection failed, so try one of the other addresses.
diff --git a/module/web/http.scm b/module/web/http.scm
index 35169ef5c..21d2964b4 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -66,7 +66,10 @@
write-response-line
make-chunked-input-port
- make-chunked-output-port))
+ make-chunked-output-port
+
+ http-proxy-port?
+ set-http-proxy-port?!))
(define (string->header name)
@@ -1117,6 +1120,21 @@ three values: the method, the URI, and the version."
"Write the first line of an HTTP request to PORT."
(display method port)
(display #\space port)
+ (when (http-proxy-port? port)
+ (let ((scheme (uri-scheme uri))
+ (host (uri-host uri))
+ (host-port (uri-port uri)))
+ (when (and scheme host)
+ (display scheme port)
+ (display "://" port)
+ (if (string-index host #\:)
+ (begin (display #\[ port)
+ (display host port)
+ (display #\] port))
+ (display host port))
+ (unless ((@@ (web uri) default-port?) scheme host-port)
+ (display #\: port)
+ (display host-port port)))))
(let ((path (uri-path uri))
(query (uri-query uri)))
(if (not (string-null? path))
@@ -1958,3 +1976,8 @@ KEEP-ALIVE? is true."
(unless keep-alive?
(close-port port)))
(make-soft-port (vector put-char put-string flush #f close) "w"))
+
+(define %http-proxy-port? (make-object-property))
+(define (http-proxy-port? port) (%http-proxy-port? port))
+(define (set-http-proxy-port?! port flag)
+ (set! (%http-proxy-port? port) flag))
diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test b/test-suite/tests/r6rs-arithmetic-bitwise.test
index c864f3b68..3b358461c 100644
--- a/test-suite/tests/r6rs-arithmetic-bitwise.test
+++ b/test-suite/tests/r6rs-arithmetic-bitwise.test
@@ -1,6 +1,6 @@
;;; arithmetic-bitwise.test --- Test suite for R6RS (rnrs arithmetic bitwise)
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 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
diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test
index d39d5448b..60c3b87e9 100644
--- a/test-suite/tests/r6rs-arithmetic-fixnums.test
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -1,6 +1,6 @@
;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 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
@@ -23,6 +23,14 @@
:use-module ((rnrs exceptions) :version (6))
:use-module (test-suite lib))
+(with-test-prefix "fixnum-width"
+ (pass-if-equal "consistent with least-fixnum"
+ (- (expt 2 (- (fixnum-width) 1)))
+ (least-fixnum))
+ (pass-if-equal "consistent with greatest-fixnum"
+ (- (expt 2 (- (fixnum-width) 1)) 1)
+ (greatest-fixnum)))
+
(with-test-prefix "fixnum?"
(pass-if "fixnum? is #t for fixnums" (fixnum? 0))
@@ -157,7 +165,9 @@
(with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))
-(with-test-prefix "fxbit-count" (pass-if "simple" (fx=? (fxbit-count 5) 2)))
+(with-test-prefix "fxbit-count"
+ (pass-if "simple" (fx=? (fxbit-count 5) 2))
+ (pass-if "negative" (fx=? (fxbit-count -5) -2)))
(with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))
diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test
index 3df00b247..ea425e3dc 100644
--- a/test-suite/tests/r6rs-arithmetic-flonums.test
+++ b/test-suite/tests/r6rs-arithmetic-flonums.test
@@ -1,6 +1,6 @@
;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums)
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 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