diff options
Diffstat (limited to 'libguile/goops.c')
| -rw-r--r-- | libguile/goops.c | 230 |
1 files changed, 160 insertions, 70 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index bbeb58433..4616fa240 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2,18 +2,19 @@ * 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 - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ @@ -59,24 +60,32 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) -#define DEFVAR(v, val) \ -{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ - scm_module_goops); } -/* Temporary hack until we get the new module system */ -/*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ - (v), SCM_BOOL_F))) - -/* Fixme: Should use already interned symbols */ - -#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \ - a)) -#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \ - a, b)) -#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \ - a, b, c)) -#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \ - a, b, c, d)) +/* this file is a mess. in theory, though, we shouldn't have many SCM references + -- most of the references should be to vars. */ + +static SCM var_slot_unbound = SCM_BOOL_F; +static SCM var_slot_missing = SCM_BOOL_F; +static SCM var_compute_cpl = SCM_BOOL_F; +static SCM var_no_applicable_method = SCM_BOOL_F; +static SCM var_memoize_method_x = SCM_BOOL_F; +static SCM var_change_class = SCM_BOOL_F; + +SCM_SYMBOL (sym_slot_unbound, "slot-unbound"); +SCM_SYMBOL (sym_slot_missing, "slot-missing"); +SCM_SYMBOL (sym_compute_cpl, "compute-cpl"); +SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method"); +SCM_SYMBOL (sym_memoize_method_x, "memoize-method!"); +SCM_SYMBOL (sym_change_class, "change-class"); + +SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); + + +/* FIXME, exports should come from the scm file only */ +#define DEFVAR(v, val) \ + { scm_module_define (scm_module_goops, (v), (val)); \ + scm_module_export (scm_module_goops, scm_list_1 ((v))); \ + } + /* Class redefinition protocol: @@ -119,8 +128,6 @@ static int goops_loaded_p = 0; static scm_t_rstate *goops_rstate; -static SCM scm_goops_lookup_closure; - /* These variables are filled in by the object system when loaded. */ SCM scm_class_boolean, scm_class_char, scm_class_pair; SCM scm_class_procedure, scm_class_string, scm_class_symbol; @@ -169,6 +176,8 @@ static SCM scm_unbound_p (SCM obj); static SCM scm_assert_bound (SCM value, SCM obj); static SCM scm_at_assert_bound_ref (SCM obj, SCM index); static SCM scm_sys_goops_loaded (void); +static SCM scm_make_extended_class_from_symbol (SCM type_name_sym, + int applicablep); /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, @@ -234,6 +243,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, else return scm_class_procedure; case scm_tc7_gsubr: + case scm_tc7_program: return scm_class_procedure; case scm_tc7_pws: return scm_class_procedure_with_setter; @@ -273,9 +283,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, else { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); - SCM class = scm_make_extended_class (scm_is_true (name) - ? scm_i_symbol_chars (name) - : 0, + SCM class = scm_make_extended_class_from_symbol (scm_is_true (name) + ? name + : scm_nullstr, SCM_I_OPERATORP (x)); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); return class; @@ -346,7 +356,7 @@ static SCM compute_cpl (SCM class) { if (goops_loaded_p) - return CALL_GF1 ("compute-cpl", class); + return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class); else { SCM supers = SCM_SLOT (class, scm_si_direct_supers); @@ -588,13 +598,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); if (SCM_GOOPS_UNBOUNDP (slot_value)) - { - SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp)); - set_slot_value (class, - obj, - SCM_CAR (get_n_set), - scm_eval_body (SCM_CLOSURE_BODY (tmp), env)); - } + set_slot_value (class, + obj, + SCM_CAR (get_n_set), + scm_call_0 (tmp)); } } } @@ -1195,7 +1202,7 @@ SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0, #define FUNC_NAME s_scm_assert_bound { if (SCM_GOOPS_UNBOUNDP (value)) - return CALL_GF1 ("slot-unbound", obj); + return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj); return value; } #undef FUNC_NAME @@ -1208,7 +1215,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, { SCM value = SCM_SLOT (obj, scm_to_int (index)); if (SCM_GOOPS_UNBOUNDP (value)) - return CALL_GF1 ("slot-unbound", obj); + return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj); return value; } #undef FUNC_NAME @@ -1250,10 +1257,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0, #undef FUNC_NAME -SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref); -SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x); - - + /** Utilities **/ /* In the future, this function will return the effective slot @@ -1296,7 +1300,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) code = SCM_CAR (access); if (!SCM_CLOSUREP (code)) - return SCM_SUBRF (code) (obj); + return scm_call_1 (code, obj); env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), scm_list_1 (obj), SCM_ENV (code)); @@ -1313,7 +1317,7 @@ get_slot_value_using_name (SCM class, SCM obj, SCM slot_name) if (scm_is_true (slotdef)) return get_slot_value (class, obj, slotdef); else - return CALL_GF3 ("slot-missing", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name); } static SCM @@ -1339,7 +1343,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) code = SCM_CADR (access); if (!SCM_CLOSUREP (code)) - SCM_SUBRF (code) (obj, value); + scm_call_2 (code, obj, value); else { env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), @@ -1360,7 +1364,7 @@ set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value) if (scm_is_true (slotdef)) return set_slot_value (class, obj, slotdef, value); else - return CALL_GF4 ("slot-missing", class, obj, slot_name, value); + return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value); } static SCM @@ -1390,7 +1394,7 @@ SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) - return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name); return res; } #undef FUNC_NAME @@ -1453,7 +1457,7 @@ SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0, res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) - return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name); return res; } #undef FUNC_NAME @@ -1522,11 +1526,11 @@ wrap_init (SCM class, SCM *m, long n) { long i; scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout]; - const char *layout = scm_i_symbol_chars (SCM_PACK (slayout)); + SCM layout = SCM_PACK (slayout); /* Set all SCM-holding slots to unbound */ for (i = 0; i < n; i++) - if (layout[i*2] == 'p') + if (scm_i_symbol_ref (layout, i*2) == 'p') m[i] = SCM_GOOPS_UNBOUND; else m[i] = 0; @@ -1742,7 +1746,7 @@ SCM_SYMBOL (scm_sym_change_class, "change-class"); static SCM purgatory (void *args) { - return scm_apply_0 (GETVAR (scm_sym_change_class), + return scm_apply_0 (SCM_VARIABLE_REF (var_change_class), SCM_PACK ((scm_t_bits) args)); } @@ -1856,7 +1860,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 *SCM_SUBR_GENERIC (subr) = scm_make (scm_list_3 (scm_class_generic, k_name, - SCM_SNAME (subr))); + SCM_SUBR_NAME (subr))); subrs = SCM_CDR (subrs); } return SCM_UNSPECIFIED; @@ -1904,7 +1908,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension) gf = *SCM_SUBR_GENERIC (extended); gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), gf, - SCM_SNAME (extension)); + SCM_SUBR_NAME (extension)); SCM_SET_SUBR_GENERIC (extension, gext); } else @@ -2143,7 +2147,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) { if (find_method_p) return SCM_BOOL_F; - CALL_GF2 ("no-applicable-method", gf, save); + scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save); /* if we are here, it's because no-applicable-method hasn't signaled an error */ return SCM_BOOL_F; } @@ -2200,8 +2204,13 @@ call_memoize_method (void *a) SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args)); if (scm_is_true (cmethod)) return cmethod; - /*fixme* Use scm_apply */ - return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x); + + if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x))) + var_memoize_method_x = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_memoize_method_x)); + + return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x); } SCM @@ -2229,6 +2238,9 @@ scm_memoize_method (SCM x, SCM args) SCM_KEYWORD (k_setter, "setter"); SCM_KEYWORD (k_specializers, "specializers"); SCM_KEYWORD (k_procedure, "procedure"); +SCM_KEYWORD (k_formals, "formals"); +SCM_KEYWORD (k_body, "body"); +SCM_KEYWORD (k_make_procedure, "make-procedure"); SCM_KEYWORD (k_dsupers, "dsupers"); SCM_KEYWORD (k_slots, "slots"); SCM_KEYWORD (k_gf, "generic-function"); @@ -2292,9 +2304,27 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, scm_i_get_keyword (k_procedure, args, len - 1, - SCM_EOL, + SCM_BOOL_F, FUNC_NAME)); SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL); + SCM_SET_SLOT (z, scm_si_formals, + scm_i_get_keyword (k_formals, + args, + len - 1, + SCM_EOL, + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_body, + scm_i_get_keyword (k_body, + args, + len - 1, + SCM_EOL, + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_make_procedure, + scm_i_get_keyword (k_make_procedure, + args, + len - 1, + SCM_BOOL_F, + FUNC_NAME)); } else { @@ -2434,10 +2464,14 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"), + SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"), scm_from_locale_symbol ("specializers"), sym_procedure, - scm_from_locale_symbol ("code-table")); + scm_from_locale_symbol ("code-table"), + scm_from_locale_symbol ("formals"), + scm_from_locale_symbol ("body"), + scm_from_locale_symbol ("make-procedure"), + SCM_UNDEFINED); SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"), k_init_keyword, k_slot_definition)); @@ -2646,7 +2680,35 @@ make_class_from_template (char const *template, char const *type_name, SCM super /* Only define name if doesn't already exist. */ if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F))) + && scm_is_false (scm_module_variable (scm_module_goops, name))) + DEFVAR (name, class); + return class; +} + +static SCM +make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) +{ + SCM class, name; + if (type_name_sym != SCM_BOOL_F) + { + name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), + scm_symbol_to_string (type_name_sym), + scm_from_locale_string (">"))); + name = scm_string_to_symbol (name); + } + else + name = SCM_GOOPS_UNBOUND; + + class = scm_permanent_object (scm_basic_make_class (applicablep + ? scm_class_procedure_class + : scm_class_class, + name, + supers, + SCM_EOL)); + + /* Only define name if doesn't already exist. */ + if (!SCM_GOOPS_UNBOUNDP (name) + && scm_is_false (scm_module_variable (scm_module_goops, name))) DEFVAR (name, class); return class; } @@ -2662,6 +2724,16 @@ scm_make_extended_class (char const *type_name, int applicablep) applicablep); } +static SCM +scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep) +{ + return make_class_from_symbol (type_name_sym, + scm_list_1 (applicablep + ? scm_class_applicable + : scm_class_top), + applicablep); +} + void scm_i_inherit_applicable (SCM c) { @@ -2754,11 +2826,16 @@ static SCM make_struct_class (void *closure SCM_UNUSED, SCM vtable, SCM data, SCM prev SCM_UNUSED) { - if (scm_is_true (SCM_STRUCT_TABLE_NAME (data))) - SCM_SET_STRUCT_TABLE_CLASS (data, - scm_make_extended_class - (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)), - SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR)); + SCM sym = SCM_STRUCT_TABLE_NAME (data); + if (scm_is_true (sym)) + { + int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR; + + SCM_SET_STRUCT_TABLE_CLASS (data, + scm_make_extended_class_from_symbol (sym, applicablep)); + } + + scm_remember_upto_here_2 (data, vtable); return SCM_UNSPECIFIED; } @@ -2978,8 +3055,23 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, { goops_loaded_p = 1; var_compute_applicable_methods = - scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, - SCM_BOOL_F); + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_compute_applicable_methods)); + var_slot_unbound = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_slot_unbound)); + var_slot_missing = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_slot_missing)); + var_compute_cpl = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_compute_cpl)); + var_no_applicable_method = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_no_applicable_method)); + var_change_class = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_change_class)); setup_extended_primitive_generics (); return SCM_UNSPECIFIED; } @@ -2991,12 +3083,10 @@ SCM scm_init_goops_builtins (void) { scm_module_goops = scm_current_module (); - scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); /* Not really necessary right now, but who knows... */ scm_permanent_object (scm_module_goops); - scm_permanent_object (scm_goops_lookup_closure); scm_components = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (37))); |