diff options
Diffstat (limited to 'libguile/goops.c')
-rw-r--r-- | libguile/goops.c | 70 |
1 files changed, 38 insertions, 32 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 274749048..899ba7329 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -124,7 +124,7 @@ SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2]) #define SCM_GOOPS_UNBOUND SCM_UNBOUND -#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND) +#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND)) static int goops_loaded_p = 0; static scm_t_rstate *goops_rstate; @@ -293,7 +293,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_fraction; } case scm_tc7_program: - if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x)) + if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) + && SCM_UNPACK (*SCM_SUBR_GENERIC (x))) return scm_class_primitive_generic; else return scm_class_procedure; @@ -494,8 +495,8 @@ compute_getters_n_setters (SCM slots) SCM options = SCM_CDAR (slots); if (!scm_is_null (options)) { - init = scm_get_keyword (k_init_value, options, 0); - if (init) + init = scm_get_keyword (k_init_value, options, SCM_PACK (0)); + if (SCM_UNPACK (init)) { init = scm_primitive_eval (scm_list_3 (scm_sym_lambda, SCM_EOL, @@ -592,7 +593,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots)) { SCM slot_name = SCM_CAR (slots); - SCM slot_value = 0; + SCM slot_value = SCM_PACK (0); if (!scm_is_null (SCM_CDR (slot_name))) { @@ -604,10 +605,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, tmp = scm_i_get_keyword (k_init_keyword, SCM_CDR (slot_name), n, - 0, + SCM_PACK (0), FUNC_NAME); slot_name = SCM_CAR (slot_name); - if (tmp) + if (SCM_UNPACK (tmp)) { /* an initarg was provided for this slot */ if (!scm_is_keyword (tmp)) @@ -616,12 +617,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, - 0, + SCM_PACK (0), FUNC_NAME); } } - if (slot_value) + if (SCM_UNPACK (slot_value)) /* set slot to provided value */ set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value); else @@ -1231,7 +1232,7 @@ slot_definition_using_name (SCM class, SCM slot_name) { register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters); for (; !scm_is_null (slots); slots = SCM_CDR (slots)) - if (SCM_CAAR (slots) == slot_name) + if (scm_is_eq (SCM_CAAR (slots), slot_name)) return SCM_CAR (slots); return SCM_BOOL_F; } @@ -1599,7 +1600,7 @@ burnin (SCM o) static void go_to_hell (void *o) { - SCM obj = SCM_PACK ((scm_t_bits) o); + SCM obj = *(SCM*)o; scm_lock_mutex (hell_mutex); if (n_hell >= hell_size) { @@ -1613,8 +1614,9 @@ go_to_hell (void *o) static void go_to_heaven (void *o) { + SCM obj = *(SCM*)o; scm_lock_mutex (hell_mutex); - hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell]; + hell[burnin (obj)] = hell[--n_hell]; scm_unlock_mutex (hell_mutex); } @@ -1622,10 +1624,9 @@ go_to_heaven (void *o) SCM_SYMBOL (scm_sym_change_class, "change-class"); static SCM -purgatory (void *args) +purgatory (SCM obj, SCM new_class) { - return scm_apply_0 (SCM_VARIABLE_REF (var_change_class), - SCM_PACK ((scm_t_bits) args)); + return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class); } /* This function calls the generic function change-class for all @@ -1636,9 +1637,13 @@ void scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) { if (!burnin (obj)) - scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, - (void *) SCM_UNPACK (scm_list_2 (obj, new_class)), - (void *) SCM_UNPACK (obj)); + { + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY); + scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY); + purgatory (obj, new_class); + scm_dynwind_end (); + } } /****************************************************************************** @@ -1697,7 +1702,7 @@ static SCM make_dispatch_procedure (SCM gf) { static SCM var = SCM_BOOL_F; - if (var == SCM_BOOL_F) + if (scm_is_false (var)) var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"), sym_delayed_compile); return scm_call_1 (SCM_VARIABLE_REF (var), gf); @@ -1771,7 +1776,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, { if (SCM_PRIMITIVE_GENERIC_P (subr)) { - if (!*SCM_SUBR_GENERIC (subr)) + if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr))) scm_enable_primitive_generic_x (scm_list_1 (subr)); return *SCM_SUBR_GENERIC (subr); } @@ -1798,7 +1803,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension) if (goops_loaded_p) { SCM gf, gext; - if (!*SCM_SUBR_GENERIC (extended)) + if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended))) scm_enable_primitive_generic_x (scm_list_1 (extended)); gf = *SCM_SUBR_GENERIC (extended); gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), @@ -1815,7 +1820,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension) * extensions in the extensions list. O(N^2) algorithm, but * extensions of primitive generics are rare. */ - while (*loc && extension != (*loc)->extended) + while (*loc && !scm_is_eq (extension, (*loc)->extended)) loc = &(*loc)->next; e->next = *loc; e->extended = extended; @@ -1883,13 +1888,13 @@ more_specificp (SCM m1, SCM m2, SCM const *targs) for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) { if (scm_is_null(s1)) return 1; if (scm_is_null(s2)) return 0; - if (SCM_CAR(s1) != SCM_CAR(s2)) { + if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) { register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2); for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { - if (cs1 == SCM_CAR(l)) + if (scm_is_eq (cs1, SCM_CAR (l))) return 1; - if (cs2 == SCM_CAR(l)) + if (scm_is_eq (cs2, SCM_CAR (l))) return 0; } return 0;/* should not occur! */ @@ -2106,7 +2111,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, class = SCM_CAR(args); args = SCM_CDR(args); - if (class == scm_class_generic || class == scm_class_accessor) + if (scm_is_eq (class, scm_class_generic) + || scm_is_eq (class, scm_class_accessor)) { z = scm_make_struct (class, SCM_INUM0, scm_list_4 (SCM_BOOL_F, @@ -2118,7 +2124,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, args, SCM_BOOL_F)); clear_method_cache (z); - if (class == scm_class_accessor) + if (scm_is_eq (class, scm_class_accessor)) { SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F); if (scm_is_true (setter)) @@ -2129,8 +2135,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, { z = scm_sys_allocate_instance (class, args); - if (class == scm_class_method - || class == scm_class_accessor_method) + if (scm_is_eq (class, scm_class_method) + || scm_is_eq (class, scm_class_accessor_method)) { SCM_SET_SLOT (z, scm_si_generic_function, scm_i_get_keyword (k_gf, @@ -2513,7 +2519,7 @@ static SCM make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) { SCM class, name; - if (type_name_sym != SCM_BOOL_F) + if (scm_is_true (type_name_sym)) { name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), scm_symbol_to_string (type_name_sym), @@ -2595,12 +2601,12 @@ create_smob_classes (void) long i; for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i) - scm_smob_class[i] = 0; + scm_smob_class[i] = SCM_BOOL_F; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; for (i = 0; i < scm_numsmob; ++i) - if (!scm_smob_class[i]) + if (scm_is_false (scm_smob_class[i])) scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i), scm_smobs[i].apply != 0); } |