/* * * s t k l o s . c -- STklos support * * Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, modify, distribute,and license this * software and its documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in any * distributions. No written agreement, license, or royalty fee is * required for any of the authorized uses. * This software is provided ``AS IS'' without express or implied * warranty. * * Author: Erick Gallesio [eg@unice.fr] * Creation date: 9-Feb-1994 15:56 * Last file update: 3-Sep-1999 20:58 (eg) */ #ifdef USE_STKLOS #include "stk.h" #include "stklos.h" #include "extend.h" #include "module.h" #define CLASSP(x) (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Class)) #define GENERICP(x) (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Generic)) #define METHODP(x) (INSTANCEP(x) && SUBCLASSP(CLASS_OF(x), Method)) #define NCLASSP(x) (!CLASSP(x)) #define NGENERICP(x) (!GENERICP(x)) #define NMETHODP(x) (!METHODP(x)) #define SPEC_OF(x) THE_SLOT_OF(x, S_specializers) #define DEFVAR(v,val) {STk_define_public_var(STklos,(v),(val)); \ STk_export_symbol(v, STklos);} #define GETVAR(v) (*(STk_varlookup((v), MOD_ENV(STklos),FALSE))) #define CALL_GF1(name,a) (Apply1(GETVAR(Intern(name)), a)) #define CALL_GF2(name,a,b) (Apply2(GETVAR(Intern(name)), a, b)) #define CALL_GF3(name,a,b,c) (Apply(GETVAR(Intern(name)), LIST3(a, b, c))) #define CALL_GF4(name,a,b,c,d) (Apply(GETVAR(Intern(name)), LIST4(a, b, c, d))) #define CLASS_REDEF(c) THE_SLOT_OF(c, S_redefined) #define TEST_CHANGE_CLASS(obj, classe) \ { \ classe = CLASS_OF(obj); \ if (CLASS_REDEF(classe) != Ntruth) \ CALL_GF3("change-object-class", obj, classe, CLASS_REDEF(classe)); \ } #define NXT_MTHD_METHODS CAR #define NXT_MTHD_ARGS CDR static char initialized = 0; static SCM STklos; static SCM Top, Object, Class, Generic, Method, Simple_method, Accessor, Procedure_class, Entity_class; static SCM Boolean, Char, Pair, Procedure, String, Symbol, Vector, Number, Liste, Null, Real, Integer, Keyword, UnknownClass; #ifdef USE_TK static SCM Widget; #endif static void set_slot_value_if_unbound(SCM classe, SCM obj, SCM slot_name, SCM form); /*****************************************************************************/ static SCM make_instance(SCM classe, long size, int type) { register SCM z; register long i; NEWCELL(z, STk_tc_instance); INST(z) = must_malloc(sizeof(Instance) + (size-1)*sizeof(SCM)); CLASS_OF(z) = classe; INST_TYPE(z) = type; ACCESSORS_OF(z) = classe? THE_SLOT_OF(classe, S_getters_n_setters) : NIL; NUMBER_OF_SLOTS(z) = size; /* Set all the slots to unbound */ for (i = 0; i < size; i++) THE_SLOT_OF(z, i) = UNBOUND; return z; } void STk_free_instance(SCM o) { free(INST(o)); } SCM STk_STklos_value(SCM symbol) { return GETVAR(symbol); } /****************************************************************************** * * Compute-cpl * * This version doesn't handle multiple-inheritance. It serves only for * booting classes and will be overaloaded in Scheme * ******************************************************************************/ static SCM compute_cpl(SCM supers, SCM res) { return NULLP(supers)? Reverse(res) : compute_cpl(THE_SLOT_OF(CAR(supers), S_direct_supers), Cons(CAR(supers), res)); } /****************************************************************************** * * compute-slots * ******************************************************************************/ static SCM remove_duplicate_slots(SCM l, SCM res, SCM slots_already_seen) { SCM tmp; if (NULLP(l)) return res; tmp = CONSP(CAR(l)) ? CAR(CAR(l)) : CAR(l); if (NSYMBOLP(tmp)) Err("%compute-slots: bad slot name", tmp); if (STk_memq(tmp, slots_already_seen) == Ntruth) { res = Cons(CAR(l), res); slots_already_seen = Cons(tmp, slots_already_seen); } return remove_duplicate_slots(CDR(l), res, slots_already_seen); } static SCM build_slots_list(SCM dslots, SCM cpl) { register SCM res = dslots; for (cpl = CDR(cpl); NNULLP(cpl); cpl = CDR(cpl)) res = STk_append2(THE_SLOT_OF(CAR(cpl), S_direct_slots), res); /* res contains a list of slots. Remove slots which appears more than once */ return remove_duplicate_slots(Reverse(res), NIL, NIL); } static PRIMITIVE compute_slots(SCM classe) { if (NCLASSP(classe)) Err("%compute-slots: bad class", classe); return build_slots_list(THE_SLOT_OF(classe, S_direct_slots), THE_SLOT_OF(classe, S_cpl)); } /****************************************************************************** * * compute-getters-n-setters * * This version doesn't handle slot options. It serves only for booting * classes and will be overaloaded in Scheme. * ******************************************************************************/ static SCM compute_getters_n_setters(SCM slots) { SCM res = NIL; long i = 0; for ( ; NNULLP(slots); slots = CDR(slots)) res = Cons(Cons(CAR(slots), Cons(Ntruth, STk_makeinteger(i++))), res); return res; } /****************************************************************************** * * initialize-object * ******************************************************************************/ static PRIMITIVE initialize_object(SCM obj, SCM initargs) { static char k_init_keyword[] = ":init-keyword"; SCM tmp, get_n_set, slots; SCM init_keyword = STk_makekey(k_init_keyword); SCM classe = CLASS_OF(obj); ENTER_PRIMITIVE("%initialize-object"); if (NINSTANCEP(obj)) Serror("bad object", obj); if (NCONSP(initargs) && NNULLP(initargs)) Serror("bad init list", initargs); get_n_set = THE_SLOT_OF(classe, S_getters_n_setters); slots = THE_SLOT_OF(classe, S_slots); /* See for each slot how it must be initialized */ for ( ; NNULLP(slots); get_n_set=CDR(get_n_set), slots=CDR(slots)) { SCM slot_name = CAR(slots); SCM slot_value = NULL; if (CONSP(slot_name)) { /* This slot admits (perhaps) to be initialized at creation time */ tmp = STk_get_keyword(init_keyword,CDR(slot_name), NULL); slot_name = CAR(slot_name); if (tmp) { /* an initarg was provided for this slot */ if (NKEYWORDP(tmp)) Serror("initarg must be a keyword. It was", tmp); slot_value = STk_get_keyword(tmp, initargs, NULL); } } if (slot_value) /* set slot to provided value */ STk_slot_set(obj, slot_name, slot_value); else { /* set slot to its :initform if it exists */ tmp = CAR(CDR(CAR(get_n_set))); if (tmp != Ntruth) set_slot_value_if_unbound(classe, obj, slot_name, tmp); } } return obj; } /******************************************************************************/ SCM STk_basic_make_class(SCM classe, SCM name, SCM dsupers, SCM dslots) { SCM z, cpl, slots, g_n_s; /* Allocate one instance */ z = make_instance(classe, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE); /* Initialize its slots */ cpl = compute_cpl(dsupers, LIST1(z)); slots = build_slots_list(dslots, cpl); g_n_s = compute_getters_n_setters(slots); THE_SLOT_OF(z, S_name) = name; THE_SLOT_OF(z, S_direct_supers) = dsupers; THE_SLOT_OF(z, S_direct_slots) = dslots; THE_SLOT_OF(z, S_direct_subclasses) = NIL; THE_SLOT_OF(z, S_direct_methods) = NIL; THE_SLOT_OF(z, S_cpl) = cpl; THE_SLOT_OF(z, S_slots) = slots; THE_SLOT_OF(z, S_nfields) = STk_makeinteger(STk_llength(slots)); THE_SLOT_OF(z, S_getters_n_setters) = g_n_s; THE_SLOT_OF(z, S_redefined) = Ntruth; THE_SLOT_OF(z, S_environment) = MOD_ENV(STklos); /* Don't forget to set the accessors list of the object */ ACCESSORS_OF(z) = THE_SLOT_OF(classe, S_getters_n_setters); /* Add this class in the direct-subclasses slot of dsupers */ { SCM tmp; for (tmp = dsupers; NNULLP(tmp); tmp = CDR(tmp)) { THE_SLOT_OF(CAR(tmp), S_direct_subclasses) = Cons(z, THE_SLOT_OF(CAR(tmp), S_direct_subclasses)); } } return z; } /******************************************************************************/ static void create_Top_Object_Class(void) { SCM tmp, slots_of_class = Cons(Intern("name"), Cons(Intern("direct-supers"), Cons(Intern("direct-slots"), Cons(Intern("direct-subclasses"), Cons(Intern("direct-methods"), Cons(Intern("cpl"), Cons(Intern("slots"), Cons(Intern("nfields"), Cons(Intern("getters-n-setters"), Cons(Intern("redefined"), Cons(Intern("environment"), NIL))))))))))); /* protect Top, Object and Class against garbage collection */ STk_gc_protect(&Top); STk_gc_protect(&Object); STk_gc_protect(&Class); /**** ****/ tmp = Intern(""); Class = make_instance(NULL, NUMBER_OF_CLASS_SLOTS, TYPE_INSTANCE); CLASS_OF(Class) = Class; ACCESSORS_OF(Class) = compute_getters_n_setters(slots_of_class); THE_SLOT_OF(Class, S_name) = tmp; THE_SLOT_OF(Class, S_direct_supers) = NIL; /* will be changed */ THE_SLOT_OF(Class, S_direct_slots) = slots_of_class; THE_SLOT_OF(Class, S_direct_subclasses)= NIL; THE_SLOT_OF(Class, S_direct_methods) = NIL; THE_SLOT_OF(Class, S_cpl) = NIL; /* will be changed */ THE_SLOT_OF(Class, S_slots) = slots_of_class; THE_SLOT_OF(Class, S_nfields) = STk_makeinteger(NUMBER_OF_CLASS_SLOTS); THE_SLOT_OF(Class, S_getters_n_setters)= ACCESSORS_OF(Class); THE_SLOT_OF(Class, S_redefined) = Ntruth; THE_SLOT_OF(Class, S_environment) = MOD_ENV(STklos); DEFVAR(tmp, Class); /**** ****/ tmp = Intern(""); Top = STk_basic_make_class(Class, tmp, NIL, NIL); DEFVAR(tmp, Top); /**** ****/ tmp = Intern(""); Object = STk_basic_make_class(Class, tmp, LIST1(Top), NIL); DEFVAR(tmp, Object); /* and were partially initialized. Correct them here */ THE_SLOT_OF(Object, S_direct_subclasses) = LIST1(Class); THE_SLOT_OF(Class, S_direct_supers) = LIST1(Object); THE_SLOT_OF(Class, S_cpl) = LIST3(Class, Object, Top); } /******************************************************************************/ static PRIMITIVE instancep(SCM obj) { return INSTANCEP(obj)? Truth: Ntruth; } static SCM class_of(SCM obj) { if (INSTANCEP(obj)) { SCM classe; TEST_CHANGE_CLASS(obj, classe); return CLASS_OF(obj); } switch (TYPE(obj)) { case tc_boolean: return Boolean; case tc_char: return Char; case tc_cons: return Pair; case tc_nil: return Null; case tc_string: return String; case tc_symbol: return Symbol; case tc_vector: return Vector; case tc_flonum: return Real; case tc_integer: case tc_bignum: return Integer; case tc_keyword: return Keyword; #ifdef USE_TK case tc_tkcommand: return Widget; #endif default: if (EXTENDEDP(obj)) return STk_extended_class_of(obj); else return (STk_procedurep(obj) == Truth)? Procedure: UnknownClass; } } /****************************************************************************** * * Meta object accessors * ******************************************************************************/ static PRIMITIVE class_name(SCM obj) { if (NCLASSP(obj)) Err("class-name: bad class", obj); return STk_slot_ref(obj, Intern("name")); } static PRIMITIVE class_direct_supers(SCM obj) { if (NCLASSP(obj)) Err("class-direct-supers: bad class", obj); return STk_slot_ref(obj, Intern("direct-supers")); } static PRIMITIVE class_direct_slots(SCM obj) { if (NCLASSP(obj)) Err("class-direct-slots: bad class", obj); return STk_slot_ref(obj, Intern("direct-slots")); } static PRIMITIVE class_direct_subs(SCM obj) { if (NCLASSP(obj)) Err("class-direct-subclasses: bad class", obj); return STk_slot_ref(obj, Intern("direct-subclasses")); } static PRIMITIVE class_direct_methods(SCM obj) { if (NCLASSP(obj)) Err("class-direct-methods: bad class", obj); return STk_slot_ref(obj, Intern("direct-methods")); } static PRIMITIVE class_cpl(SCM obj) { if (NCLASSP(obj)) Err("class-precedence-list: bad class", obj); return STk_slot_ref(obj, Intern("cpl")); } static PRIMITIVE class_slots(SCM obj) { if (NCLASSP(obj)) Err("class-slots: bad class", obj); return STk_slot_ref(obj, Intern("slots")); } static PRIMITIVE class_environment(SCM obj) { if (NCLASSP(obj)) Err("class-environment: bad class", obj); return STk_slot_ref(obj, Intern("environment")); } static PRIMITIVE gf_name(SCM obj) { if (NGENERICP(obj)) Err("generic-function-name: bad function", obj); return STk_slot_ref(obj, Intern("name")); } static PRIMITIVE gf_methods(SCM obj) { if (NGENERICP(obj)) Err("generic-function-methods: bad function", obj); return STk_slot_ref(obj, Intern("methods")); } static PRIMITIVE method_gf(SCM obj) { if (NMETHODP(obj)) Err("method-generic-function: bad method", obj); return STk_slot_ref(obj, Intern("generic-function")); } static PRIMITIVE method_specializers(SCM obj) { if (NMETHODP(obj)) Err("method-specializers: bad method", obj); return STk_slot_ref(obj, Intern("specializers")); } static PRIMITIVE method_procedure(SCM obj) { if (NMETHODP(obj)) Err("method-procedure: bad method", obj); return STk_slot_ref(obj, Intern("procedure")); } /****************************************************************************** * * S l o t a c c e s s * ******************************************************************************/ static PRIMITIVE fast_slot_ref(SCM obj, SCM index) { register long i = STk_integer_value(index); ENTER_PRIMITIVE("%fast-slot-ref"); if (NINSTANCEP(obj)) Serror("bad object", obj); if (i < 0 || i >= NUMBER_OF_SLOTS(obj)) Serror("bad index", index); return THE_SLOT_OF(obj, i); } static PRIMITIVE fast_slot_set(SCM obj, SCM index, SCM value) { register long i = STk_integer_value(index); ENTER_PRIMITIVE("%fast-slot-set!"); if (NINSTANCEP(obj)) Serror("bad object", obj); if (i < 0 || i >= NUMBER_OF_SLOTS(obj)) Serror("bad index", index); THE_SLOT_OF(obj, i) = value; return UNDEFINED; } /** Utilities **/ static SCM get_slot_value(SCM classe, SCM obj, SCM slot_name) { register SCM l; for (l=ACCESSORS_OF(obj); NNULLP(l); l=CDR(l)) { if (EQ(CAR(CAR(l)), slot_name)) { l = CDR(CDR(CAR(l))); /* Two cases here: * - l is an integer (the offset of this slot in the slots vector) * - otherwise (car l) is the getter function to apply */ if (INTEGERP(l)) return THE_SLOT_OF(obj, INTEGER(l)); else { /* We must evaluate (apply (car l) (list obj)) * where (car l) is known to be a closure of arity 1 */ register SCM code, env; code = CAR(l); env = add_frame(CLOSPARAMS(code), LIST1(obj), CLOSENV(code)); /* Evaluate the closure body */ for(code=CLOSBODY(code); NNULLP(code); code=CDR(code)) l = EVALCAR(code); return l; } } } return CALL_GF3("slot-missing", classe, obj, slot_name); } static SCM set_slot_value(SCM classe, SCM obj, SCM slot_name, SCM value) { register SCM l; for (l=ACCESSORS_OF(obj); NNULLP(l); l=CDR(l)) { if (EQ(CAR(CAR(l)), slot_name)) { l = CDR(CDR(CAR(l))); /* Two cases here: * - l is an integer (the offset of this slot in the slots vector) * - otherwise (cadr l) is the setter function to apply */ if (INTEGERP(l)) THE_SLOT_OF(obj, INTEGER(l)) = value; else { /* We must evaluate (apply (cadr l) (list obj value)) * where (cadr l) is known to be a closure of arity 2 */ register SCM code, env; code = CAR(CDR(l)); env = add_frame(CLOSPARAMS(code), LIST2(obj, value), CLOSENV(code)); /* Evaluate the closure body */ for(code=CLOSBODY(code); NNULLP(code); code=CDR(code)) EVALCAR(code); } return UNDEFINED; } } return CALL_GF4("slot-missing", classe, obj, slot_name, value); } static void set_slot_value_if_unbound(SCM classe, SCM obj, SCM slot_name, SCM form) { SCM old_val = get_slot_value(classe, obj, slot_name); if (old_val == UNBOUND) set_slot_value(classe, obj, slot_name, Apply0(form)); } static SCM test_slot_existence(SCM classe, SCM obj, SCM slot_name) { register SCM l; for (l=ACCESSORS_OF(obj); NNULLP(l); l=CDR(l)) if (EQ(CAR(CAR(l)), slot_name)) return Truth; return Ntruth; } /* ======================================== */ static PRIMITIVE slot_ref_using_class(SCM classe, SCM obj, SCM slot_name) { SCM res; ENTER_PRIMITIVE("slot-ref-using-class"); if (NCLASSP(classe)) Serror("bad class", classe); if (NINSTANCEP(obj)) Serror("bad object", obj); res = get_slot_value(classe, obj, slot_name); if (res == UNBOUND) return CALL_GF3("slot-unbound", classe, obj, slot_name); return res; } static PRIMITIVE slot_set_using_class(SCM l, int len) { ENTER_PRIMITIVE("slot-set-using-class!"); if (len != 4) Serror("bad number of parameters", NIL); { SCM classe = CAR(l); SCM obj = CAR(CDR(l)); if (NCLASSP(classe)) Serror("bad class", classe); if (NINSTANCEP(obj)) Serror("bad object", obj); return set_slot_value(classe, obj, CAR(CDR(CDR(l))), CAR(CDR(CDR(CDR(l))))); } } static PRIMITIVE slot_boundp_using_class(SCM classe, SCM obj, SCM slot_name) { ENTER_PRIMITIVE("slot-bound-using-class?"); if (NCLASSP(classe)) Serror("bad class", classe); if (NSYMBOLP(slot_name)) Serror("bad slot name",slot_name); if (NINSTANCEP(obj)) Serror("bad object", obj); return (get_slot_value(classe, obj, slot_name) == UNBOUND) ? Ntruth : Truth; } static PRIMITIVE slot_exists_using_class(SCM classe, SCM obj, SCM slot_name) { ENTER_PRIMITIVE("slot-exists-using-class?"); if (NCLASSP(classe)) Serror("bad class", classe); if (NSYMBOLP(slot_name)) Serror("bad slot name",slot_name); if (NINSTANCEP(obj)) Serror("bad object", obj); return test_slot_existence(classe, obj, slot_name); } /* ======================================== */ PRIMITIVE STk_slot_ref(SCM obj, SCM slot_name) { SCM res, classe; if (NINSTANCEP(obj)) Err("slot-ref: bad object", obj); TEST_CHANGE_CLASS(obj, classe); res = get_slot_value(classe, obj, slot_name); if (res == UNBOUND) return CALL_GF3("slot-unbound", classe, obj, slot_name); return res; } PRIMITIVE STk_slot_set(SCM obj, SCM slot_name, SCM value) { SCM classe; if (NINSTANCEP(obj)) Err("slot-set!: bad object", obj); TEST_CHANGE_CLASS(obj, classe); return set_slot_value(classe, obj, slot_name, value); } static PRIMITIVE slot_boundp(SCM obj, SCM slot_name) { SCM classe; if (NINSTANCEP(obj)) Err("slot-bound?: bad object", obj); TEST_CHANGE_CLASS(obj, classe); return (get_slot_value(classe, obj, slot_name) == UNBOUND) ? Ntruth : Truth; } static PRIMITIVE slot_existsp(SCM obj, SCM slot_name) { SCM classe; ENTER_PRIMITIVE("slot-exists?"); if (NSYMBOLP(slot_name)) Serror("bad slot name", slot_name); if (NINSTANCEP(obj)) Serror("bad object", obj); TEST_CHANGE_CLASS(obj, classe); return test_slot_existence(classe, obj, slot_name); } /****************************************************************************** * * %allocate-instance (the low level instance allocation primitive) * ******************************************************************************/ PRIMITIVE STk_allocate_instance(SCM classe) { int type; if (NCLASSP(classe)) Err("%allocate-instance: bad class", classe); if (EQ(classe, Generic)) type= TYPE_GENERIC; else if (EQ(classe, Accessor)) type = TYPE_ACCESSOR; else if (EQ(classe, Simple_method)) type = TYPE_SIMPLE_METHOD; else type = TYPE_INSTANCE; return make_instance(classe, STk_integer_value(THE_SLOT_OF(classe, S_nfields)), type); } /****************************************************************************** * * %modify-instance (used by change-class to modify in place) * ******************************************************************************/ static PRIMITIVE modify_instance(SCM old, SCM new) { struct obj tmp; if (NINSTANCEP(old) || NINSTANCEP(new)) Err("%modify-instance: both parameters must be instances", NIL); /* Exchange the data contained in old and new. We exchange rather than * scratch the old value with new to be correct with GC */ tmp = *old; *old = *new; *new = tmp; return UNDEFINED; } static PRIMITIVE stklos_version(void) { return STk_makestring(STKLOS_VERSION); } /****************************************************************************** * * GGGG FFFFF * G F * G GG FFF * G G F * GGG E N E R I C F U N C T I O N S * * This implementation provides * - generic functions (with class specializers) * - multi-methods * - next-method * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf * ******************************************************************************/ SCM STk_make_next_method(SCM methods, SCM args, SCM gf) { register SCM z, l; /* if gf is NIL, args already contains the GF in front of args. * This saves the cost of a a cons. This situation is very frequent since * most of the time next-method is called without parameter and we just have * to propagate the previous args. */ l = (NULLP(gf))? args : Cons(gf, args); NEWCELL(z, tc_next_method); CAR(z) = methods; CDR(z) = l; return z; } SCM STk_apply_next_method(SCM next, SCM provided_args) { SCM methods = NXT_MTHD_METHODS(next); SCM args, tmp; if (NULLP(provided_args)) { tmp = NXT_MTHD_ARGS(next); args = CDR(tmp); } else { tmp = Cons(CAR(NXT_MTHD_ARGS(next)), provided_args); args = provided_args; } if (NULLP(methods)) { SCM gf = CAR(NXT_MTHD_ARGS(next)); return CALL_GF2("no-next-method", gf, args); } else { SCM m = CAR(methods); SCM new_next = STk_make_next_method(CDR(methods),tmp, NIL); /* m is the function to call with args. */ return Apply(THE_SLOT_OF(m, S_procedure), Cons(new_next, args)); } } static PRIMITIVE next_method_exists(SCM next) { if (NTYPEP(next, tc_next_method)) Err("next-method-exists: bad next method'", next); return NULLP(NXT_MTHD_METHODS(next))? Ntruth : Truth; } int STk_methodp(SCM obj) { return METHODP(obj); } /****************************************************************************** * * Protocol for calling a generic fumction * This protocol is roughly equivalent to (parameter are a little bit different * for efficiency reasons): * * + apply-generic (gf args) * + compute-applicable-methods (gf args ...) * + sort-applicable-methods (methods args) * + apply-methods (gf methods args) * * apply-methods calls make-next-method to build the "continuation" of a a * method. Applying a next-method will call apply-next-method which in * turn will call apply again to call effectively the following method. * ******************************************************************************/ static int applicablep(SCM actual, SCM formal) { register SCM ptr; /* We test that (memq formal (slot-ref actual 'cpl)) * However, we don't call memq here since we already know that * the list is well formed */ for (ptr=THE_SLOT_OF(actual, S_cpl); NNULLP(ptr); ptr = CDR(ptr)) { if (CONSP(ptr)) { if (EQ(CAR(ptr), formal)) return TRUE; } else Err("Internal error in applicable: bad list", actual); } return FALSE; } static int more_specificp(SCM m1, SCM m2, SCM *targs) { register SCM s1, s2; register int i; /* * Note: * m1 and m2 can have != length (i.e. one can be one element longer than the * other when we have a dotted parameter list). For instance, with the call * (M 1) * with * (define-method M (a . l) ....) * (define-method M (a) ....) * * we consider that the second method is more specific. * * BTW, targs is an array of types. We don't need it's size since * we already know that m1 and m2 are applicable (no risk to go past * the end of this array). * */ for (i=0,s1=SPEC_OF(m1),s2=SPEC_OF(m2); ; i++,s1=CDR(s1),s2=CDR(s2)) { if (NULLP(s1)) return 1; if (NULLP(s2)) return 0; if (CAR(s1) != CAR(s2)) { register SCM l, cs1 = CAR(s1), cs2 = CAR(s2); for (l = THE_SLOT_OF(targs[i], S_cpl); ; l = CDR(l)) { if (EQ(cs1, CAR(l))) return 1; if (EQ(cs2, CAR(l))) return 0; } return 0;/* should not occur! */ } } return 0; /* should not occur! */ } #define BUFFSIZE 32 /* big enough for most uses */ static SCM sort_applicable_methods(SCM method_list, int size, SCM *targs) { int i, j, incr; SCM *v, vector; SCM buffer[BUFFSIZE]; SCM save = method_list; /* For reasonably sized method_lists we can try to avoid all the * consing and reorder the list in place... * This idea is due to David McClain */ if (size <= BUFFSIZE) { for(i=0; i < size; i++) { buffer[i] = CAR(method_list); method_list = CDR(method_list); } vector = NIL; /* for GCC */ v = buffer; } else { /* Too many elements in method_list to keep everything locally */ vector = STk_vector(save, size); v = VECT(vector); } /* Use a simple shell sort since it is generally faster than qsort on * small vectors (which is probably mostly the case when we have to * sort a list of applicable methods). */ for (incr = size / 2; incr; incr /= 2) { for (i = incr; i < size; i++) { for (j = i-incr ;j >= 0; j -= incr) { if (more_specificp(v[j], v[j+incr], targs)) break; else { SCM tmp = v[j+incr]; v[j+incr] = v[j]; v[j] = tmp; } } } } if (size <= BUFFSIZE) { /* We did it in locally, so restore the original list (reordered) in-place */ for(i=0, method_list=save; i < size; i++, v++) { CAR(method_list) = *v; method_list = CDR(method_list); } return save; } /* If we are here, that's that we did it the hard way... */ return STk_vector2list(vector); } SCM STk_compute_applicable_methods(SCM gf, SCM args, int len, int find_method) { register int i; int count = 0; SCM l, fl, applicable = NIL; SCM save = args; SCM buffer[BUFFSIZE], *types, *p; SCM tmp; /* Build the list of arguments types */ if (len >= BUFFSIZE) { tmp = STk_makevect(len, NULL); types = p = VECT(tmp); } else types = p = buffer; for ( ; NNULLP(args); args = CDR(args)) *p++ = class_of(CAR(args)); /* Build a list of all applicable methods */ for (l = THE_SLOT_OF(gf, S_methods); NNULLP(l); l = CDR(l)) { for (i=0, fl=SPEC_OF(CAR(l)); ; i++, fl=CDR(fl)) { if (INSTANCEP(fl) || /* We have a dotted argument list */ (i >= len && NULLP(fl))) { /* both list exhausted */ applicable = Cons(CAR(l), applicable); count += 1; break; } if (i >= len || NULLP(fl) || !applicablep(types[i], CAR(fl))) break; } } if (count == 0) { if (find_method) return Ntruth; CALL_GF2("no-applicable-method", gf, save); /* if we are here, it's because no-applicable-method hasn't signaled an error */ return NIL; } return (count == 1) ? applicable : sort_applicable_methods(applicable, count, types); } static SCM apply_methods(SCM gf, SCM methods, SCM args) { SCM m, next; if (NULLP(methods)) { /* * methods can be NIL if we have a no-applicable-method handler which * doesn't signal an error (or dont ends with a call to next-method) * In this case return an undefined value */ return UNDEFINED; } m = CAR(methods); next = FASTMETHODP(m) ? UNBOUND : STk_make_next_method(CDR(methods), args, gf); /* Next-method is set to UNBOUND for simple_method and accessors */ return Apply(THE_SLOT_OF(m, S_procedure), Cons(next, args)); } SCM STk_apply_generic(SCM gf, SCM args) { if (NGENERICP(gf)) Err("apply: bad generic function", gf); if (NULLP(THE_SLOT_OF(gf, S_methods))) CALL_GF2("no-method", gf, args); return apply_methods(gf, STk_compute_applicable_methods(gf,args,STk_llength(args),FALSE), args); } SCM STk_apply_user_generic(SCM gf, SCM args) { if (NGENERICP(gf)) Err("apply: bad generic function", gf); return CALL_GF2("apply-generic", gf, args); } /****************************************************************************** * * A simple make (which will be redefined later in Scheme) * This version handles only creation of gf, methods and classes (no instances) * * Since this code will disappear when Stklos will be fully booted, * no precaution is taken to be efficient. * ******************************************************************************/ static char k_name[] = ":name"; /* Use vars since makekey patches */ static char k_specializers[] = ":specializers"; /* its argument. This avoids the */ static char k_procedure[] = ":procedure"; /* -fwritable_string */ static char k_dsupers[] = ":dsupers"; static char k_slots[] = ":slots"; static char k_gf[] = ":generic-function"; static PRIMITIVE lmake(SCM args, int len) { SCM classe, z; if (len == 0) Err("make: parameter list is null", NIL); classe = CAR(args); args = CDR(args); if (classe == Generic) { z = make_instance(classe, STk_llength(THE_SLOT_OF(classe, S_slots)), TYPE_GENERIC); THE_SLOT_OF(z, S_name) = STk_get_keyword(STk_makekey(k_name), args, Intern("???")); THE_SLOT_OF(z, S_methods) = NIL; } else { z = make_instance(classe, STk_llength(THE_SLOT_OF(classe, S_slots)), TYPE_INSTANCE); if (classe == Method || classe == Simple_method || classe == Accessor) { THE_SLOT_OF(z, S_generic_function) = STk_get_keyword(STk_makekey(k_gf), args, Ntruth); THE_SLOT_OF(z, S_specializers) = STk_get_keyword(STk_makekey(k_specializers), args, NIL); THE_SLOT_OF(z, S_procedure) = STk_get_keyword(STk_makekey(k_procedure), args, NIL); } else { /* In all the others case, make a new class .... No instance here */ THE_SLOT_OF(z, S_name) = STk_get_keyword(STk_makekey(k_name), args, Intern("???")); THE_SLOT_OF(z, S_direct_supers) = STk_get_keyword(STk_makekey(k_dsupers), args, NIL); THE_SLOT_OF(z, S_direct_slots) = STk_get_keyword(STk_makekey(k_slots), args, NIL); } } return z; } static PRIMITIVE find_method(SCM l, int len) { SCM gf; ENTER_PRIMITIVE("find-method"); if (len == 0) Serror("no parameter list", NIL); gf = CAR(l); l = CDR(l); if (NGENERICP(gf)) Serror("bad generic function", gf); if (NULLP(THE_SLOT_OF(gf, S_methods))) Serror("no methods for generic", gf); return STk_compute_applicable_methods(gf, l, len-1, TRUE); } static PRIMITIVE user_more_specificp(SCM m1, SCM m2, SCM targs) { SCM l, v; int i, len; ENTER_PRIMITIVE("%method-more-specific?"); if (NMETHODP(m1)) Serror("bad method", m1); if (NMETHODP(m2)) Serror("bad method", m2); if ((len=STk_llength(targs)) < 0) Serror("bad argument", targs); /* Verify that all the arguments of targs are classes and place them in a vector*/ v = STk_makevect(len, NIL); for (i=0, l=targs; NNULLP(l); i++, l=CDR(l)) { if (NCLASSP(CAR(l))) Serror("bad argument", targs); VECT(v)[i] = CAR(l); } return more_specificp(m1, m2, VECT(v)) ? Truth: Ntruth; } /****************************************************************************** * * Initializations * ******************************************************************************/ static void select_STklos_module(void) { STk_selected_module = STklos = STk_make_module(Intern("stklos")); } static void make_stdcls(SCM *var, char *name, SCM meta, SCM super, SCM slots) { SCM tmp = Intern(name); *var = STk_basic_make_class(meta, tmp, LIST1(super), slots); STk_gc_protect(var); DEFVAR(tmp, *var); } static void make_standard_classes(void) { SCM tmp1 = LIST3(Intern("generic-function"), Intern("specializers"), Intern("procedure")); SCM tmp2 = LIST2(Intern("name"), Intern("methods")); /* Generic functions classes */ make_stdcls(&Procedure_class, "", Class, Class, NIL); make_stdcls(&Entity_class, "", Class, Procedure_class, NIL); make_stdcls(&Method, "", Class, Object, tmp1); make_stdcls(&Simple_method, "", Class, Method, NIL); make_stdcls(&Accessor, "", Class, Simple_method, NIL); make_stdcls(&Generic, "", Entity_class, Object, tmp2); /* Primitive types classes */ make_stdcls(&Boolean, "", Class, Top, NIL); make_stdcls(&Char, "", Class, Top, NIL); make_stdcls(&Liste, "", Class, Top, NIL); make_stdcls(&Pair, "", Class, Liste, NIL); make_stdcls(&Null, "", Class, Liste, NIL); make_stdcls(&String, "", Class, Top, NIL); make_stdcls(&Symbol, "", Class, Top, NIL); make_stdcls(&Vector, "", Class, Top, NIL); make_stdcls(&Number, "", Class, Top, NIL); make_stdcls(&Real, "", Class, Number, NIL); make_stdcls(&Integer, "", Class, Real, NIL); make_stdcls(&Keyword, "", Class, Top, NIL); make_stdcls(&UnknownClass, "", Class, Top, NIL); make_stdcls(&Procedure, "", Procedure_class, Top, NIL); #ifdef USE_TK make_stdcls(&Widget, "", Procedure_class, Procedure, NIL); #endif } /** * * Definition of Extended type classes * **/ SCM STk_make_extended_class(char *name) { /* * This function is called when a new extended type is defined and returns * a new class for it. Furthermore, it defines a global variable for this class. * If STklos is not initialized, it returns NIL. * Extended types defined before initialization of STklos will be done * when STklos is inited by "define_extended_type_classes" */ if (initialized) { SCM tmp1, tmp2; char buffer[200]; sprintf(buffer, "<%s>", name); tmp1 = Intern(buffer); tmp2 = STk_basic_make_class(Class, tmp1, LIST1(Top), NIL); DEFVAR(tmp1, tmp2); return tmp2; } return NIL; } static void define_extended_type_classes(void) { /* * This function is called when STklos is initialized. It performs * the definition of classes for extended types defined before STklos * loading */ int i; initialized = TRUE; for (i = tc_start_extd; ; i++) { char *name = STk_get_extended_name(i); if (!name) return; STk_register_extended_class(STk_make_extended_class(name), i); } } static void add_primitive(char *name, int type, void *fct_ptr) { STk_add_new_primitive(name, type, fct_ptr); STk_export_symbol(Intern(name), STklos); } /*===========================================================================*/ PRIMITIVE STk_init_STklos(void) { SCM curmod = STk_selected_module; Top = Object = Class = Generic = Method = Simple_method = Accessor = NIL; select_STklos_module(); create_Top_Object_Class(); make_standard_classes(); /* Define new primitives and export them */ add_primitive("stklos-version", tc_subr_0, stklos_version); add_primitive("instance?", tc_subr_1, instancep); add_primitive("slot-ref-using-class", tc_subr_3, slot_ref_using_class); add_primitive("slot-set-using-class!", tc_lsubr, slot_set_using_class); add_primitive("slot-bound-using-class?", tc_subr_3, slot_boundp_using_class); add_primitive("slot-exists-using-class?", tc_subr_3, slot_exists_using_class); add_primitive("slot-ref", tc_subr_2, STk_slot_ref); add_primitive("slot-set!", tc_subr_3, STk_slot_set); add_primitive("slot-bound?", tc_subr_2, slot_boundp); add_primitive("class-of", tc_subr_1, class_of); add_primitive("class-name", tc_subr_1, class_name); add_primitive("class-direct-supers", tc_subr_1, class_direct_supers); add_primitive("class-direct-subclasses", tc_subr_1, class_direct_subs); add_primitive("class-direct-methods", tc_subr_1, class_direct_methods); add_primitive("class-direct-slots", tc_subr_1, class_direct_slots); add_primitive("class-precedence-list", tc_subr_1, class_cpl); add_primitive("class-slots", tc_subr_1, class_slots); add_primitive("class-environment", tc_subr_1, class_environment); add_primitive("generic-function-name", tc_subr_1, gf_name); add_primitive("generic-function-methods", tc_subr_1, gf_methods); add_primitive("method-generic-function", tc_subr_1, method_gf); add_primitive("method-specializers", tc_subr_1, method_specializers); add_primitive("method-procedure", tc_subr_1, method_procedure); add_primitive("slot-exists?", tc_subr_2, slot_existsp); add_primitive("make", tc_lsubr, lmake); add_primitive("find-method", tc_lsubr, find_method); /* Unexported primitives */ STk_add_new_primitive("%allocate-instance", tc_subr_1, STk_allocate_instance); STk_add_new_primitive("%initialize-object", tc_subr_2, initialize_object); STk_add_new_primitive("%compute-slots", tc_subr_1, compute_slots); STk_add_new_primitive("%modify-instance", tc_subr_2, modify_instance); STk_add_new_primitive("%method-more-specific?", tc_subr_3, user_more_specificp); STk_add_new_primitive("%fast-slot-ref", tc_subr_2, fast_slot_ref); STk_add_new_primitive("%fast-slot-set!", tc_subr_3, fast_slot_set); STk_add_new_primitive("%next-method-exists?", tc_subr_1, next_method_exists); /* Define classes for already defined extended type */ define_extended_type_classes(); /* Reset the default module we have to the one we have when starting inits */ STk_selected_module = curmod; return UNDEFINED; } #else /* Don't produce an empty object file since some compiler (loader?) don't * manage them correctly */ static char not_used = '?'; #endif