dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Mark H Weaver 2013-07-18 15:31:34 -04:00
commit f82f62944a
12 changed files with 108 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -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@

14
doc/ref/web.texi
View file

@ -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

50
libguile/_scm.h
View file

@ -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 */

5
libguile/tags.h
View file

@ -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
/*

2
module/rnrs/arithmetic/bitwise.scm
View file

@ -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

16
module/rnrs/arithmetic/fixnums.scm
View file

@ -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))

2
module/rnrs/arithmetic/flonums.scm
View file

@ -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

14
module/web/client.scm
View file

@ -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.

25
module/web/http.scm
View file

@ -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))

2
test-suite/tests/r6rs-arithmetic-bitwise.test
View file

@ -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

14
test-suite/tests/r6rs-arithmetic-fixnums.test
View file

@ -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)))

2
test-suite/tests/r6rs-arithmetic-flonums.test
View file

@ -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