/********************************************************************************* * Package : c-resolv.c * Author : Hans Oesterholt-Dijkema. * Copyright : HOD 2004/2005. * License : LGPL * CVS : $Id: c-roos.c,v 1.1.1.1 2006/05/20 11:40:10 hoesterholt Exp $ ********************************************************************************* $Log: c-roos.c,v $ Revision 1.1.1.1 2006/05/20 11:40:10 hoesterholt ROOS Object System Revision 1.4.2.2 2005/12/28 22:55:03 HansOesterholt Made roos ready for PLT distribution Revision 1.4.2.1 2005/11/06 17:35:08 HansOesterholt ROOS has been fully reprogrammed for mzscheme.\nA new type "#roos" has been made,\nand the main administrative functions have been recoded in C,\nwhich makes ROOS a lot faster. *********************************************************************************/ #include #ifdef _WIN32 #define alloca _alloca #endif #ifndef SCHEME_STR_VAL /* This is mzscheme 30x */ # define MZSCHEME3 # define SCHEME_STR_VAL(obj) SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(obj)) # define EQ_CTYPE(cobj,type) (SCHEME_CPTR_TYPE(cobj)==type) # define IS_STRINGP(obj) SCHEME_CHAR_STRINGP(obj) #else /* this is mzscheme 20x */ # define EQ_CTYPE(cobj,type) strcmp(SCHEME_CPTR_TYPE(cobj),type)==0 # define IS_STRINGP(obj) SCHEME_STRINGP(obj) #endif /********************************************************************************************************* * Supportive functions *********************************************************************************************************/ static void *roos_realloc(void *mem,int from_size,int to_size) { void *newmem=scheme_malloc(to_size); if (mem!=NULL) { memcpy(newmem,mem,from_size); memset(mem,from_size,0); } return newmem; } /********************************************************************************************************* * Types, Symbols, Constants, C macros and C types. *********************************************************************************************************/ #define ADD_MEMBERS 5 #define ROOS_EQ(a,b) (a==b) #define IS_ROOS_OBJECT(a) (SCHEME_TYPE(a)==roos_type) #define IS_ROOS_SUPER(a) (((t_roos *) a)->object_type==TYPE_SUPER) #define ROOS_PUBLIC(a) (a==roos_public) #define ROOS_PRIVATE(a) (a==roos_private) #define IS_ROOS_VALID(a) (a->object_valid==ROOS_VALID) #define IS_ROOS_INVALID(a) (a->object_valid==ROOS_INVALID) #define TYPE_SUPER 1 #define TYPE_THIS 2 #define ROOS_INVALID 1 #define ROOS_VALID 2 static Scheme_Type roos_type; static Scheme_Object *roos_public; static Scheme_Object *roos_private; #define CHECK_ROOS_VALID(obj,funcn,arg,argc,argv) \ if (IS_ROOS_INVALID(obj)) { \ scheme_signal_error("ROOS:%s object has been invalidated (argument %d)",funcn,arg); \ } typedef struct s_t_roos { union { Scheme_Type type; Scheme_Object dummy; } t; int object_type; /* this holds the object_type (supers or this). */ int object_valid; struct s_t_roos **supers; int nsupers; struct s_t_roos **proxies; int nproxies; Scheme_Object **member_names; Scheme_Object **member_types; Scheme_Object **members; Scheme_Object *class_name; Scheme_Object *this_setter; int nmembers; int imember; } t_roos; typedef struct { union { Scheme_Type type; Scheme_Object dummy; } t; int object_type; /* this holds the object_type (supers or this). */ t_roos *this; /* A pointer to the this object */ } t_roos_super; static Scheme_Object *c_roos_new(int argc,Scheme_Object *argv[]) { Scheme_Object *class_name=argv[0]; Scheme_Object *this_setter=argv[1]; Scheme_Object *supers=argv[2]; if (!SCHEME_SYMBOLP(class_name)) { scheme_wrong_type("c-roos-new","symbol",0,argc,argv); } if (!SCHEME_PROCP(this_setter)) { scheme_wrong_type("c-roos-new","procedure",1,argc,argv); } if (!SCHEME_LISTP(supers)) { scheme_wrong_type("c-roos-new","list",2,argc,argv); } { t_roos *obj=(t_roos *) scheme_malloc(sizeof(t_roos)); { int i,N=scheme_list_length(supers); Scheme_Object *car; obj->nsupers=N; obj->supers=(t_roos **) scheme_malloc(N*sizeof(Scheme_Object *)); for(i=0;isupers[i]=(t_roos *) car; } } obj->object_type=TYPE_THIS; /* Default objects are always of type this */ obj->t.type=roos_type; obj->member_types=NULL; obj->member_names=NULL; obj->members=NULL; obj->nmembers=0; obj->imember=0; obj->class_name=class_name; obj->this_setter=this_setter; obj->object_valid=ROOS_VALID; obj->proxies=NULL; obj->nproxies=0; return (Scheme_Object *) obj; } } static Scheme_Object *c_roos_new_super(int argc,Scheme_Object *argv[]) { t_roos *object=(t_roos *) argv[0]; if (!IS_ROOS_OBJECT(object)) { scheme_wrong_type("c-roos-new-super","#roos",0,argc,argv); } if (IS_ROOS_SUPER(object)) { scheme_signal_error("ROOS:c-roos-new-super cannot act on a #roos super object"); } CHECK_ROOS_VALID(object,"c-roos-new-super",0,argc,argv); { t_roos_super *super=(t_roos_super *) scheme_malloc(sizeof(t_roos_super)); super->object_type=TYPE_SUPER; super->this=object; super->t.type=roos_type; return (Scheme_Object *) super; } } static Scheme_Object *c_roos_supers_for_each(int argc,Scheme_Object *argv[]) { t_roos *object=(t_roos *) argv[0]; Scheme_Object *closure=argv[1]; if (!IS_ROOS_OBJECT(object)) { scheme_wrong_type("c-roos-supers-for-each","#roos",0,argc,argv); } if (IS_ROOS_SUPER(object)) { scheme_signal_error("ROOS:c-roos-supers-for-each cannot act on a #roos super object"); } CHECK_ROOS_VALID(object,"c-roos-supers-for-each",0,argc,argv); if (!SCHEME_PROCP(closure)) { scheme_wrong_type("c-roos-supers-for-each","procedure",1,argc,argv); } { int i,N; for(i=0,N=object->nsupers;isupers[i] }; int argc=1; /*printf("supers: %d,%d\n",i,N);*/ _scheme_apply(closure,argc,argv); } } return (Scheme_Object *) object; } static Scheme_Object *c_roos_add_member(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; Scheme_Object *type=argv[1]; Scheme_Object *name=argv[2]; Scheme_Object *closure=argv[3]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-add-member","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { scheme_signal_error("ROOS:c-roos-add-member cannot act on a #roos super object"); } CHECK_ROOS_VALID(roos,"c-roos-add-member",0,argc,argv); if (!SCHEME_SYMBOLP(type)) { scheme_wrong_type("c-roos-add-member","symbol ('public or 'private)",1,argc,argv); } else { if (!(ROOS_PUBLIC(type) || ROOS_PRIVATE(type))) { scheme_wrong_type("c-roos-add-member","symbol ('public or 'private)",1,argc,argv); } } if (!SCHEME_SYMBOLP(name)) { scheme_wrong_type("c-roos-add-member","symbol",2,argc,argv); } if (!SCHEME_PROCP(closure)) { scheme_wrong_type("c-roos-add-member","procedure",2,argc,argv); } if (roos->imember==roos->nmembers) { int cn=roos->nmembers; { register int add=roos->nmembers*2+ADD_MEMBERS; roos->nmembers+=(add<=50) ? add : 50 ; } roos->member_types=(Scheme_Object **) roos_realloc(roos->member_types, cn*sizeof(Scheme_Object *), roos->nmembers*sizeof(Scheme_Object *) ); roos->member_names=(Scheme_Object **) roos_realloc(roos->member_names, cn*sizeof(Scheme_Object *), roos->nmembers*sizeof(Scheme_Object *) ); roos->members=(Scheme_Object **) roos_realloc(roos->members, cn*sizeof(Scheme_Object *), roos->nmembers*sizeof(Scheme_Object *) ); } { int i=roos->imember; roos->member_types[i]=type; roos->member_names[i]=name; roos->members[i]=closure; roos->imember+=1; } return (Scheme_Object *) roos; } static Scheme_Object *c_roos_add_proxy(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; t_roos *object=(t_roos *) argv[1]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-class-is","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { scheme_signal_error("ROOS:c-roos-add-proxy cannot act on a #roos super object"); } CHECK_ROOS_VALID(roos,"c-roos-add-proxy",0,argc,argv); if (!IS_ROOS_OBJECT(object)) { scheme_wrong_type("c-roos-add-proxy","#roos",1,argc,argv); } if (IS_ROOS_SUPER(object)) { scheme_wrong_type("c-roos-add-proxy","#roos(super)",1,argc,argv); } CHECK_ROOS_VALID(object,"c-roos-add-proxy",1,argc,argv); { int I=roos->nproxies; roos->nproxies+=1; roos->proxies=(t_roos **) roos_realloc(roos->proxies, I*sizeof(Scheme_Object *), roos->nproxies*sizeof(Scheme_Object *) ); roos->proxies[I]=object; } return (Scheme_Object *) roos; } static Scheme_Object *c_roos_find_member(t_roos *roos,Scheme_Object *symbol,int only_in_supers) { int i,N=roos->imember; if (only_in_supers) { i=N; } else { for(i=0,N=roos->imember;imember_names[i]);i++); } if (i==N) { Scheme_Object *obj=NULL; N=roos->nsupers; for(i=0;isupers[i],symbol,0))==NULL;i++); if (!obj) { for(i=0,N=roos->nproxies;iproxies[i],symbol,0))==NULL;i++); } return obj; } else { if (ROOS_PUBLIC(roos->member_types[i])) { return roos->members[i]; } else { scheme_signal_error("ROOS:member function '%s' is not public",SCHEME_SYM_VAL(symbol)); return NULL; } } } static Scheme_Object *c_roos_call_member(int argc,Scheme_Object *argv[]) { t_roos *roos =(t_roos *) argv[0]; Scheme_Object *symbol =argv[1]; Scheme_Object *closure; int only_in_supers =0; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-call-member","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; only_in_supers=1; } CHECK_ROOS_VALID(roos,"c-roos-call-member",0,argc,argv); if (!SCHEME_SYMBOLP(symbol)) { scheme_wrong_type("c-roos-call-member","symbol",1,argc,argv); } closure=c_roos_find_member(roos,symbol,only_in_supers); if (closure==NULL) { scheme_signal_error("ROOS:Cannot find member '%s'",SCHEME_SYM_VAL(symbol)); } return scheme_tail_apply(closure,argc-2,&argv[2]); } static Scheme_Object *c_roos_get_member(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; Scheme_Object *symbol =argv[1]; Scheme_Object *closure; int only_in_supers =0; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-get-member","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; only_in_supers=1; } CHECK_ROOS_VALID(roos,"c-roos-get-member",0,argc,argv); if (!SCHEME_SYMBOLP(symbol)) { scheme_wrong_type("c-roos-get-member","symbol",1,argc,argv); } closure=c_roos_find_member(roos,symbol,only_in_supers); if (closure==NULL) { scheme_signal_error("ROOS:Cannot find member '%s'",SCHEME_SYM_VAL(symbol)); } return closure; } static Scheme_Object *c_class_is_intern(t_roos *roos,Scheme_Object *class_name) { if (ROOS_EQ(roos->class_name,class_name)) { return scheme_true; } else { int i,N=roos->nsupers; Scheme_Object *ok=NULL; for(i=0;isupers[i],class_name))==NULL;i++); return ok; } } static Scheme_Object *c_roos_class_is(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; Scheme_Object *class_name=argv[1]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-class-is","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; } CHECK_ROOS_VALID(roos,"c-roos-class-is",0,argc,argv); if (!SCHEME_SYMBOLP(class_name)) { scheme_wrong_type("c-roos-class-is","symbol",1,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; } if (c_class_is_intern(roos,class_name)==NULL) { return scheme_false; } else { return scheme_true; } } static Scheme_Object *c_roos_is_object(int argc,Scheme_Object *argv[]) { if (IS_ROOS_OBJECT(argv[0])) { return scheme_true; } else { return scheme_false; } } static Scheme_Object *c_roos_is_valid(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-class-is","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; } if (IS_ROOS_VALID(roos)) { return scheme_true; } else { return scheme_false; } } static Scheme_Object *c_roos_invalidate(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-class-invalidate","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { scheme_signal_error("ROOS:c-roos-invalidate cannot act on a #roos super object"); } CHECK_ROOS_VALID(roos,"c-roos-call-invalidate",0,argc,argv); roos->object_valid=ROOS_INVALID; { int i,N; for(i=0,N=roos->imember;imember_names[i]=NULL; roos->member_types[i]=NULL; roos->members[i]=NULL; } for(i=0,N=roos->nsupers;isupers[i]=NULL; } for(i=0,N=roos->nproxies;iproxies[i]=NULL; } roos->this_setter=NULL; roos->supers=NULL; roos->supers=NULL; roos->member_names=NULL; roos->member_types=NULL; roos->members=NULL; roos->imember=0; roos->nmembers=0; roos->nsupers=0; roos->nproxies=0; } return (Scheme_Object *) roos; } static Scheme_Object *c_roos_class(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-class","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { roos=((t_roos_super *) roos)->this; } CHECK_ROOS_VALID(roos,"c-roos-class",0,argc,argv); { int i,N=roos->nsupers; Scheme_Object *me; Scheme_Object **supers=alloca(sizeof(Scheme_Object *)*N); me=roos->class_name; for(i=0;isupers[i]); } { Scheme_Object *objs[2]={ me, scheme_build_list(N,supers) }; return scheme_build_list(2,objs); } } } static void c_roos_set_this_internal(t_roos *obj,t_roos *this) { _scheme_apply(obj->this_setter,1,(Scheme_Object **) &this); { int i,N; for(i=0,N=obj->nsupers;isupers[i],this); } } } static Scheme_Object *c_roos_set_this(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; t_roos *this=(t_roos *) argv[1]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-set-this","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { scheme_signal_error("ROOS:c-roos-set-this cannot act on a #roos super object"); } CHECK_ROOS_VALID(roos,"c-roos-set-this",0,argc,argv); if (!IS_ROOS_OBJECT(this)) { scheme_wrong_type("c-roos-set-this","#roos",1,argc,argv); } c_roos_set_this_internal(roos,this); return scheme_true; } Scheme_Object *c_roos_id(int argc,Scheme_Object *argv[]) { t_roos *roos=(t_roos *) argv[0]; t_roos *this=(t_roos *) argv[1]; if (!IS_ROOS_OBJECT(roos)) { scheme_wrong_type("c-roos-id","#roos",0,argc,argv); } if (IS_ROOS_SUPER(roos)) { scheme_signal_error("ROOS:c-roos-id cannot act on a #roos super object"); } { int p=(int) roos; if (IS_ROOS_INVALID(roos)) { p=p*-1; } return scheme_make_integer(p); } } Scheme_Object *scheme_reload(Scheme_Env *env) { Scheme_Env *menv; Scheme_Object *proc; menv = scheme_primitive_module(scheme_intern_symbol("c-roos"),env); proc = scheme_make_prim_w_arity(c_roos_new, "c-roos-new", 3, 3); scheme_add_global("c-roos-new", proc, menv); proc = scheme_make_prim_w_arity(c_roos_add_member, "c-roos-add-member", 4, 4); scheme_add_global("c-roos-add-member", proc, menv); proc = scheme_make_prim_w_arity(c_roos_add_proxy, "c-roos-add-proxy", 2, 2); scheme_add_global("c-roos-add-proxy", proc, menv); proc = scheme_make_prim_w_arity(c_roos_new_super, "c-roos-new-super", 1, 1); scheme_add_global("c-roos-new-super", proc, menv); proc = scheme_make_prim_w_arity(c_roos_call_member, "c-roos-call-member", 2, -1); scheme_add_global("c-roos-call-member", proc, menv); proc = scheme_make_prim_w_arity(c_roos_get_member, "c-roos-get-member", 2, 2); scheme_add_global("c-roos-get-member", proc, menv); proc = scheme_make_prim_w_arity(c_roos_supers_for_each, "c-roos-supers-for-each", 2, 2); scheme_add_global("c-roos-supers-for-each", proc, menv); proc = scheme_make_prim_w_arity(c_roos_class_is, "c-roos-class-is", 2, 2); scheme_add_global("c-roos-class-is", proc, menv); proc = scheme_make_prim_w_arity(c_roos_class, "c-roos-class", 1, 1); scheme_add_global("c-roos-class", proc, menv); proc = scheme_make_prim_w_arity(c_roos_is_object, "c-roos-is-object", 1, 1); scheme_add_global("c-roos-is-object", proc, menv); scheme_add_global("object?", proc, menv); proc = scheme_make_prim_w_arity(c_roos_set_this, "c-roos-set-this", 2, 2); scheme_add_global("c-roos-set-this", proc, menv); proc = scheme_make_prim_w_arity(c_roos_invalidate, "c-roos-invalidate", 1, 1); scheme_add_global("c-roos-invalidate", proc, menv); proc = scheme_make_prim_w_arity(c_roos_is_valid, "c-roos-is-valid", 1, 1); scheme_add_global("c-roos-is-valid", proc, menv); scheme_add_global("c-roos-valid?", proc, menv); proc = scheme_make_prim_w_arity(c_roos_id, "c-roos-id", 1, 1); scheme_add_global("c-roos-id", proc, menv); scheme_add_global("roos-id", proc, menv); scheme_finish_primitive_module(menv); return scheme_void; } Scheme_Object *scheme_initialize(Scheme_Env *env) { roos_type=scheme_make_type("roos"); roos_public=scheme_intern_symbol("public"); roos_private=scheme_intern_symbol("private"); return scheme_reload(env); } Scheme_Object *scheme_module_name(void) { return scheme_intern_symbol("c-roos"); }