[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-46-g9a9e0d6

[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=9a9e0d6d5e70ecf959bcedf6e172e569c5339d17

The branch, master has been updated
       via  9a9e0d6d5e70ecf959bcedf6e172e569c5339d17 (commit)
       via  5565279a67f9c0da5888273c5904b1b69d021522 (commit)
       via  288bbc44cf6f3839331a03649933f25d2361e06f (commit)
      from  9a8eb5fb4641bd9ea83903624c8c71192fe0d0f6 (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 9a9e0d6d5e70ecf959bcedf6e172e569c5339d17
Author: Julian Graham <address@hidden>
Date:   Sun Oct 25 13:00:08 2009 -0400

    Resolve warning in gcc-4.3 about transposed parameters passed to memset
    
    * libguile/gc-malloc.c (scm_gc_calloc): Add explicit check on size parameter
    
    Signed-off-by: Ludovic Courtès <address@hidden>

commit 5565279a67f9c0da5888273c5904b1b69d021522
Author: Ludovic Courtès <address@hidden>
Date:   Sun Oct 25 22:57:29 2009 +0100

    SRFI-35: Provide nice vtable names, to make GOOPS happier.
    
    * module/srfi/srfi-35.scm (%make-condition-type): New procedure.
      (make-condition-type, make-compound-condition-type): Use it.
    
    * test-suite/tests/srfi-35.test ("condition
      types")["struct-vtable-name"]: New test.

commit 288bbc44cf6f3839331a03649933f25d2361e06f
Author: Ludovic Courtès <address@hidden>
Date:   Sun Oct 25 22:49:28 2009 +0100

    Fix GOOPS `class-of' for nameless structs.
    
    * libguile/goops.c (scm_class_of): Fix second argument for
      `scm_make_extended_class_from_symbol ()' for nameless structs.
    
    * test-suite/tests/goops.test ("classes for built-in types")["struct
      vtable"]: New test case.

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

Summary of changes:
 libguile/gc-malloc.c          |    3 ++-
 libguile/goops.c              |   14 +++++++++-----
 module/srfi/srfi-35.scm       |   30 +++++++++++++++++++-----------
 test-suite/tests/goops.test   |    7 ++++++-
 test-suite/tests/srfi-35.test |    8 ++++++--
 5 files changed, 42 insertions(+), 20 deletions(-)

diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index a96a186..0e60eba 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -206,7 +206,8 @@ void *
 scm_gc_calloc (size_t size, const char *what)
 {
   void *ptr = scm_gc_malloc (size, what);
-  memset (ptr, 0x0, size);
+  if (size)
+    memset (ptr, 0x0, size);
   return ptr;
 }
 
diff --git a/libguile/goops.c b/libguile/goops.c
index 9848e43..24a823f 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -282,11 +282,15 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
                return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
              else
                {
-                 SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
-                 SCM class = scm_make_extended_class_from_symbol (scm_is_true 
(name)
-                                                      ? name
-                                                      : scm_nullstr,
-                                                      SCM_I_OPERATORP (x));
+                 SCM class, name;
+
+                 name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+                 if (!scm_is_symbol (name))
+                   name = scm_string_to_symbol (scm_nullstr);
+
+                 class =
+                   scm_make_extended_class_from_symbol (name,
+                                                        SCM_I_OPERATORP (x));
                  SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
                  return class;
                }
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 1d496fc..12aa83a 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -57,6 +57,19 @@
                                    (number->string (object-address ct)
                                                    16))))))
 
+(define (%make-condition-type layout id parent all-fields)
+  (let ((struct (make-struct %condition-type-vtable 0
+                             (make-struct-layout layout) ;; layout
+                             print-condition             ;; printer
+                             id parent all-fields)))
+
+    ;; Hack to associate STRUCT with a name, providing a better name for
+    ;; GOOPS classes as returned by `class-of' et al.
+    (set-struct-vtable-name! struct (cond ((symbol? id) id)
+                                          ((string? id) (string->symbol id))
+                                          (else         (string->symbol ""))))
+    struct))
+
 (define (condition-type? obj)
   "Return true if OBJ is a condition type."
   (and (struct? obj)
@@ -104,10 +117,8 @@ supertypes."
                                               field-names parent-fields)))
                (let* ((all-fields (append parent-fields field-names))
                       (layout     (struct-layout-for-condition all-fields)))
-                 (make-struct %condition-type-vtable 0
-                              (make-struct-layout layout) ;; layout
-                              print-condition             ;; printer
-                              id parent all-fields))
+                 (%make-condition-type layout
+                                        id parent all-fields))
                (error "invalid condition type field names"
                       field-names)))
          (error "parent is not a condition type" parent))
@@ -126,13 +137,10 @@ supertypes."
          (let* ((all-fields (append-map condition-type-all-fields
                                         parents))
                 (layout     (struct-layout-for-condition all-fields)))
-           (make-struct %condition-type-vtable 0
-                        (make-struct-layout layout) ;; layout
-                        print-condition             ;; printer
-                        id
-                        parents                     ;; list of parents!
-                        all-fields
-                        all-fields)))))
+           (%make-condition-type layout
+                                 id
+                                 parents         ;; list of parents!
+                                 all-fields)))))
 
 
 ;;;
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index c060d12..c7a03d6 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -139,7 +139,12 @@
     (eq? (class-of "foo") <string>))
 
   (pass-if "port"
-    (is-a? (%make-void-port "w") <port>)))
+    (is-a? (%make-void-port "w") <port>))
+
+  (pass-if "struct vtable"
+    ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+    ;; for which `struct-vtable-name' is #f.
+    (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
 
 
 (with-test-prefix "defining classes"
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 24ee602..849d1de 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
 ;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
 ;;;; Ludovic Courtès <address@hidden>
 ;;;;
-;;;;   Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2007, 2008, 2009 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
@@ -33,7 +33,11 @@
     (condition-type? &condition))
 
   (pass-if "make-condition-type"
-    (condition-type? (make-condition-type 'foo &condition '(a b)))))
+    (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+  (pass-if "struct-vtable-name"
+    (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
+      (eq? 'chbouib (struct-vtable-name ct)))))
 
 
 


hooks/post-receive
-- 
GNU Guile