diff --git a/libguile/goops.c b/libguile/goops.c index fdf4469b6..41aa6433a 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -28,6 +28,7 @@ #include "libguile/_scm.h" #include "libguile/alist.h" +#include "libguile/chars.h" #include "libguile/debug.h" #include "libguile/dynl.h" #include "libguile/dynwind.h" @@ -114,7 +115,13 @@ static scm_t_rstate *goops_rstate; static SCM scm_goops_lookup_closure; -/* Some classes are defined in libguile/objects.c. */ +/* 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; +SCM scm_class_procedure_with_setter, scm_class_primitive_generic; +SCM scm_class_vector, scm_class_null; +SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; +SCM scm_class_unknown; SCM scm_class_top, scm_class_object, scm_class_class; SCM scm_class_applicable; SCM scm_class_entity, scm_class_entity_with_setter; @@ -139,6 +146,11 @@ SCM scm_class_protected_opaque, scm_class_protected_read_only; SCM scm_class_scm; SCM scm_class_int, scm_class_float, scm_class_double; +SCM *scm_port_class = 0; +SCM *scm_smob_class = 0; + +SCM scm_no_applicable_method; + SCM_SYMBOL (scm_sym_define_public, "define-public"); static SCM scm_make_unbound (void); @@ -147,6 +159,135 @@ 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); +/* This function is used for efficient type dispatch. */ +SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, + (SCM x), + "Return the class of @var{x}.") +#define FUNC_NAME s_scm_class_of +{ + switch (SCM_ITAG3 (x)) + { + case scm_tc3_int_1: + case scm_tc3_int_2: + return scm_class_integer; + + case scm_tc3_imm24: + if (SCM_CHARP (x)) + return scm_class_char; + else if (scm_is_bool (x)) + return scm_class_boolean; + else if (scm_is_null (x)) + return scm_class_null; + else + return scm_class_unknown; + + case scm_tc3_cons: + switch (SCM_TYP7 (x)) + { + case scm_tcs_cons_nimcar: + return scm_class_pair; + case scm_tcs_closures: + return scm_class_procedure; + case scm_tc7_symbol: + return scm_class_symbol; + case scm_tc7_vector: + case scm_tc7_wvect: + return scm_class_vector; + case scm_tc7_string: + return scm_class_string; + case scm_tc7_number: + switch SCM_TYP16 (x) { + case scm_tc16_big: + return scm_class_integer; + case scm_tc16_real: + return scm_class_real; + case scm_tc16_complex: + return scm_class_complex; + case scm_tc16_fraction: + return scm_class_fraction; + } + case scm_tc7_asubr: + case scm_tc7_subr_0: + case scm_tc7_subr_1: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_3: + case scm_tc7_subr_2: + case scm_tc7_rpsubr: + case scm_tc7_subr_1o: + case scm_tc7_subr_2o: + case scm_tc7_lsubr_2: + case scm_tc7_lsubr: + if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) + return scm_class_primitive_generic; + else + return scm_class_procedure; + case scm_tc7_cclo: + return scm_class_procedure; + case scm_tc7_pws: + return scm_class_procedure_with_setter; + + case scm_tc7_smob: + { + scm_t_bits type = SCM_TYP16 (x); + if (type != scm_tc16_port_with_ps) + return scm_smob_class[SCM_TC2SMOBNUM (type)]; + x = SCM_PORT_WITH_PS_PORT (x); + /* fall through to ports */ + } + case scm_tc7_port: + return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x) + ? (SCM_RDNG & SCM_CELL_WORD_0 (x) + ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) + : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) + : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) + return SCM_CLASS_OF (x); + else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) + { + /* Goops object */ + if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x))) + scm_change_object_class (x, + SCM_CLASS_OF (x), /* old */ + SCM_OBJ_CLASS_REDEF (x)); /* new */ + return SCM_CLASS_OF (x); + } + else + { + /* ordinary struct */ + SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); + if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) + return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); + 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_I_OPERATORP (x)); + SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); + return class; + } + } + default: + if (scm_is_pair (x)) + return scm_class_pair; + else + return scm_class_unknown; + } + + case scm_tc3_struct: + case scm_tc3_tc7_1: + case scm_tc3_tc7_2: + case scm_tc3_closure: + /* Never reached */ + break; + } + return scm_class_unknown; +} +#undef FUNC_NAME + /****************************************************************************** * * Compute-cpl @@ -2437,7 +2578,6 @@ create_standard_classes (void) scm_class_class, scm_list_2 (scm_class_input_port, scm_class_output_port), SCM_EOL); - scm_classes_initialized = 1; } /********************************************************************** diff --git a/libguile/goops.h b/libguile/goops.h index 2130d7dbd..80f47c6a3 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -156,6 +156,22 @@ typedef struct scm_t_method { #define scm_si_code_table 3 /* offset of code. slot in a */ /* C interface */ +SCM_API SCM scm_class_boolean; +SCM_API SCM scm_class_char; +SCM_API SCM scm_class_pair; +SCM_API SCM scm_class_procedure; +SCM_API SCM scm_class_string; +SCM_API SCM scm_class_symbol; +SCM_API SCM scm_class_procedure_with_setter; +SCM_API SCM scm_class_primitive_generic; +SCM_API SCM scm_class_vector, scm_class_null; +SCM_API SCM scm_class_real; +SCM_API SCM scm_class_complex; +SCM_API SCM scm_class_integer; +SCM_API SCM scm_class_fraction; +SCM_API SCM scm_class_unknown; +SCM_API SCM *scm_port_class; +SCM_API SCM *scm_smob_class; SCM_API SCM scm_class_top; SCM_API SCM scm_class_object; SCM_API SCM scm_class_class; @@ -197,6 +213,8 @@ SCM_API SCM scm_class_float; SCM_API SCM scm_class_double; SCM_API const char *scm_s_slot_set_x; +SCM_API SCM scm_no_applicable_method; + SCM_API SCM scm_module_goops; SCM_API SCM scm_goops_version (void); @@ -216,6 +234,7 @@ SCM_API SCM scm_wrap_object (SCM c, void *); SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *); SCM_API SCM scm_ensure_accessor (SCM name); SCM_API void scm_add_method (SCM gf, SCM m); +SCM_API SCM scm_class_of (SCM obj); /* Low level functions exported */ SCM_API SCM scm_make_next_method (SCM methods, SCM args, SCM gf); diff --git a/libguile/objects.c b/libguile/objects.c index 1695c185c..5c7575e5e 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -43,153 +43,6 @@ SCM scm_metaclass_standard; SCM scm_metaclass_operator; -/* 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; -SCM scm_class_procedure_with_setter, scm_class_primitive_generic; -SCM scm_class_vector, scm_class_null; -SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; -SCM scm_class_unknown; - -int scm_classes_initialized = 0; - -SCM *scm_port_class = 0; -SCM *scm_smob_class = 0; - -SCM scm_no_applicable_method; - -/* This function is used for efficient type dispatch. */ -SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, - (SCM x), - "Return the class of @var{x}.") -#define FUNC_NAME s_scm_class_of -{ - if (!scm_classes_initialized) - scm_misc_error (NULL, "GOOPS not loaded yet.", SCM_EOL); - - switch (SCM_ITAG3 (x)) - { - case scm_tc3_int_1: - case scm_tc3_int_2: - return scm_class_integer; - - case scm_tc3_imm24: - if (SCM_CHARP (x)) - return scm_class_char; - else if (scm_is_bool (x)) - return scm_class_boolean; - else if (scm_is_null (x)) - return scm_class_null; - else - return scm_class_unknown; - - case scm_tc3_cons: - switch (SCM_TYP7 (x)) - { - case scm_tcs_cons_nimcar: - return scm_class_pair; - case scm_tcs_closures: - return scm_class_procedure; - case scm_tc7_symbol: - return scm_class_symbol; - case scm_tc7_vector: - case scm_tc7_wvect: - return scm_class_vector; - case scm_tc7_string: - return scm_class_string; - case scm_tc7_number: - switch SCM_TYP16 (x) { - case scm_tc16_big: - return scm_class_integer; - case scm_tc16_real: - return scm_class_real; - case scm_tc16_complex: - return scm_class_complex; - case scm_tc16_fraction: - return scm_class_fraction; - } - case scm_tc7_asubr: - case scm_tc7_subr_0: - case scm_tc7_subr_1: - case scm_tc7_dsubr: - case scm_tc7_cxr: - case scm_tc7_subr_3: - case scm_tc7_subr_2: - case scm_tc7_rpsubr: - case scm_tc7_subr_1o: - case scm_tc7_subr_2o: - case scm_tc7_lsubr_2: - case scm_tc7_lsubr: - if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) - return scm_class_primitive_generic; - else - return scm_class_procedure; - case scm_tc7_cclo: - return scm_class_procedure; - case scm_tc7_pws: - return scm_class_procedure_with_setter; - - case scm_tc7_smob: - { - scm_t_bits type = SCM_TYP16 (x); - if (type != scm_tc16_port_with_ps) - return scm_smob_class[SCM_TC2SMOBNUM (type)]; - x = SCM_PORT_WITH_PS_PORT (x); - /* fall through to ports */ - } - case scm_tc7_port: - return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x) - ? (SCM_RDNG & SCM_CELL_WORD_0 (x) - ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) - : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) - : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) - return SCM_CLASS_OF (x); - else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) - { - /* Goops object */ - if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x))) - scm_change_object_class (x, - SCM_CLASS_OF (x), /* old */ - SCM_OBJ_CLASS_REDEF (x)); /* new */ - return SCM_CLASS_OF (x); - } - else - { - /* ordinary struct */ - SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); - if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) - return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); - 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_I_OPERATORP (x)); - SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); - return class; - } - } - default: - if (scm_is_pair (x)) - return scm_class_pair; - else - return scm_class_unknown; - } - - case scm_tc3_struct: - case scm_tc3_tc7_1: - case scm_tc3_tc7_2: - case scm_tc3_closure: - /* Never reached */ - break; - } - return scm_class_unknown; -} -#undef FUNC_NAME - /* The cache argument for scm_mcache_lookup_cmethod has one of two possible * formats: * diff --git a/libguile/objects.h b/libguile/objects.h index 801f5f0b1..d6d4a2e42 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -178,25 +178,6 @@ typedef struct scm_effective_slot_definition { /* Plugin proxy classes for basic types. */ SCM_API SCM scm_metaclass_standard; SCM_API SCM scm_metaclass_operator; -SCM_API SCM scm_class_boolean; -SCM_API SCM scm_class_char; -SCM_API SCM scm_class_pair; -SCM_API SCM scm_class_procedure; -SCM_API SCM scm_class_string; -SCM_API SCM scm_class_symbol; -SCM_API SCM scm_class_procedure_with_setter; -SCM_API SCM scm_class_primitive_generic; -SCM_API SCM scm_class_vector, scm_class_null; -SCM_API SCM scm_class_real; -SCM_API SCM scm_class_complex; -SCM_API SCM scm_class_integer; -SCM_API SCM scm_class_fraction; -SCM_API SCM scm_class_unknown; -SCM_API SCM *scm_port_class; -SCM_API SCM *scm_smob_class; -SCM_API int scm_classes_initialized; - -SCM_API SCM scm_no_applicable_method; /* Goops functions. */ SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep); @@ -205,7 +186,6 @@ SCM_API void scm_make_port_classes (long ptobnum, char *type_name); SCM_API void scm_change_object_class (SCM, SCM, SCM); SCM_API SCM scm_memoize_method (SCM x, SCM args); -SCM_API SCM scm_class_of (SCM obj); SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args); SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args); /* The following are declared in __scm.h