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 |
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; |
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 |
{ |
{ |
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 |
} |
} |
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); |
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}.") |
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 |
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. */ |
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, |
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), |
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); |
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>", |