/*********************************************************************************
 * Package   : c-resolv.c
 * Author    : Hans Oesterholt-Dijkema.
 * Copyright : HOD 2004/2005.
 * License   : LGPL
 * CVS       : $Id: c-roos.c,v 1.4.2.2 2005/12/28 22:55:03 HansOesterholt Exp $
 *********************************************************************************
 $Log: c-roos.c,v $
 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 <escheme.h>

#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;i<N;i++) {
	car=scheme_car(supers);
	supers=scheme_cdr(supers);
	obj->supers[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;i<N;i++) {
      Scheme_Object *argv[]={ (Scheme_Object *) object->supers[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;i<N && !ROOS_EQ(symbol,roos->member_names[i]);i++);
  }

  if (i==N) {
    Scheme_Object *obj=NULL;
    N=roos->nsupers;
    for(i=0;i<N && (obj=c_roos_find_member(roos->supers[i],symbol,0))==NULL;i++);
    if (!obj) {
      for(i=0,N=roos->nproxies;i<N && (obj=c_roos_find_member(roos->proxies[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;i<N && (ok=c_class_is_intern(roos->supers[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;i<N;i++) {
      roos->member_names[i]=NULL;
      roos->member_types[i]=NULL;
      roos->members[i]=NULL;
    }

    for(i=0,N=roos->nsupers;i<N;i++) {
      roos->supers[i]=NULL;
    }

    for(i=0,N=roos->nproxies;i<N;i++) {
      roos->proxies[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;i<N;i++) {
      supers[i]=c_roos_class(1,(Scheme_Object **) &roos->supers[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;i<N;i++) {
      c_roos_set_this_internal(obj->supers[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");
}