/* xlobj - xlisp object functions */
/*        Copyright (c) 1985, by David Michael Betz
          All Rights Reserved
          Permission is granted for unrestricted non-commercial use   */

#include "flp1_xlisp_h"

#ifdef MEGAMAX
overlay "overflow"
#endif

/* external variables */
extern NODE *xlenv;
extern NODE *s_stdout;
extern NODE *self,*class,*object;
extern NODE *new,*isnew;

/* 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 *entermsg();
FORWARD NODE *sendmsg();

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

    /* create the class */
    sym = xlsenter(name);
    cls = newobject(class,CLASSSIZE);
    setvalue(sym,cls);

    /* set the instance variable counts */
    setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
    setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));

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

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

/* xladdivar - enter an instance variable */
xladdivar(cls,var)
  NODE *cls; char *var;
{
    setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
}

/* 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,cvsubr(code,SUBR));
}

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

    /* create a new stack frame */
    oldstk = xlstack;
    xlsave1(arglist);

    /* get the message symbol */
    sym = xlevmatch(SYM,&args);

    /* evaluate the arguments */
    arglist = xlevlist(args);

    /* send the message */
    val = sendmsg(obj,getclass(obj),sym,arglist);

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

    /* return the result */
    return (val);
}

/* xlobgetvalue - get the value of an instance variable */
int xlobgetvalue(pair,sym,pval)
  NODE *pair,*sym,**pval;
{
    NODE *cls,*names;
    int ivtotal,n;

    /* find the instance or class variable */
    for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {

          /* check the instance variables */
          names = getivar(cls,IVARS);
          ivtotal = getivcnt(cls,IVARTOTAL);
          for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
              if (car(names) == sym) {
                    *pval = getivar(car(pair),n);
                    return (TRUE);
              }
              names = cdr(names);
          }

          /* check the class variables */
          names = getivar(cls,CVARS);
          for (n = 0; consp(names); ++n) {
              if (car(names) == sym) {
                    *pval = getelement(getivar(cls,CVALS),n);
                    return (TRUE);
              }
              names = cdr(names);
          }
    }

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

/* xlobsetvalue - set the value of an instance variable */
int xlobsetvalue(pair,sym,val)
  NODE *pair,*sym,*val;
{
    NODE *cls,*names;
    int ivtotal,n;

    /* find the instance or class variable */
    for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {

          /* check the instance variables */
          names = getivar(cls,IVARS);
          ivtotal = getivcnt(cls,IVARTOTAL);
          for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
              if (car(names) == sym) {
                    setivar(car(pair),n,val);
                    return (TRUE);
              }
              names = cdr(names);
          }

          /* check the class variables */
          names = getivar(cls,CVARS);
          for (n = 0; consp(names); ++n) {
              if (car(names) == sym) {
                    setelement(getivar(cls,CVALS),n,val);
                    return (TRUE);
              }
              names = cdr(names);
          }
    }

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

/* obisnew - default 'isnew' method */
LOCAL NODE *obisnew(args)
  NODE *args;
{
    xllastarg(args);
    return (xlgetvalue(self));
}

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

    /* return the object's class */
    return (getclass(xlgetvalue(self)));
}

/* obshow - show the instance variables of an object */
LOCAL NODE *obshow(args)
  NODE *args;
{
    NODE *fptr,*obj,*cls,*names;
    int ivtotal,n;

    /* get the file pointer */
    fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
    xllastarg(args);

    /* get the object and its class */
    obj = xlgetvalue(self);
    cls = getclass(obj);

    /* print the object and class */
    xlputstr(fptr,"Object is ");
    xlprint(fptr,obj,TRUE);
    xlputstr(fptr,", Class is ");
    xlprint(fptr,cls,TRUE);
    xlterpri(fptr);

    /* print the object's instance variables */
    for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
          names = getivar(cls,IVARS);
          ivtotal = getivcnt(cls,IVARTOTAL);
          for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
              xlputstr(fptr,"  ");
              xlprint(fptr,car(names),TRUE);
              xlputstr(fptr," = ");
              xlprint(fptr,getivar(obj,n),TRUE);
              xlterpri(fptr);
              names = cdr(names);
          }
    }

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

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

    /* get the object */
    obj = xlgetvalue(self);

    /* get the object's superclass */
    super = getivar(getclass(obj),SUPERCLASS);

    /* get the message selector */
    sym = xlmatch(SYM,&args);

    /* send the message */
    return (sendmsg(obj,super,sym,args));
}

