/[guile]/guile/guile-core/libguile/goops.c
ViewVC logotype

Diff of /guile/guile-core/libguile/goops.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.54 by mvo, Sun Nov 3 22:05:09 2002 UTC revision 1.55 by mdj, Wed Jan 8 13:24:36 2003 UTC
# Line 1  Line 1 
1  /* Copyright (C) 1998,1999,2000,2001, 2002 Free Software Foundation, Inc.  /* Copyright (C) 1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
2   *   *
3   * This program is free software; you can redistribute it and/or modify   * This program is free software; you can redistribute it and/or modify
4   * it under the terms of the GNU General Public License as published by   * it under the terms of the GNU General Public License as published by
# Line 137  static SCM scm_goops_lookup_closure; Line 137  static SCM scm_goops_lookup_closure;
137  /* Some classes are defined in libguile/objects.c. */  /* Some classes are defined in libguile/objects.c. */
138  SCM scm_class_top, scm_class_object, scm_class_class;  SCM scm_class_top, scm_class_object, scm_class_class;
139  SCM scm_class_entity, scm_class_entity_with_setter;  SCM scm_class_entity, scm_class_entity_with_setter;
140  SCM scm_class_generic, scm_class_generic_with_setter, scm_class_method;  SCM scm_class_generic, scm_class_generic_with_setter;
141    SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
142    SCM scm_class_method;
143  SCM scm_class_simple_method, scm_class_accessor;  SCM scm_class_simple_method, scm_class_accessor;
144  SCM scm_class_procedure_class;  SCM scm_class_procedure_class;
145  SCM scm_class_operator_class, scm_class_operator_with_setter_class;  SCM scm_class_operator_class, scm_class_operator_with_setter_class;
# Line 166  static SCM scm_sys_goops_loaded (void); Line 168  static SCM scm_sys_goops_loaded (void);
168   *   *
169   * Compute-cpl   * Compute-cpl
170   *   *
171   *   This version doesn't handle multiple-inheritance. It serves only for   *   This version doesn't fully handle multiple-inheritance. It serves
172   * booting classes and will be overloaded in Scheme   *   only for booting classes and will be overloaded in Scheme
173   *   *
174   ******************************************************************************/   ******************************************************************************/
175    
 #if 0  
 static SCM  
 compute_cpl (SCM supers, SCM res)  
 {  
   return (SCM_NULLP (supers)  
           ? scm_reverse (res)  
           : compute_cpl (SCM_SLOT (SCM_CAR (supers), scm_si_direct_supers),  
                          scm_cons (SCM_CAR (supers), res)));  
 }  
 #endif  
   
