diff options
author | Andy Wingo <wingo@pobox.com> | 2011-10-27 13:45:04 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-10-27 13:45:04 +0200 |
commit | 4938d3cb742de2a356586c55e5af32e193c5990b (patch) | |
tree | b4bfe0fd26e102c5fa38ca9965bc4ebdbae8e3b4 /libguile/goops.c | |
parent | 9d013330154852bc2309947adaa30b32418642c0 (diff) | |
parent | 2be3feb17e5456bba71749e0e97adf45c32c4e0e (diff) | |
download | guile-4938d3cb742de2a356586c55e5af32e193c5990b.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
libguile/deprecated.c
libguile/gc-malloc.c
module/language/tree-il/peval.scm
Diffstat (limited to 'libguile/goops.c')
-rw-r--r-- | libguile/goops.c | 71 |
1 files changed, 61 insertions, 10 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index cefc03bb5..3c82d6d55 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -360,7 +360,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); @@ -374,7 +374,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))) @@ -409,7 +409,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); @@ -424,15 +424,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); @@ -444,8 +492,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; @@ -869,7 +920,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 */ |