/* clnew - create a new object instance */
LOCAL NODE *clnew()
{
    NODE *cls;
    cls = xlgetvalue(self);
    return (newobject(cls,getivcnt(cls,IVARTOTAL)));
}

/* clisnew - initialize a new class */
LOCAL NODE *clisnew(args)
  NODE *args;
{
    NODE *ivars,*cvars,*super,*cls;
    int n;

    /* get the ivars, cvars and superclass */
    ivars = xlmatch(LIST,&args);
    cvars = (args ? xlmatch(LIST,&args) : NIL);
    super = (args ? xlmatch(OBJ,&args) : object);
    xllastarg(args);

    /* get the new class object */
    cls = xlgetvalue(self);

    /* store the instance and class variable lists and the superclass */
    setivar(cls,IVARS,ivars);
    setivar(cls,CVARS,cvars);
    setivar(cls,CVALS,newvector(listlength(cvars)));
    setivar(cls,SUPERCLASS,super);

    /* compute the instance variable count */
    n = listlength(ivars);
    setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
    n += getivcnt(super,IVARTOTAL);
    setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));

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

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

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

    /* get the object node */
    obj = xlgetvalue(self);

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

    /* setup the message node */
    rplacd(mptr,cons(fargs,code));

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

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

    /* lookup the message */
    for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
          if (car(mptr = car(lptr)) == msg)
              return (mptr);

    /* allocate a new message entry if one wasn't found */
    oldstk = xlstack;
    xlsave1(mptr);
    mptr = consa(msg);
    setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
    xlstack = oldstk;

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

/* sendmsg - send a message to an object */
LOCAL NODE *sendmsg(obj,cls,sym,args)
  NODE *obj,*cls,*sym,*args;
{
    NODE ***oldstk,*oldenv,*newenv,*method,*ptr,*val,*isnewmsg;
    NODE *msg,*msgcls;

    /* look for the message in the class or superclasses */
    for (msgcls = cls; msgcls; ) {

          /* lookup the message in this class */
          for (ptr = getivar(msgcls,MESSAGES); ptr; ptr = cdr(ptr))
              if ((msg = car(ptr)) && car(msg) == sym)
                    goto send_message;

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

    /* message not found */
    xlerror("no method for this message",sym);

send_message:
    /* create a new stack frame */
    oldstk = xlstack;
    xlstkcheck(5);
    xlsave(oldenv);
    xlsave(newenv);
    xlsave(method);
    xlsave(ptr);
    xlsave(val);

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

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

    /* create an 'object' stack entry */
    newenv = xlframe(NIL);
    rplaca(newenv,cons(obj,msgcls));

    /* create a new environment frame */
    newenv = xlframe(newenv);
    oldenv = xlenv;

    /* bind the symbol 'self' */
    xlbind(self,obj,newenv);

    /* evaluate the function call */
    if (subrp(method)) {
          xlenv = newenv;
          val = (*getsubr(method))(args);
    }
    else {

          /* bind the formal arguments */
          xlabind(car(method),args,newenv);
          xlenv = newenv;

          /* execute the code */
          for (ptr = cdr(method); ptr; )
              val = xlevarg(&ptr);
    }

    /* restore the environment */
    xlenv = oldenv;

    /* after creating an object, send it the ":isnew" message */
    if (car(msg) == new && val)
          sendmsg(val,getclass(val),isnew,args);

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

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

/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(cls,ivar)
  NODE *cls; int ivar;
{
    NODE *cnt;
    if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
          xlfail("bad value for instance variable count");
    return ((int)getfixnum(cnt));
}

/* listlength - find the length of a list */
LOCAL int listlength(list)
  NODE *list;
{
    int len;
    for (len = 0; consp(list); len++)
          list = cdr(list);
    return (len);
}

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

    /* enter the object related symbols */
    self  = xlsenter("SELF");
    new             = xlsenter(":NEW");
    isnew = xlsenter(":ISNEW");

    /* create the 'Class' object */
    class = xlclass("CLASS",CLASSSIZE);
    setelement(class,0,class);

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

    /* finish initializing 'class' */
    setivar(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",clnew);
    xladdmsg(class,":ISNEW",clisnew);
    xladdmsg(class,":ANSWER",clanswer);

    /* finish initializing 'object' */
    xladdmsg(object,":ISNEW",obisnew);
    xladdmsg(object,":CLASS",obclass);
    xladdmsg(object,":SHOW",obshow);
    xladdmsg(object,":SENDSUPER",obsendsuper);
}