diff options
author | Mark H Weaver <mhw@netris.org> | 2013-07-18 15:31:34 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2013-07-18 15:31:34 -0400 |
commit | f82f62944a4e605d385f40b5a4a01e19677bc0b3 (patch) | |
tree | 7fc4a887fd5033748dc1e9603052514e5e58f2ca | |
parent | 902a4e779da1193ff9097c23b40fbd44ab2df6a3 (diff) | |
parent | 824b9ad8b792ab42c5cc614d66462dfaab489075 (diff) | |
download | guile-f82f62944a4e605d385f40b5a4a01e19677bc0b3.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
-rw-r--r-- | Makefile.am | 3 | ||||
-rw-r--r-- | doc/ref/web.texi | 14 | ||||
-rw-r--r-- | libguile/_scm.h | 50 | ||||
-rw-r--r-- | libguile/tags.h | 5 | ||||
-rw-r--r-- | module/rnrs/arithmetic/bitwise.scm | 2 | ||||
-rw-r--r-- | module/rnrs/arithmetic/fixnums.scm | 16 | ||||
-rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 2 | ||||
-rw-r--r-- | module/web/client.scm | 14 | ||||
-rw-r--r-- | module/web/http.scm | 25 | ||||
-rw-r--r-- | test-suite/tests/r6rs-arithmetic-bitwise.test | 2 | ||||
-rw-r--r-- | test-suite/tests/r6rs-arithmetic-fixnums.test | 14 | ||||
-rw-r--r-- | test-suite/tests/r6rs-arithmetic-flonums.test | 2 |
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 |