[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-176-g13d807b

[Andy Wingo]

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=13d807b7d36594676c5aa683c595eca8dbe26b57

The branch, stable-2.0 has been updated
       via  13d807b7d36594676c5aa683c595eca8dbe26b57 (commit)
      from  aa9c19858872a135ea959066fff26f86527a1bd0 (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 13d807b7d36594676c5aa683c595eca8dbe26b57
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 21 00:22:44 2011 +0200

    fix segfault in goops if class fields are redefined
    
    * libguile/goops.c (map, filter_cpl, remove_duplicate_slots): Use
      scm_is_pair instead of !scm_is_null, given that we use accessor
      macros.
      (check_cpl, build_slots_list): Check that descendents of <class> can't
      redefine slots of <class>.
    
    * test-suite/tests/goops.test ("defining classes"): Add a test.
    
    Patch originally by Stefan Israelsson Tampe.

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

Summary of changes:
 libguile/goops.c            |   71 +++++++++++++++++++++++++++++++++++++------
 test-suite/tests/goops.test |   11 +++++-
 2 files changed, 70 insertions(+), 12 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index c2eb88f..31fa179 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -373,7 +373,7 @@ map (SCM (*proc) (SCM), SCM ls)
       SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
       SCM h = res;
       ls = SCM_CDR (ls);
-      while (!scm_is_null (ls))
+      while (scm_is_pair (ls))
        {
          SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
          h = SCM_CDR (h);
@@ -387,7 +387,7 @@ static SCM
 filter_cpl (SCM ls)
 {
   SCM res = SCM_EOL;
-  while (!scm_is_null (ls))
+  while (scm_is_pair (ls))
     {
       SCM el = SCM_CAR (ls);
       if (scm_is_false (scm_c_memq (el, res)))
@@ -422,7 +422,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM 
slots_already_seen)
 {
   SCM tmp;
 
-  if (scm_is_null (l))
+  if (!scm_is_pair (l))
     return res;
 
   tmp = SCM_CAAR (l);
@@ -437,15 +437,63 @@ remove_duplicate_slots (SCM l, SCM res, SCM 
slots_already_seen)
   return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
 }
 
+static void 
+check_cpl (SCM slots, SCM bslots)
+{
+  for (; scm_is_pair (bslots); bslots = SCM_CDR (bslots))
+    if (scm_is_true (scm_assq (SCM_CAAR (bslots), slots)))
+      scm_misc_error ("init-object", "a predefined <class> inherited "
+                      "field cannot be redefined", SCM_EOL);  
+}
+
+static SCM 
+build_class_class_slots (void);
+
 static SCM
 build_slots_list (SCM dslots, SCM cpl)
 {
-  register SCM res = dslots;
+  SCM bslots, class_slots;
+  int classp;
+  SCM res = dslots;
+
+  class_slots = SCM_EOL;  
+  classp = scm_is_true (scm_memq (scm_class_class, cpl));
+  
+  if (classp) 
+    {
+      bslots = build_class_class_slots ();
+      check_cpl (res, bslots);
+    }
+  else
+    bslots = SCM_EOL;
+
+  if (scm_is_pair (cpl))
+    {      
+      for (cpl = SCM_CDR (cpl); scm_is_pair (cpl); cpl = SCM_CDR (cpl))
+        {
+          SCM new_slots = SCM_SLOT (SCM_CAR (cpl),
+                                    scm_si_direct_slots);
+          if (classp)
+            {
+              if (!scm_is_eq (SCM_CAR (cpl), scm_class_class))
+                check_cpl (new_slots, bslots);
+              else
+                {
+                  /* Move class slots to the head of the list. */
+                  class_slots = new_slots;
+                  continue;
+                }
+            }   
+          res = scm_append (scm_list_2 (new_slots, res));
+        }
+    }
+  else
+    scm_misc_error ("%compute-slots", "malformed cpl argument in "
+                    "build_slots_list", SCM_EOL);
 
-  for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
-    res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
-                                           scm_si_direct_slots),
-                                 res));
+  /* make sure to add the <class> slots to the head of the list */
+  if (classp)
+    res = scm_append (scm_list_2 (class_slots, res));
 
   /* res contains a list of slots. Remove slots which appears more than once */
   return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
@@ -457,8 +505,11 @@ maplist (SCM ls)
   SCM orig = ls;
   while (!scm_is_null (ls))
     {
+      if (!scm_is_pair (ls))
+        scm_misc_error ("%compute-slots", "malformed ls argument in "
+                        "maplist", SCM_EOL);
       if (!scm_is_pair (SCM_CAR (ls)))
-       SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
+        SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
       ls = SCM_CDR (ls);
     }
   return orig;
@@ -882,7 +933,7 @@ SCM_SYMBOL (sym_nfields, "nfields");
 
 
 static SCM
-build_class_class_slots ()
+build_class_class_slots (void)
 {
   /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
      SCM_CLASS_CLASS_LAYOUT */
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 2bf7d69..b864b24 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -206,8 +206,15 @@
                        (x #:accessor x #:init-value 123)
                        (z #:accessor z #:init-value 789))
                     (current-module))
-              (eval '(equal? (x (make <qux>)) 123) (current-module)))))
-     
+              (eval '(equal? (x (make <qux>)) 123) (current-module)))
+
+     (pass-if-exception "cannot redefine fields of <class>"
+       '(misc-error . "cannot be redefined")
+       (eval '(begin
+                (define-class <test-class> (<class>) 
+                  name) 
+                (make <test-class>))
+             (current-module)))))
 
 (with-test-prefix "defining generics"
 


hooks/post-receive
-- 
GNU Guile