File contents

/* xlobj - xlisp object functions */

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;
extern struct node *xlenv;

/* external procedures */
extern struct node *xlevarg();
extern struct node *xlevmatch();

/* global variables */
struct node *self;

/* the class object pointer */
static struct node *class;
static struct node *messages;
static struct node *ivars;
static struct node *new;
static struct node *isnew;
static int init;

/* forward declarations (the extern hack is because of decusc) */
extern struct node *enterivar();

/* xlmfind - find the message binding for a message to an object */
struct node *xlmfind(obj,msym)
  struct node *obj,*msym;
{
    struct node *lptr,*msg;

    /* lookup the message */
    for (lptr = enterivar(obj->n_obclass,messages)->n_bndvalue;
	 lptr != NULL;
	 lptr = lptr->n_listnext)
	if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == msym)
	    return (msg);

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

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

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

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

    /* get the method for this message */
    method.n_ptr = msg->n_msgcode;

    /* make sure its a function or a subr */
    if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != FUN)
	xlfail("bad method");

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

    /* evaluate the function call */
    if (method.n_ptr->n_type == SUBR) {
	xlfixbindings(oldenv);
	val.n_ptr = (*method.n_ptr->n_subr)(args);
    }
    else {

	/* bind the formal arguments */
	xlabind(method.n_ptr->n_funargs,args);
	xlfixbindings(oldenv);

	/* execute the code */
	cptr.n_ptr = method.n_ptr->n_funcode;
	while (cptr.n_ptr != NULL)
	    val.n_ptr = xlevarg(&cptr.n_ptr);
    }

    /* restore the environment */
    xlunbind(oldenv);

    /* after creating an object, send it the "isnew" message */
    if (msg->n_msg == new && val.n_ptr != NULL) {
	if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
	    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) */
struct node *xlsend(obj,args)
  struct node *obj,*args;
{
    struct node *msg;

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

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

/* new - create a new object instance */
static struct node *mnew()
{
    struct node *oldstk,obj;
    struct node *cls,*lptr,*lnk,*last;

    /* 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;

    /* create a list of instance variables for the new object */
    for (lptr = enterivar(cls,ivars)->n_bndvalue, last = NULL;
	 lptr != NULL;
	 lptr = lptr->n_listnext, last = lnk) {
	lnk = newnode(LIST);
	if (last == NULL)
	    obj.n_ptr->n_obdata = lnk;
	else
	    last->n_listnext = lnk;
	lnk->n_listvalue = newnode(BND);
	lnk->n_listvalue->n_bndsym = lptr->n_listvalue;
    }

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

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

/* misnew - initialize a new class */
static struct node *misnew(args)
  struct node *args;
{
    /* make sure there aren't any arguments */
    if (args != NULL)
	xlfail("too many arguments");

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

/* enterivar - enter an instance variable */
static struct node *enterivar(obj,sym)
  struct node *obj,*sym;
{
    struct node *lptr,*vbnd;

    /* lookup the instance variable */
    for (lptr = obj->n_obdata; lptr != NULL; lptr = lptr->n_listnext)
	if ((vbnd = lptr->n_listvalue) != NULL && vbnd->n_bndsym == sym)
	    break;

    /* add the instance variable if it wasn't found */
    if (lptr == NULL) {
	if (!init)
	    printf("can't find \"%s\"\n",sym->n_symname);
	lptr = newnode(LIST);
	lptr->n_listnext = obj->n_obdata;
	obj->n_obdata = lptr;
	lptr->n_listvalue = vbnd = newnode(BND);
	vbnd->n_bndsym = sym;
    }

    /* return the binding */
    return (vbnd);
}

/* addivar - enter an instance variable */
static addivar(cls,var)
  struct node *cls; char *var;
{
    struct node *vbnd,*lptr;

    /* enter the "ivars" instance variable */
    vbnd = enterivar(cls,ivars);

    /* add the instance variable */
    lptr = newnode(LIST);
    lptr->n_listnext = vbnd->n_bndvalue;
    vbnd->n_bndvalue = lptr;
    lptr->n_listvalue = xlenter(var);
}

/* entermsg - add a message to a class */
static struct node *entermsg(cls,msg)
  struct node *cls,*msg;
{
    struct node *lptr,*mbnd,*mptr;

    /* lookup the "messages" instance variable */
    mbnd = enterivar(cls,messages);

    /* lookup the message */
    for (lptr = mbnd->n_bndvalue; lptr != NULL; lptr = lptr->n_listnext)
	if ((mptr = lptr->n_listvalue)->n_msg == msg)
	    break;

    /* allocate a new message entry if one wasn't found */
    if (lptr == NULL) {
	lptr = newnode(LIST);
	lptr->n_listnext = mbnd->n_bndvalue;
	mbnd->n_bndvalue = lptr;
	lptr->n_listvalue = mptr = newnode(MSG);
	mptr->n_msg = msg;
    }

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

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

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

    /* initialize */
    arg.n_ptr = args;

    /* message symbol */
    msg.n_ptr = xlevmatch(SYM,&arg.n_ptr);

    /* get the formal argument list */
    fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* get the code */
    code.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

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

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

    /* setup the message node */
    mptr->n_msgcode = fptr = newnode(FUN);
    fptr->n_funargs = fargs.n_ptr;
    fptr->n_funcode = code.n_ptr;

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

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

/* mivars - define a list of instance variables */
static int mivars(args)
  struct node *args;
{
    struct node *oldstk,vars,*obj,*vbnd;

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

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

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

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

    /* find the ivars instance variable */
    vbnd = enterivar(obj,ivars);
    vbnd->n_bndvalue = vars.n_ptr;

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

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

/* addmsg - add a message to a class */
static addmsg(cls,msg,code)
  struct node *cls; char *msg; int (*code)();
{
    struct node *mptr;

    /* enter the message symbol */
    mptr = entermsg(cls,xlenter(msg));

    /* store the code for this message */
    mptr->n_msgcode = newnode(SUBR);
    mptr->n_msgcode->n_subr = code;
}

/* xloinit - object function initialization routine */
xloinit()
{
    struct node *csym;

    /* set the initialization flag */
    init = TRUE;

    /* enter the object related symbols */
    messages = xlenter("messages");
    ivars = xlenter("ivars");
    new = xlenter("new");
    isnew = xlenter("isnew");
    self = xlenter("self");

    /* initialize the class object */
    csym = xlenter("class");
    class = csym->n_symvalue = newnode(OBJ);
    class->n_obclass = class;
    addivar(class,"messages");
    addivar(class,"ivars");
    addmsg(class,"new",mnew);
    addmsg(class,"answer",answer);
    addmsg(class,"ivars",mivars);
    addmsg(class,"isnew",misnew);

    /* clear the initialization flag */
    init = FALSE;
}