[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-41-gd74fcce

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d74fcce9b98135042fd713180c587dff0239d6b3

The branch, stable-2.0 has been updated
       via  d74fcce9b98135042fd713180c587dff0239d6b3 (commit)
       via  2663411bd7d7d6b7be6c674c4e6c35c22e2e3c19 (commit)
       via  8ac870dee4397c3b3f0ac24b072e88e87b91e47e (commit)
      from  6996f07f577416505b2e33e5967f9fcc933559b7 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit d74fcce9b98135042fd713180c587dff0239d6b3
Author: Ludovic Courtès <address@hidden>
Date:   Fri Oct 12 23:09:44 2012 +0200

    web: Pass `AI_NUMERICSERV' when given a port number.
    
    * module/web/client.scm (open-socket-for-uri)[addresses]: Pass
      AI_NUMERICSERV as the `getaddrinfo' hint when (uri-port URI) is true.

commit 2663411bd7d7d6b7be6c674c4e6c35c22e2e3c19
Author: Ludovic Courtès <address@hidden>
Date:   Fri Oct 12 23:05:22 2012 +0200

    web: Change `http-get' to try all the addresses for the given URI.
    
    * module/web/client.scm (open-socket-for-uri): Try all the addresses
      returned by `getaddrinfo' until one succeeds.

commit 8ac870dee4397c3b3f0ac24b072e88e87b91e47e
Author: Ludovic Courtès <address@hidden>
Date:   Fri Oct 12 23:03:39 2012 +0200

    Implement `hash' for structs.
    
    * libguile/hash.c (scm_hasher): Call `scm_i_struct_hash' upon
      `scm_tcs_struct'.
    * libguile/struct.c (scm_i_struct_hash): New function.
    * libguile/struct.h (scm_i_struct_hash): New declaration.
    
    * test-suite/tests/structs.test ("hash"): New test prefix.

-----------------------------------------------------------------------

Summary of changes:
 libguile/hash.c               |    7 ++++-
 libguile/struct.c             |   49 +++++++++++++++++++++++++++++++++++++++++
 libguile/struct.h             |    2 +
 module/web/client.scm         |   47 +++++++++++++++++++++++++++-----------
 test-suite/tests/structs.test |   42 +++++++++++++++++++++++++++++++++++
 5 files changed, 131 insertions(+), 16 deletions(-)

diff --git a/libguile/hash.c b/libguile/hash.c
index a79f03d..8b00a0c 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,5 +1,6 @@
-/*     Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009, 
2010, 2011 Free Software Foundation, Inc.
- * 
+/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
+ *   2009, 2010, 2011, 2012 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
  * as published by the Free Software Foundation; either version 3 of
@@ -223,6 +224,8 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
        significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
        return (size_t) significant_bits  % n;
       }
+    case scm_tcs_struct:
+      return scm_i_struct_hash (obj, n, d);
     case scm_tc7_wvect:
     case scm_tc7_vector:
       {
diff --git a/libguile/struct.c b/libguile/struct.c
index 5837b7c..db1687e 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -922,6 +922,55 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
   return SCM_UNPACK (obj) % n;
 }
 
+/* Return the hash of struct OBJ, modulo N.  Traverse OBJ's fields to
+   compute the result, unless DEPTH is zero.  */
+unsigned long
+scm_i_struct_hash (SCM obj, unsigned long n, size_t depth)
+#define FUNC_NAME "hash"
+{
+  SCM layout;
+  scm_t_bits *data;
+  size_t struct_size, field_num;
+  unsigned long hash;
+
+  SCM_VALIDATE_STRUCT (1, obj);
+
+  layout = SCM_STRUCT_LAYOUT (obj);
+  struct_size = scm_i_symbol_length (layout) / 2;
+  data = SCM_STRUCT_DATA (obj);
+
+  hash = SCM_UNPACK (SCM_STRUCT_VTABLE (obj)) % n;
+  if (depth > 0)
+    for (field_num = 0; field_num < struct_size; field_num++)
+      {
+       int protection;
+
+       protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
+       if (protection != 'h' && protection != 'o')
+         {
+           int type;
+           type = scm_i_symbol_ref (layout, field_num * 2);
+           switch (type)
+             {
+             case 'p':
+               hash ^= scm_hasher (SCM_PACK (data[field_num]), n,
+                                   depth / 2);
+               break;
+             case 'u':
+               hash ^= data[field_num] % n;
+               break;
+             default:
+               /* Ignore 's' fields.  */;
+             }
+         }
+      }
+
+  /* FIXME: Tail elements should be taken into account.  */
+
+  return hash % n;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, 
             (SCM vtable),
            "Return the name of the vtable @var{vtable}.")
diff --git a/libguile/struct.h b/libguile/struct.h
index 3072f24..643fd9d 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -193,6 +193,8 @@ SCM_API void scm_print_struct (SCM exp, SCM port, 
scm_print_state *);
 
 SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
 SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
+SCM_INTERNAL unsigned long scm_i_struct_hash (SCM s, unsigned long n,
+                                             size_t depth);
 SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
 SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
 SCM_INTERNAL void scm_init_struct (void);
diff --git a/module/web/client.scm b/module/web/client.scm
index b035668..27458a4 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -1,6 +1,6 @@
 ;;; Web client
 
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 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
@@ -42,19 +42,38 @@
             http-get))
 
 (define (open-socket-for-uri uri)
-  (let* ((ai (car (getaddrinfo (uri-host uri)
-                               (cond
-                                ((uri-port uri) => number->string)
-                                (else (symbol->string (uri-scheme uri)))))))
-         (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
-                     (addrinfo:protocol ai))))
-    (set-port-encoding! s "ISO-8859-1")
-    (connect s (addrinfo:addr ai))
-    ;; Buffer input and output on this port.
-    (setvbuf s _IOFBF)
-    ;; Enlarge the receive buffer.
-    (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
-    s))
+  "Return an open input/output port for a connection to URI."
+  (define addresses
+    (let ((port (uri-port uri)))
+      (getaddrinfo (uri-host uri)
+                   (cond (port => number->string)
+                         (else (symbol->string (uri-scheme uri))))
+                   (if port
+                       AI_NUMERICSERV
+                       0))))
+
+  (let loop ((addresses addresses))
+    (let* ((ai (car addresses))
+           (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                       (addrinfo:protocol ai))))
+      (set-port-encoding! s "ISO-8859-1")
+
+      (catch 'system-error
+        (lambda ()
+          (connect s (addrinfo:addr ai))
+
+          ;; Buffer input and output on this port.
+          (setvbuf s _IOFBF)
+          ;; Enlarge the receive buffer.
+          (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+          s)
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (if (null? addresses)
+              (apply throw args)
+              (begin
+                (close s)
+                (loop (cdr addresses)))))))))
 
 (define (decode-string bv encoding)
   (if (string-ci=? encoding "utf-8")
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 431a014..0e3b241 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -126,7 +126,49 @@
      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
              (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 
+
+(with-test-prefix "hash"
+
+  (pass-if "simple structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "hello")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "different structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "world")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
+
+  (pass-if "different struct types"
+    (let* ((v1 (make-vtable "pr"))
+           (v2 (make-vtable "pr"))
+           (s1 (make-struct v1 0 "hello"))
+           (s2 (make-struct v2 0 "hello")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
 
+  (pass-if "more complex structs"
+    (let ((s1 (make-ball red (string-copy "Bob")))
+          (s2 (make-ball red (string-copy "Bob"))))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "struct with weird fields"
+    (let* ((v  (make-vtable "prurph"))
+           (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
+           (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "cyclic structs"
+    (let* ((v (make-vtable "pw"))
+           (a (make-struct v 0 #f))
+           (b (make-struct v 0 a)))
+      (struct-set! a 0 b)
+      (and (hash a 7777) (hash b 7777) #t))))
+
+
 ;;
 ;; make-struct
 ;;


hooks/post-receive
-- 
GNU Guile