/* xlobj - xlisp object functions */

#include "xlisp.h"

#ifdef MEGAMAX
overlay "overflow"
#endif

/* external variables */
extern NODE *xlstack;
extern NODE *xlenv,*xlnewenv;
extern NODE *s_stdout;
extern NODE *self;
extern NODE *class;
extern NODE *object;
extern NODE *new;
extern NODE *isnew;
extern NODE *msgcls;
extern NODE *msgclass;
extern int varcnt;

/* instance variable numbers for the class 'Class' */
#define MESSAGES	0	/* list of messages */
#define IVARS		1	/* list of instance variable names */
#define CVARS		2	/* list of class variable names */
#define CVALS		3	/* list of class variable values */
#define SUPERCLASS	4	/* pointer to the superclass */
#define IVARCNT		5	/* number of class instance variables */
#define IVARTOTAL	6	/* total number of instance variables */

/* number of instance variables for the class 'Class' */
#define CLASSSIZE	7

/* forward declarations */
FORWARD NODE *xlgetivar();
FORWARD NODE *xlsetivar();
FORWARD NODE *xlivar();
FORWARD NODE *xlcvar();
FORWARD NODE *findmsg();
FORWARD NODE *findvar();
FORWARD NODE *defvars();
FORWARD NODE *makelist();

/* xlclass - define a class */
NODE *xlclass(name,vcnt)
  char *name; int vcnt;
{
    NODE *sym,*cls;

    /* create the class */
    sym = xlsenter(name);
    cls = sym->n_symvalue = newnode(OBJ);
    cls->n_obclass = class;
    cls->n_obdata = makelist(CLASSSIZE);

    /* set the instance variable counts */
    if (vcnt > 0) {
	xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
	xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
    }

    /* set the superclass to 'Object' */
    xlsetivar(cls,SUPERCLASS,object);

    /* return the new class */
    return (cls);
}

/* xlmfind - find the message binding for a message to an object */
NODE *xlmfind(obj,msym)
  NODE *obj,*msym;
{
    return (findmsg(obj->n_obclass,msym));
}

