home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / xlisp / xlisp11.ark / XLOBJ.C < prev    next >
Text File  |  1986-10-12  |  18KB  |  698 lines
  1. /* xlobj - xlisp object functions */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* global variables */
  12. struct node *self;
  13.  
  14. /* external variables */
  15. extern struct node *xlstack;
  16. extern struct node *xlenv;
  17.  
  18. /* local variables */
  19. static struct node *class;
  20. static struct node *object;
  21. static struct node *new;
  22. static struct node *isnew;
  23. static struct node *msgcls;
  24. static struct node *msgclass;
  25. static int varcnt;
  26.  
  27. /* instance variable numbers for the class 'Class' */
  28. #define MESSAGES    0    /* list of messages */
  29. #define IVARS        1    /* list of instance variable names */
  30. #define CVARS        2    /* list of class variable names */
  31. #define CVALS        3    /* list of class variable values */
  32. #define SUPERCLASS    4    /* pointer to the superclass */
  33. #define IVARCNT        5    /* number of class instance variables */
  34. #define IVARTOTAL    6    /* total number of instance variables */
  35.  
  36. /* number of instance variables for the class 'Class' */
  37. #define CLASSSIZE    7
  38.  
  39. /* forward declarations (the extern hack is because of decusc) */
  40. extern struct node *findmsg();
  41. extern struct node *findvar();
  42. extern struct node *defvars();
  43. extern struct node *makelist();
  44.  
  45. /* xlclass - define a class */
  46. struct node *xlclass(name,vcnt)
  47.   char *name; int vcnt;
  48. {
  49.     struct node *sym,*cls;
  50.  
  51.     /* create the class */
  52.     sym = xlenter(name);
  53.     cls = sym->n_symvalue = newnode(OBJ);
  54.     cls->n_obclass = class;
  55.     cls->n_obdata = makelist(CLASSSIZE);
  56.  
  57.     /* set the instance variable counts */
  58.     if (vcnt > 0) {
  59.     (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
  60.     (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
  61.     }
  62.  
  63.     /* set the superclass to 'Object' */
  64.     xlivar(cls,SUPERCLASS)->n_listvalue = object;
  65.  
  66.     /* return the new class */
  67.     return (cls);
  68. }
  69.  
  70. /* xlmfind - find the message binding for a message to an object */
  71. struct node *xlmfind(obj,msym)
  72.   struct node *obj,*msym;
  73. {
  74.     return (findmsg(obj->n_obclass,msym));
  75. }
  76.  
  77. /* xlxsend - send a message to an object */
  78. struct node *xlxsend(obj,msg,args)
  79.   struct node *obj,*msg,*args;
  80. {
  81.     struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv;
  82.  
  83.     /* save the old environment */
  84.     oldenv = xlenv;
  85.  
  86.     /* create a new stack frame */
  87.     oldstk = xlsave(&method,&cptr,&val,NULL);
  88.  
  89.     /* get the method for this message */
  90.     method.n_ptr = msg->n_msgcode;
  91.  
  92.     /* make sure its a function or a subr */
  93.     if (method.n_ptr->n_type != SUBR && method.n_ptr->n_type != LIST)
  94.     xlfail("bad method");
  95.  
  96.     /* bind the symbols 'self' and 'msgclass' */
  97.     xlbind(self,obj);
  98.     xlbind(msgclass,msgcls);
  99.  
  100.     /* evaluate the function call */
  101.     if (method.n_ptr->n_type == SUBR) {
  102.     xlfixbindings(oldenv);
  103.     val.n_ptr = (*method.n_ptr->n_subr)(args);
  104.     }
  105.     else {
  106.  
  107.     /* bind the formal arguments */
  108.     xlabind(method.n_ptr->n_listvalue,args);
  109.     xlfixbindings(oldenv);
  110.  
  111.     /* execute the code */
  112.     cptr.n_ptr = method.n_ptr->n_listnext;
  113.     while (cptr.n_ptr != NULL)
  114.         val.n_ptr = xlevarg(&cptr.n_ptr);
  115.     }
  116.  
  117.     /* restore the environment */
  118.     xlunbind(oldenv);
  119.  
  120.     /* after creating an object, send it the "isnew" message */
  121.     if (msg->n_msg == new && val.n_ptr != NULL) {
  122.     if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
  123.         xlfail("no method for the isnew message");
  124.     val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
  125.     }
  126.  
  127.     /* restore the previous stack frame */
  128.     xlstack = oldstk;
  129.  
  130.     /* return the result value */
  131.     return (val.n_ptr);
  132. }
  133.  
  134. /* xlsend - send a message to an object (message in arg list) */
  135. struct node *xlsend(obj,args)
  136.   struct node *obj,*args;
  137. {
  138.     struct node *msg;
  139.  
  140.     /* find the message binding for this message */
  141.     if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
  142.     xlfail("no method for this message");
  143.  
  144.     /* send the message */
  145.     return (xlxsend(obj,msg,args));
  146. }
  147.  
  148. /* xlobsym - find a class or instance variable for the current object */
  149. struct node *xlobsym(sym)
  150.   struct node *sym;
  151. {
  152.     struct node *obj;
  153.  
  154.     if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
  155.     return (findvar(obj,sym));
  156.     else
  157.     return (NULL);
  158. }
  159.  
  160. /* mnew - create a new object instance */
  161. static struct node *mnew()
  162. {
  163.     struct node *oldstk,obj,*cls;
  164.  
  165.     /* create a new stack frame */
  166.     oldstk = xlsave(&obj,NULL);
  167.  
  168.     /* get the class */
  169.     cls = self->n_symvalue;
  170.  
  171.     /* generate a new object */
  172.     obj.n_ptr = newnode(OBJ);
  173.     obj.n_ptr->n_obclass = cls;
  174.     obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
  175.  
  176.     /* restore the previous stack frame */
  177.     xlstack = oldstk;
  178.  
  179.     /* return the new object */
  180.     return (obj.n_ptr);
  181. }
  182.  
  183. /* misnew - initialize a new class */
  184. static struct node *misnew(args)
  185.   struct node *args;
  186. {
  187.     struct node *oldstk,super,*obj;
  188.  
  189.     /* create a new stack frame */
  190.     oldstk = xlsave(&super,NULL);
  191.  
  192.     /* get the superclass if there is one */
  193.     if (args != NULL)
  194.     super.n_ptr = xlevmatch(OBJ,&args);
  195.     else
  196.     super.n_ptr = object;
  197.  
  198.     /* make sure there aren't any more arguments */
  199.     xllastarg(args);
  200.  
  201.     /* get the object */
  202.     obj = self->n_symvalue;
  203.  
  204.     /* store the superclass */
  205.     xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
  206.     (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
  207.          getivcnt(super.n_ptr,IVARTOTAL);
  208.  
  209.     /* restore the previous stack frame */
  210.     xlstack = oldstk;
  211.  
  212.     /* return the new object */
  213.     return (obj);
  214. }
  215.  
  216. /* xladdivar - enter an instance variable */
  217. xladdivar(cls,var)
  218.   struct node *cls; char *var;
  219. {
  220.     struct node *ivar,*lptr;
  221.  
  222.     /* find the 'ivars' instance variable */
  223.     ivar = xlivar(cls,IVARS);
  224.  
  225.     /* add the instance variable */
  226.     lptr = newnode(LIST);
  227.     lptr->n_listnext = ivar->n_listvalue;
  228.     ivar->n_listvalue = lptr;
  229.     lptr->n_listvalue = xlenter(var);
  230. }
  231.  
  232. /* entermsg - add a message to a class */
  233. static struct node *entermsg(cls,msg)
  234.   struct node *cls,*msg;
  235. {
  236.     struct node *ivar,*lptr,*mptr;
  237.  
  238.     /* find the 'messages' instance variable */
  239.     ivar = xlivar(cls,MESSAGES);
  240.  
  241.     /* lookup the message */
  242.     for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
  243.     if ((mptr = lptr->n_listvalue)->n_msg == msg)
  244.         return (mptr);
  245.  
  246.     /* allocate a new message entry if one wasn't found */
  247.     lptr = newnode(LIST);
  248.     lptr->n_listnext = ivar->n_listvalue;
  249.     ivar->n_listvalue = lptr;
  250.     lptr->n_listvalue = mptr = newnode(LIST);
  251.     mptr->n_msg = msg;
  252.  
  253.     /* return the symbol node */
  254.     return (mptr);
  255. }
  256.  
  257. /* answer - define a method for answering a message */
  258. static struct node *answer(args)
  259.   struct node *args;
  260. {
  261.     struct node *oldstk,arg,msg,fargs,code;
  262.     struct node *obj,*mptr,*fptr;
  263.  
  264.     /* create a new stack frame */
  265.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  266.  
  267.     /* initialize */
  268.     arg.n_ptr = args;
  269.  
  270.     /* message symbol */
  271.     msg.n_ptr = xlevmatch(SYM,&arg.n_ptr);
  272.  
  273.     /* get the formal argument list */
  274.     fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  275.  
  276.     /* get the code */
  277.     code.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  278.  
  279.     /* make sure there aren't any more arguments */
  280.     xllastarg(arg.n_ptr);
  281.  
  282.     /* get the object node */
  283.     obj = self->n_symvalue;
  284.  
  285.     /* make a new message list entry */
  286.     mptr = entermsg(obj,msg.n_ptr);
  287.  
  288.     /* setup the message node */
  289.     mptr->n_msgcode = fptr = newnode(LIST);
  290.     fptr->n_listvalue = fargs.n_ptr;
  291.     fptr->n_listnext = code.n_ptr;
  292.  
  293.     /* restore the previous stack frame */
  294.     xlstack = oldstk;
  295.  
  296.     /* return the object */
  297.     return (obj);
  298. }
  299.  
  300. /* mivars - define the list of instance variables */
  301. static struct node *mivars(args)
  302.   struct node *args;
  303. {
  304.     struct node *cls,*super;
  305.     int scnt;
  306.  
  307.     /* define the list of instance variables */
  308.     cls = defvars(args,IVARS);
  309.  
  310.     /* get the superclass instance variable count */
  311.     if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
  312.     scnt = getivcnt(super,IVARTOTAL);
  313.     else
  314.     scnt = 0;
  315.  
  316.     /* save the number of instance variables */
  317.     (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
  318.     (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;
  319.  
  320.     /* return the class */
  321.     return (cls);
  322. }
  323.  
  324. /* getivcnt - get the number of instance variables for a class */
  325. static int getivcnt(cls,ivar)
  326.   struct node *cls; int ivar;
  327. {
  328.     struct node *cnt;
  329.  
  330.     if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
  331.     if (cnt->n_type == INT)
  332.         return (cnt->n_int);
  333.     else
  334.         xlfail("bad value for instance variable count");
  335.     else
  336.     return (0);
  337. }
  338.  
  339. /* mcvars - define the list of class variables */
  340. static struct node *mcvars(args)
  341.   struct node *args;
  342. {
  343.     struct node *cls;
  344.  
  345.     /* define the list of class variables */
  346.     cls = defvars(args,CVARS);
  347.  
  348.     /* make a new list of values */
  349.     xlivar(cls,CVALS)->n_listvalue = makelist(varcnt);
  350.  
  351.     /* return the class */
  352.     return (cls);
  353. }
  354.  
  355. /* defvars - define a class or instance variable list */
  356. static struct node *defvars(args,varnum)
  357.   struct node *args; int varnum;
  358. {
  359.     struct node *oldstk,vars,*vptr,*cls,*sym;
  360.  
  361.     /* create a new stack frame */
  362.     oldstk = xlsave(&vars,NULL);
  363.  
  364.     /* get ivar list */
  365.     vars.n_ptr = xlevmatch(LIST,&args);
  366.  
  367.     /* make sure there aren't any more arguments */
  368.     xllastarg(args);
  369.  
  370.     /* get the class node */
  371.     cls = self->n_symvalue;
  372.  
  373.     /* check each variable in the list */
  374.     varcnt = 0;
  375.     for (vptr = vars.n_ptr;
  376.      vptr != NULL && vptr->n_type == LIST;
  377.      vptr = vptr->n_listnext) {
  378.  
  379.     /* make sure this is a valid symbol in the list */
  380.     if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
  381.         xlfail("bad variable list");
  382.  
  383.     /* make sure its not already defined */
  384.     if (checkvar(cls,sym))
  385.         xlfail("multiply defined variable");
  386.  
  387.     /* count the variable */
  388.     varcnt++;
  389.     }
  390.  
  391.     /* make sure the list ended properly */
  392.     if (vptr != NULL)
  393.     xlfail("bad variable list");
  394.  
  395.     /* define the new variable list */
  396.     xlivar(cls,varnum)->n_listvalue = vars.n_ptr;
  397.  
  398.     /* restore the previous stack frame */
  399.     xlstack = oldstk;
  400.  
  401.     /* return the class */
  402.     return (cls);
  403. }
  404.  
  405. /* xladdmsg - add a message to a class */
  406. xladdmsg(cls,msg,code)
  407.   struct node *cls; char *msg; struct node *(*code)();
  408. {
  409.     struct node *mptr;
  410.  
  411.     /* enter the message selector */
  412.     mptr = entermsg(cls,xlenter(msg));
  413.  
  414.     /* store the method for this message */
  415.     mptr->n_msgcode = newnode(SUBR);
  416.     mptr->n_msgcode->n_subr = code;
  417. }
  418.  
  419. /* getclass - get the class of an object */
  420. static struct node *getclass(args)
  421.   struct node *args;
  422. {
  423.     /* make sure there aren't any arguments */
  424.     xllastarg(args);
  425.  
  426.     /* return the object's class */
  427.     return (self->n_symvalue->n_obclass);
  428. }
  429.  
  430. /* obprint - print an object */
  431. static struct node *obprint(args)
  432.   struct node *args;
  433. {
  434.     /* make sure there aren't any arguments */
  435.     xllastarg(args);
  436.  
  437.     /* print the object */
  438.     printf("<Object: #%o>",self->n_symvalue);
  439.  
  440.     /* return the object */
  441.     return (self->n_symvalue);
  442. }
  443.  
  444. /* obshow - show the instance variables of an object */
  445. static struct node *obshow(args)
  446.   struct node *args;
  447. {
  448.     /* make sure there aren't any arguments */
  449.     xllastarg(args);
  450.  
  451.     /* print the object's instance variables */
  452.     xlprint(self->n_symvalue->n_obdata,TRUE);
  453.  
  454.     /* return the object */
  455.     return (self->n_symvalue);
  456. }
  457.  
  458. /* defisnew - default 'isnew' method */
  459. static struct node *defisnew(args)
  460.   struct node *args;
  461. {
  462.     /* make sure there aren't any arguments */
  463.     xllastarg(args);
  464.  
  465.     /* return the object */
  466.     return (self->n_symvalue);
  467. }
  468.  
  469. /* sendsuper - send a message to an object's superclass */
  470. static struct node *sendsuper(args)
  471.   struct node *args;
  472. {
  473.     struct node *obj,*super,*msg;
  474.  
  475.     /* get the object */
  476.     obj = self->n_symvalue;
  477.  
  478.     /* get the object's superclass */
  479.     super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;
  480.  
  481.     /* find the message binding for this message */
  482.     if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL)
  483.     xlfail("no method for this message");
  484.  
  485.     /* send the message */
  486.     return (xlxsend(obj,msg,args));
  487. }
  488.  
  489. /* findmsg - find the message binding given an object and a class */
  490. static struct node *findmsg(cls,sym)
  491.   struct node *cls,*sym;
  492. {
  493.     struct node *lptr,*msg;
  494.  
  495.     /* start at the specified class */
  496.     msgcls = cls;
  497.  
  498.     /* look for the message in the class or superclasses */
  499.     while (msgcls != NULL) {
  500.  
  501.     /* lookup the message in this class */
  502.     for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
  503.          lptr != NULL;
  504.          lptr = lptr->n_listnext)
  505.         if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
  506.         return (msg);
  507.  
  508.     /* look in class's superclass */
  509.     msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
  510.     }
  511.  
  512.     /* message not found */
  513.     return (NULL);
  514. }
  515.  
  516. /* findvar - find a class or instance variable */
  517. static struct node *findvar(obj,sym)
  518.   struct node *obj,*sym;
  519. {
  520.     struct node *cls,*lptr;
  521.     int base,varnum;
  522.     int found;
  523.  
  524.     /* get the class of the object */
  525.     cls = obj->n_obclass;
  526.  
  527.     /* get the total number of instance variables */
  528.     base = getivcnt(cls,IVARTOTAL);
  529.  
  530.     /* find the variable */
  531.     found = FALSE;
  532.     for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {
  533.  
  534.     /* get the number of instance variables for this class */
  535.     if ((base -= getivcnt(cls,IVARCNT)) < 0)
  536.         xlfail("error finding instance variable");
  537.  
  538.     /* check for finding the class of the current message */
  539.     if (!found && cls == msgclass->n_symvalue)
  540.         found = TRUE;
  541.  
  542.     /* lookup the instance variable */
  543.     varnum = 0;
  544.     for (lptr = xlivar(cls,IVARS)->n_listvalue;
  545.              lptr != NULL;
  546.              lptr = lptr->n_listnext)
  547.         if (found && lptr->n_listvalue == sym)
  548.         return (xlivar(obj,base + varnum));
  549.         else
  550.         varnum++;
  551.  
  552.     /* skip the class variables if the message class hasn't been found */
  553.     if (!found)
  554.         continue;
  555.  
  556.     /* lookup the class variable */
  557.     varnum = 0;
  558.     for (lptr = xlivar(cls,CVARS)->n_listvalue;
  559.              lptr != NULL;
  560.              lptr = lptr->n_listnext)
  561.         if (lptr->n_listvalue == sym)
  562.         return (xlcvar(cls,varnum));
  563.         else
  564.         varnum++;
  565.     }
  566.  
  567.     /* variable not found */
  568.     return (NULL);
  569. }
  570.  
  571. /* checkvar - check for an existing class or instance variable */
  572. static int checkvar(cls,sym)
  573.   struct node *cls,*sym;
  574. {
  575.     struct node *lptr;
  576.  
  577.     /* find the variable */
  578.     for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue) {
  579.  
  580.     /* lookup the instance variable */
  581.     for (lptr = xlivar(cls,IVARS)->n_listvalue;
  582.              lptr != NULL;
  583.              lptr = lptr->n_listnext)
  584.         if (lptr->n_listvalue == sym)
  585.         return (TRUE);
  586.  
  587.     /* lookup the class variable */
  588.     for (lptr = xlivar(cls,CVARS)->n_listvalue;
  589.              lptr != NULL;
  590.              lptr = lptr->n_listnext)
  591.         if (lptr->n_listvalue == sym)
  592.         return (TRUE);
  593.     }
  594.  
  595.     /* variable not found */
  596.     return (FALSE);
  597. }
  598.  
  599. /* xlivar - get an instance variable */
  600. struct node *xlivar(obj,num)
  601.   struct node *obj; int num;
  602. {
  603.     struct node *ivar;
  604.  
  605.     /* get the instance variable */
  606.     for (ivar = obj->n_obdata; num > 0; num--)
  607.     if (ivar != NULL)
  608.         ivar = ivar->n_listnext;
  609.     else
  610.         xlfail("bad instance variable list");
  611.  
  612.     /* return the instance variable */
  613.     return (ivar);
  614. }
  615.  
  616. /* xlcvar - get a class variable */
  617. struct node *xlcvar(cls,num)
  618.   struct node *cls; int num;
  619. {
  620.     struct node *cvar;
  621.  
  622.     /* get the class variable */
  623.     for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
  624.     if (cvar != NULL)
  625.         cvar = cvar->n_listnext;
  626.     else
  627.         xlfail("bad class variable list");
  628.  
  629.     /* return the class variable */
  630.     return (cvar);
  631. }
  632.  
  633. /* makelist - make a list of nodes */
  634. static struct node *makelist(cnt)
  635.   int cnt;
  636. {
  637.     struct node *oldstk,list,*lnew;
  638.  
  639.     /* create a new stack frame */
  640.     oldstk = xlsave(&list,NULL);
  641.  
  642.     /* make the list */
  643.     for (; cnt > 0; cnt--) {
  644.     lnew = newnode(LIST);
  645.     lnew->n_listnext = list.n_ptr;
  646.     list.n_ptr = lnew;
  647.     }
  648.  
  649.     /* restore the previous stack frame */
  650.     xlstack = oldstk;
  651.  
  652.     /* return the list */
  653.     return (list.n_ptr);
  654. }
  655.  
  656. /* xloinit - object function initialization routine */
  657. xloinit()
  658. {
  659.     /* don't confuse the garbage collector */
  660.     class = NULL;
  661.     object = NULL;
  662.  
  663.     /* enter the object related symbols */
  664.     new = xlenter("new");
  665.     isnew = xlenter("isnew");
  666.     self = xlenter("self");
  667.     msgclass = xlenter("msgclass");
  668.  
  669.     /* create the 'Class' object */
  670.     class = xlclass("Class",CLASSSIZE);
  671.     class->n_obclass = class;
  672.  
  673.     /* create the 'Object' object */
  674.     object = xlclass("Object",0);
  675.  
  676.     /* finish initializing 'class' */
  677.     xlivar(class,SUPERCLASS)->n_listvalue = object;
  678.     xladdivar(class,"ivartotal");    /* ivar number 6 */
  679.     xladdivar(class,"ivarcnt");        /* ivar number 5 */
  680.     xladdivar(class,"superclass");    /* ivar number 4 */
  681.     xladdivar(class,"cvals");        /* ivar number 3 */
  682.     xladdivar(class,"cvars");        /* ivar number 2 */
  683.     xladdivar(class,"ivars");        /* ivar number 1 */
  684.     xladdivar(class,"messages");    /* ivar number 0 */
  685.     xladdmsg(class,"new",mnew);
  686.     xladdmsg(class,"answer",answer);
  687.     xladdmsg(class,"ivars",mivars);
  688.     xladdmsg(class,"cvars",mcvars);
  689.     xladdmsg(class,"isnew",misnew);
  690.  
  691.     /* finish initializing 'object' */
  692.     xladdmsg(object,"class",getclass);
  693.     xladdmsg(object,"print",obprint);
  694.     xladdmsg(object,"show",obshow);
  695.     xladdmsg(object,"isnew",defisnew);
  696.     xladdmsg(object,"sendsuper",sendsuper);
  697. }
  698.