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