/* xlxsend - send a message to an object */
NODE *xlxsend(obj,msg,args)
  NODE *obj,*msg,*args;
{
    NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;

    /* save the old environment */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;

    /* create a new stack frame */
    oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);

    /* get the method for this message */
    method.n_ptr = cdr(msg);

    /* make sure its a function or a subr */
    if (!subrp(method.n_ptr) && !consp(method.n_ptr))
	xlfail("bad method");

    /* bind the symbols 'self' and 'msgclass' */
    xlbind(self,obj);
    xlbind(msgclass,msgcls);

    /* evaluate the function call */
    eargs.n_ptr = xlevlist(args);
    if (subrp(method.n_ptr)) {
	xlfixbindings();
	val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
    }
    else {

	/* bind the formal arguments */
	xlabind(car(method.n_ptr),eargs.n_ptr);
	xlfixbindings();

	/* execute the code */
	cptr.n_ptr = cdr(method.n_ptr);
	while (cptr.n_ptr != NIL)
	    val.n_ptr = xlevarg(&cptr.n_ptr);
    }

    /* restore the environment */
    xlunbind(oldenv); xlnewenv = oldnewenv;

    /* after creating an object, send it the "isnew" message */
    if (car(msg) == new && val.n_ptr != NIL) {
	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
	    xlfail("no method for the isnew message");
	val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* xlsend - send a message to an object (message in arg list) */
NODE *xlsend(obj,args)
  NODE *obj,*args;
{
    NODE *msg;

    /* find the message binding for this message */
    if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* xlobsym - find a class or instance variable for the current object */
NODE *xlobsym(sym)
  NODE *sym;
{
    NODE *obj;

    if ((obj = self->n_symvalue) != NIL && objectp(obj))
	return (findvar(obj,sym));
    else
	return (NIL);
}

/* mnew - create a new object instance */
LOCAL NODE *mnew()
{
    NODE *oldstk,obj,*cls;

    /* create a new stack frame */
    oldstk = xlsave(&obj,NULL);

    /* get the class */
    cls = self->n_symvalue;

    /* generate a new object */
    obj.n_ptr = newnode(OBJ);
    obj.n_ptr->n_obclass = cls;
    obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj.n_ptr);
}

/* misnew - initialize a new class */
LOCAL NODE *misnew(args)
  NODE *args;
{
    NODE *oldstk,super,*obj;

    /* create a new stack frame */
    oldstk = xlsave(&super,NULL);

    /* get the superclass if there is one */
    if (args != NIL)
	super.n_ptr = xlmatch(OBJ,&args);
    else
	super.n_ptr = object;
    xllastarg(args);

    /* get the object */
    obj = self->n_symvalue;

    /* store the superclass */
    xlsetivar(obj,SUPERCLASS,super.n_ptr);
    xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
        getivcnt(super.n_ptr,IVARTOTAL);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new object */
    return (obj);
}

/* xladdivar - enter an instance variable */
xladdivar(cls,var)
  NODE *cls; char *var;
{
    NODE *ivar,*lptr;

    /* find the 'ivars' instance variable */
    ivar = xlivar(cls,IVARS);

    /* add the instance variable */
    lptr = newnode(LIST);
    rplacd(lptr,car(ivar));
    rplaca(ivar,lptr);
    rplaca(lptr,xlsenter(var));
}

/* entermsg - add a message to a class */
LOCAL NODE *entermsg(cls,msg)
  NODE *cls,*msg;
{
    NODE *ivar,*lptr,*mptr;

    /* find the 'messages' instance variable */
    ivar = xlivar(cls,MESSAGES);

    /* lookup the message */
    for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
	if (car(mptr = car(lptr)) == msg)
	    return (mptr);

    /* allocate a new message entry if one wasn't found */
    lptr = newnode(LIST);
    rplacd(lptr,car(ivar));
    rplaca(ivar,lptr);
    rplaca(lptr,mptr = newnode(LIST));
    rplaca(mptr,msg);

    /* return the symbol node */
    return (mptr);
}

/* answer - define a method for answering a message */
LOCAL NODE *answer(args)
  NODE *args;
{
    NODE *oldstk,arg,msg,fargs,code;
    NODE *obj,*mptr,*fptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* message symbol, formal argument list and code */
    msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
    code.n_ptr = xlmatch(LIST,&arg.n_ptr);
    xllastarg(arg.n_ptr);

    /* get the object node */
    obj = self->n_symvalue;

    /* make a new message list entry */
    mptr = entermsg(obj,msg.n_ptr);

    /* setup the message node */
    rplacd(mptr,fptr = newnode(LIST));
    rplaca(fptr,fargs.n_ptr);
    rplacd(fptr,code.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the object */
    return (obj);
}

/* mivars - define the list of instance variables */
LOCAL NODE *mivars(args)
  NODE *args;
{
    NODE *cls,*super;
    int scnt;

    /* define the list of instance variables */
    cls = defvars(args,IVARS);

    /* get the superclass instance variable count */
    if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
	scnt = getivcnt(super,IVARTOTAL);
    else
	scnt = 0;

    /* save the number of instance variables */
    xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
    xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;

    /* return the class */
    return (cls);
}

/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(cls,ivar)
  NODE *cls; int ivar;
{
    NODE *cnt;

    if ((cnt = xlgetivar(cls,ivar)) != NIL)
	if (fixp(cnt))
	    return (cnt->n_int);
	else
	    xlfail("bad value for instance variable count");
    else
	return (0);
}

/* mcvars - define the list of class variables */
LOCAL NODE *mcvars(args)
  NODE *args;
{
    NODE *cls;

    /* define the list of class variables */
    cls = defvars(args,CVARS);

    /* make a new list of values */
    xlsetivar(cls,CVALS,makelist(varcnt));

    /* return the class */
    return (cls);
}

/* defvars - define a class or instance variable list */
LOCAL NODE *defvars(args,varnum)
  NODE *args; int varnum;
{
    NODE *oldstk,vars,*vptr,*cls,*sym;

    /* create a new stack frame */
    oldstk = xlsave(&vars,NULL);

    /* get ivar list */
    vars.n_ptr = xlmatch(LIST,&args);
    xllastarg(args);

    /* get the class node */
    cls = self->n_symvalue;

    /* check each variable in the list */
    varcnt = 0;
    for (vptr = vars.n_ptr;
	 consp(vptr);
	 vptr = cdr(vptr)) {

	/* make sure this is a valid symbol in the list */
	if ((sym = car(vptr)) == NIL || !symbolp(sym))
	    xlfail("bad variable list");

	/* make sure its not already defined */
	if (checkvar(cls,sym))
	    xlfail("multiply defined variable");

	/* count the variable */
	varcnt++;
    }

    /* make sure the list ended properly */
    if (vptr != NIL)
	xlfail("bad variable list");

    /* define the new variable list */
    xlsetivar(cls,varnum,vars.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the class */
    return (cls);
}

/* xladdmsg - add a message to a class */
xladdmsg(cls,msg,code)
  NODE *cls; char *msg; NODE *(*code)();
{
    NODE *mptr;

    /* enter the message selector */
    mptr = entermsg(cls,xlsenter(msg));

    /* store the method for this message */
    rplacd(mptr,newnode(SUBR));
    cdr(mptr)->n_subr = code;
}

/* getclass - get the class of an object */
LOCAL NODE *getclass(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object's class */
    return (self->n_symvalue->n_obclass);
}

/* obshow - show the instance variables of an object */
LOCAL NODE *obshow(args)
  NODE *args;
{
    NODE *fptr;

    /* get the file pointer */
    fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the object's instance variables */
    xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
    xlterpri(fptr);

    /* return the object */
    return (self->n_symvalue);
}

/* defisnew - default 'isnew' method */
LOCAL NODE *defisnew(args)
  NODE *args;
{
    /* make sure there aren't any arguments */
    xllastarg(args);

    /* return the object */
    return (self->n_symvalue);
}

/* sendsuper - send a message to an object's superclass */
LOCAL NODE *sendsuper(args)
  NODE *args;
{
    NODE *obj,*super,*msg;

    /* get the object */
    obj = self->n_symvalue;

    /* get the object's superclass */
    super = xlgetivar(obj->n_obclass,SUPERCLASS);

    /* find the message binding for this message */
    if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
	xlfail("no method for this message");

    /* send the message */
    return (xlxsend(obj,msg,args));
}

/* findmsg - find the message binding given an object and a class */
LOCAL NODE *findmsg(cls,sym)
  NODE *cls,*sym;
{
    NODE *lptr,*msg;

    /* start at the specified class */
    msgcls = cls;

    /* look for the message in the class or superclasses */
    while (msgcls != NIL) {

	/* lookup the message in this class */
	for (lptr = xlgetivar(msgcls,MESSAGES);
	     lptr != NIL;
	     lptr = cdr(lptr))
	    if ((msg = car(lptr)) != NIL && car(msg) == sym)
		return (msg);

	/* look in class's superclass */
	msgcls = xlgetivar(msgcls,SUPERCLASS);
    }

    /* message not found */
    return (NIL);
}

/* findvar - find a class or instance variable */
LOCAL NODE *findvar(obj,sym)
  NODE *obj,*sym;
{
    NODE *cls,*lptr;
    int base,varnum;
    int found;

    /* get the class of the object */
    cls = obj->n_obclass;

    /* get the total number of instance variables */
    base = getivcnt(cls,IVARTOTAL);

    /* find the variable */
    found = FALSE;
    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {

	/* get the number of instance variables for this class */
	if ((base -= getivcnt(cls,IVARCNT)) < 0)
	    xlfail("error finding instance variable");

	/* check for finding the class of the current message */
	if (!found && cls == msgclass->n_symvalue)
	    found = TRUE;

	/* lookup the instance variable */
	varnum = 0;
	for (lptr = xlgetivar(cls,IVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (found && car(lptr) == sym)
		return (xlivar(obj,base + varnum));
	    else
		varnum++;

	/* skip the class variables if the message class hasn't been found */
	if (!found)
	    continue;

	/* lookup the class variable */
	varnum = 0;
	for (lptr = xlgetivar(cls,CVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (xlcvar(cls,varnum));
	    else
		varnum++;
    }

    /* variable not found */
    return (NIL);
}

/* checkvar - check for an existing class or instance variable */
LOCAL int checkvar(cls,sym)
  NODE *cls,*sym;
{
    NODE *lptr;

    /* find the variable */
    for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {

	/* lookup the instance variable */
	for (lptr = xlgetivar(cls,IVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (TRUE);

	/* lookup the class variable */
	for (lptr = xlgetivar(cls,CVARS);
    	     lptr != NIL;
    	     lptr = cdr(lptr))
	    if (car(lptr) == sym)
		return (TRUE);
    }

    /* variable not found */
    return (FALSE);
}

/* xlgetivar - get the value of an instance variable */
NODE *xlgetivar(obj,num)
  NODE *obj; int num;
{
    return (car(xlivar(obj,num)));
}

/* xlsetivar - set the value of an instance variable */
NODE *xlsetivar(obj,num,val)
  NODE *obj; int num; NODE *val;
{
    rplaca(xlivar(obj,num),val);
    return (val);
}

/* xlivar - get an instance variable */
NODE *xlivar(obj,num)
  NODE *obj; int num;
{
    NODE *ivar;

    /* get the instance variable */
    for (ivar = obj->n_obdata; num > 0; num--)
	if (ivar != NIL)
	    ivar = cdr(ivar);
	else
	    xlfail("bad instance variable list");

    /* return the instance variable */
    return (ivar);
}

/* xlcvar - get a class variable */
NODE *xlcvar(cls,num)
  NODE *cls; int num;
{
    NODE *cvar;

    /* get the class variable */
    for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
	if (cvar != NIL)
	    cvar = cdr(cvar);
	else
	    xlfail("bad class variable list");

    /* return the class variable */
    return (cvar);
}

/* makelist - make a list of nodes */
LOCAL NODE *makelist(cnt)
  int cnt;
{
    NODE *oldstk,list,*lnew;

    /* create a new stack frame */
    oldstk = xlsave(&list,NULL);

    /* make the list */
    for (; cnt > 0; cnt--) {
	lnew = newnode(LIST);
	rplacd(lnew,list.n_ptr);
	list.n_ptr = lnew;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* xloinit - object function initialization routine */
xloinit()
{
    /* don't confuse the garbage collector */
    class = object = NIL;

    /* enter the object related symbols */
    new		= xlsenter("new");
    isnew	= xlsenter("isnew");
    self	= xlsenter("self");
    msgclass	= xlsenter("msgclass");

    /* create the 'Class' object */
    class = xlclass("Class",CLASSSIZE);
    class->n_obclass = class;

    /* create the 'Object' object */
    object = xlclass("Object",0);

    /* finish initializing 'class' */
    xlsetivar(class,SUPERCLASS,object);
    xladdivar(class,"ivartotal");	/* ivar number 6 */
    xladdivar(class,"ivarcnt");		/* ivar number 5 */
    xladdivar(class,"superclass");	/* ivar number 4 */
    xladdivar(class,"cvals");		/* ivar number 3 */
    xladdivar(class,"cvars");		/* ivar number 2 */
    xladdivar(class,"ivars");		/* ivar number 1 */
    xladdivar(class,"messages");	/* ivar number 0 */
    xladdmsg(class,"new",mnew);
    xladdmsg(class,"answer",answer);
    xladdmsg(class,"ivars",mivars);
    xladdmsg(class,"cvars",mcvars);
    xladdmsg(class,"isnew",misnew);

    /* finish initializing 'object' */
    xladdmsg(object,"class",getclass);
    xladdmsg(object,"show",obshow);
    xladdmsg(object,"isnew",defisnew);
    xladdmsg(object,"sendsuper",sendsuper);
}