176  static SCM  static SCM
177  map (SCM (*proc) (SCM), SCM ls)  map (SCM (*proc) (SCM), SCM ls)
178  {  {
# Line 325  compute_getters_n_setters (SCM slots) Line 316  compute_getters_n_setters (SCM slots)
316          {          {
317            init = scm_get_keyword (k_init_value, options, 0);            init = scm_get_keyword (k_init_value, options, 0);
318            if (init)            if (init)
319              init = scm_closure (scm_list_2 (SCM_EOL, init), SCM_EOL);              init = scm_closure (scm_list_2 (SCM_EOL,
320                                                scm_list_2 (scm_sym_quote, init)),
321                                    SCM_EOL);
322            else            else
323              init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);              init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
324          }          }
# Line 620  scm_basic_basic_make_class (SCM class, S Line 613  scm_basic_basic_make_class (SCM class, S
613    z = scm_make_struct (class, SCM_INUM0, SCM_EOL);    z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
614    
615    /* Initialize its slots */    /* Initialize its slots */
 #if 0  
   cpl   = compute_cpl (dsupers, scm_list_1 (z));  
 #endif  
616    SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);    SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
617    cpl   = compute_cpl (z);    cpl   = compute_cpl (z);
618    slots = build_slots_list (maplist (dslots), cpl);    slots = build_slots_list (maplist (dslots), cpl);
# Line 900  SCM_DEFINE (scm_generic_function_name, " Line 890  SCM_DEFINE (scm_generic_function_name, "
890  }  }
891  #undef FUNC_NAME  #undef FUNC_NAME
892    
893    SCM_SYMBOL (sym_methods, "methods");
894    SCM_SYMBOL (sym_extended_by, "extended-by");
895    SCM_SYMBOL (sym_extends, "extends");
896    
897    static
898    SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
899    {
900      SCM gfs = scm_slot_ref (gf, sym_extended_by);
901      method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
902      while (!SCM_NULLP (gfs))
903        {
904          method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
905          gfs = SCM_CDR (gfs);
906        }
907      return method_lists;
908    }
909    
910    static
911    SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
912    {
913      if (SCM_IS_A_P (gf, scm_class_extended_generic))
914        {
915          SCM gfs = scm_slot_ref (gf, sym_extends);
916          while (!SCM_NULLP (gfs))
917            {
918              SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
919              method_lists = fold_upward_gf_methods (scm_cons (methods,
920                                                               method_lists),
921                                                     SCM_CAR (gfs));
922              gfs = SCM_CDR (gfs);
923            }
924        }
925      return method_lists;
926    }
927    
928  SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,  SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
929              (SCM obj),              (SCM obj),
930              "Return the methods of the generic function @var{obj}.")              "Return the methods of the generic function @var{obj}.")
931  #define FUNC_NAME s_scm_generic_function_methods  #define FUNC_NAME s_scm_generic_function_methods
932  {  {
933      SCM methods;
934    SCM_VALIDATE_GENERIC (1, obj);    SCM_VALIDATE_GENERIC (1, obj);
935    return scm_slot_ref (obj, scm_str2symbol ("methods"));    methods = fold_upward_gf_methods (SCM_EOL, obj);
936      methods = fold_downward_gf_methods (methods, obj);
937      return scm_append (methods);
938  }  }
939  #undef FUNC_NAME  #undef FUNC_NAME
940    
   
941  SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,  SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
942              (SCM obj),              (SCM obj),
943              "Return the generic function for the method @var{obj}.")              "Return the generic function for the method @var{obj}.")
# Line 1757  sort_applicable_methods (SCM method_list Line 1784  sort_applicable_methods (SCM method_list
1784          We're not allocating elements in this routine, so this should          We're not allocating elements in this routine, so this should
1785          pose no problem.          pose no problem.
1786        */        */
1787        v      = SCM_WRITABLE_VELTS (vector);        v = SCM_WRITABLE_VELTS (vector);
1788      }      }
1789    
1790    /* Use a simple shell sort since it is generally faster than qsort on    /* Use a simple shell sort since it is generally faster than qsort on
# Line 1829  scm_compute_applicable_methods (SCM gf, Line 1856  scm_compute_applicable_methods (SCM gf,
1856      *p++ = scm_class_of (SCM_CAR (args));      *p++ = scm_class_of (SCM_CAR (args));
1857        
1858    /* Build a list of all applicable methods */    /* Build a list of all applicable methods */
1859    for (l = SCM_SLOT (gf, scm_si_methods); !SCM_NULLP (l); l = SCM_CDR (l))    for (l = scm_generic_function_methods (gf); !SCM_NULLP (l); l = SCM_CDR (l))
1860      {      {
1861        fl = SPEC_OF (SCM_CAR (l));        fl = SPEC_OF (SCM_CAR (l));
1862        /* Only accept accessors which match exactly in first arg. */        /* Only accept accessors which match exactly in first arg. */
# Line 2022  SCM_DEFINE (scm_make, "make",  0, 0, 1, Line 2049  SCM_DEFINE (scm_make, "make",  0, 0, 1,
2049    if (class == scm_class_generic || class == scm_class_generic_with_setter)    if (class == scm_class_generic || class == scm_class_generic_with_setter)
2050      {      {
2051        z = scm_make_struct (class, SCM_INUM0,        z = scm_make_struct (class, SCM_INUM0,
2052                             scm_list_4 (SCM_EOL,                             scm_list_5 (SCM_EOL,
2053                                         SCM_INUM0,                                         SCM_INUM0,
2054                                         SCM_BOOL_F,                                         SCM_BOOL_F,
2055                                         scm_make_mutex ()));                                         scm_make_mutex (),
2056                                           SCM_EOL));
2057        scm_set_procedure_property_x (z, scm_sym_name,        scm_set_procedure_property_x (z, scm_sym_name,
2058                                      scm_get_keyword (k_name,                                      scm_get_keyword (k_name,
2059                                                       args,                                                       args,
# Line 2174  create_standard_classes (void) Line 2202  create_standard_classes (void)
2202                                                k_init_keyword,                                                k_init_keyword,
2203                                                k_slot_definition));                                                k_slot_definition));
2204    SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));    SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex"));
2205    SCM gf_slots = scm_list_4 (scm_str2symbol ("methods"),    SCM gf_slots = scm_list_5 (scm_str2symbol ("methods"),
2206                               scm_list_3 (scm_str2symbol ("n-specialized"),                               scm_list_3 (scm_str2symbol ("n-specialized"),
2207                                           k_init_value,                                           k_init_value,
2208                                           SCM_INUM0),                                           SCM_INUM0),
# Line 2185  create_standard_classes (void) Line 2213  create_standard_classes (void)
2213                                           k_init_thunk,                                           k_init_thunk,
2214                                           scm_closure (scm_list_2 (SCM_EOL,                                           scm_closure (scm_list_2 (SCM_EOL,
2215                                                                    mutex_slot),                                                                    mutex_slot),
2216                                                        SCM_EOL)));                                                        SCM_EOL)),
2217                                 scm_list_3 (scm_str2symbol ("extended-by"),
2218                                             k_init_value,
2219                                             SCM_EOL));
2220      SCM egf_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("extends"),
2221                                              k_init_value,
2222                                              SCM_EOL));
2223    /* Foreign class slot classes */    /* Foreign class slot classes */
2224    make_stdcls (&scm_class_foreign_slot,    "<foreign-slot>",    make_stdcls (&scm_class_foreign_slot,    "<foreign-slot>",
2225                 scm_class_class, scm_class_top,             SCM_EOL);                 scm_class_class, scm_class_top,             SCM_EOL);
# Line 2262  create_standard_classes (void) Line 2295  create_standard_classes (void)
2295    make_stdcls (&scm_class_generic,         "<generic>",    make_stdcls (&scm_class_generic,         "<generic>",
2296                 scm_class_entity_class, scm_class_entity,   gf_slots);                 scm_class_entity_class, scm_class_entity,   gf_slots);
2297    SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);    SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
2298      make_stdcls (&scm_class_extended_generic, "<extended-generic>",
2299                   scm_class_entity_class,
2300                   scm_list_1 (scm_class_generic),
2301                   egf_slots);
2302      SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
2303    make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",    make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
2304                 scm_class_entity_class,                 scm_class_entity_class,
2305                 scm_list_2 (scm_class_generic, scm_class_entity_with_setter),                 scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
2306                 SCM_EOL);                 SCM_EOL);
 #if 0  
   /* Patch cpl since compute_cpl doesn't support multiple inheritance. */  
   SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl,  
     scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter,  
                                         scm_class_generic),  
                             SCM_SLOT (scm_class_entity_with_setter,  
                                       scm_si_cpl),  
                             SCM_EOL)));  
 #endif  
2307    SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);    SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
2308      make_stdcls (&scm_class_extended_generic_with_setter,
2309                   "<extended-generic-with-setter>",
2310                   scm_class_entity_class,
2311                   scm_list_2 (scm_class_extended_generic,
2312                               scm_class_entity_with_setter),
2313                   SCM_EOL);
2314      SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
2315                           SCM_CLASSF_PURE_GENERIC);
2316    
2317    /* Primitive types classes */    /* Primitive types classes */
2318    make_stdcls (&scm_class_boolean,         "<boolean>",    make_stdcls (&scm_class_boolean,         "<boolean>",

Legend:
Removed from v.1.54  
changed lines
  Added in v.1.55

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26