home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / xlobj.c < prev    next >
Text File  |  1985-10-05  |  13KB  |  499 lines
  1. /* xlobj - xlisp object functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack,*xlenv;
  14. extern NODE *s_stdout;
  15. extern NODE *self,*msgclass,*msgcls,*class,*object;
  16. extern NODE *new,*isnew;
  17.  
  18. /* instance variable numbers for the class 'Class' */
  19. #define MESSAGES    0    /* list of messages */
  20. #define IVARS        1    /* list of instance variable names */
  21. #define CVARS        2    /* list of class variable names */
  22. #define CVALS        3    /* list of class variable values */
  23. #define SUPERCLASS    4    /* pointer to the superclass */
  24. #define IVARCNT        5    /* number of class instance variables */
  25. #define IVARTOTAL    6    /* total number of instance variables */
  26.  
  27. /* number of instance variables for the class 'Class' */
  28. #define CLASSSIZE    7
  29.  
  30. /* forward declarations */
  31. FORWARD NODE *entermsg();
  32. FORWARD NODE *findmsg();
  33. FORWARD NODE *sendmsg();
  34.  
  35. /* xlclass - define a class */
  36. NODE *xlclass(name,vcnt)
  37.   char *name; int vcnt;
  38. {
  39.     NODE *sym,*cls;
  40.  
  41.     /* create the class */
  42.     sym = xlsenter(name);
  43.     cls = newobject(class,CLASSSIZE);
  44.     setvalue(sym,cls);
  45.  
  46.     /* set the instance variable counts */
  47.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
  48.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
  49.  
  50.     /* set the superclass to 'Object' */
  51.     setivar(cls,SUPERCLASS,object);
  52.  
  53.     /* return the new class */
  54.     return (cls);
  55. }
  56.  
  57. /* xladdivar - enter an instance variable */
  58. xladdivar(cls,var)
  59.   NODE *cls; char *var;
  60. {
  61.     setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
  62. }
  63.  
  64. /* xladdmsg - add a message to a class */
  65. xladdmsg(cls,msg,code)
  66.   NODE *cls; char *msg; NODE *(*code)();
  67. {
  68.     NODE *mptr;
  69.  
  70.     /* enter the message selector */
  71.     mptr = entermsg(cls,xlsenter(msg));
  72.  
  73.     /* store the method for this message */
  74.     rplacd(mptr,cvsubr(code,SUBR));
  75. }
  76.  
  77. /* xlsend - send a message to an object (message in arg list) */
  78. NODE *xlsend(obj,args)
  79.   NODE *obj,*args;
  80. {
  81.     NODE ***oldstk,*arglist,*msg,*val;
  82.  
  83.     /* find the message binding for this message */
  84.     if ((msg = findmsg(getclass(obj),xlevmatch(SYM,&args))) == NIL)
  85.     xlfail("no method for this message");
  86.  
  87.     /* evaluate the arguments and send the message */
  88.     oldstk = xlsave(&arglist,NULL);
  89.     arglist = xlevlist(args);
  90.     val = sendmsg(obj,msg,arglist);
  91.     xlstack = oldstk;
  92.  
  93.     /* return the result */
  94.     return (val);
  95. }
  96.  
  97. /* xlobgetvalue - get the value of an instance variable */
  98. int xlobgetvalue(sym,pval)
  99.   NODE *sym,**pval;
  100. {
  101.     NODE *obj,*cls,*names;
  102.     int ivtotal,n;
  103.  
  104.     /* get the current object and the message class */
  105.     obj = xlygetvalue(self);
  106.     cls = xlygetvalue(msgclass);
  107.     if (!(objectp(obj) && objectp(cls)))
  108.     return (FALSE);
  109.  
  110.     /* find the instance or class variable */
  111.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  112.  
  113.     /* check the instance variables */
  114.     names = getivar(cls,IVARS);
  115.     ivtotal = getivcnt(cls,IVARTOTAL);
  116.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  117.         if (car(names) == sym) {
  118.         *pval = getivar(obj,n);
  119.         return (TRUE);
  120.         }
  121.         names = cdr(names);
  122.     }
  123.  
  124.     /* check the class variables */
  125.     names = getivar(cls,CVARS);
  126.     for (n = 0; consp(names); ++n) {
  127.         if (car(names) == sym) {
  128.         *pval = getelement(getivar(cls,CVALS),n);
  129.         return (TRUE);
  130.         }
  131.         names = cdr(names);
  132.     }
  133.     }
  134.  
  135.     /* variable not found */
  136.     return (FALSE);
  137. }
  138.  
  139. /* xlobsetvalue - set the value of an instance variable */
  140. int xlobsetvalue(sym,val)
  141.   NODE *sym,*val;
  142. {
  143.     NODE *obj,*cls,*names;
  144.     int ivtotal,n;
  145.  
  146.     /* get the current object and the message class */
  147.     obj = xlygetvalue(self);
  148.     cls = xlygetvalue(msgclass);
  149.     if (!(objectp(obj) && objectp(cls)))
  150.     return (FALSE);
  151.  
  152.     /* find the instance or class variable */
  153.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  154.  
  155.     /* check the instance variables */
  156.     names = getivar(cls,IVARS);
  157.     ivtotal = getivcnt(cls,IVARTOTAL);
  158.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  159.         if (car(names) == sym) {
  160.         setivar(obj,n,val);
  161.         return (TRUE);
  162.         }
  163.         names = cdr(names);
  164.     }
  165.  
  166.     /* check the class variables */
  167.     names = getivar(cls,CVARS);
  168.     for (n = 0; consp(names); ++n) {
  169.         if (car(names) == sym) {
  170.         setelement(getivar(cls,CVALS),n,val);
  171.         return (TRUE);
  172.         }
  173.         names = cdr(names);
  174.     }
  175.     }
  176.  
  177.     /* variable not found */
  178.     return (FALSE);
  179. }
  180.  
  181. /* obisnew - default 'isnew' method */
  182. LOCAL NODE *obisnew(args)
  183.   NODE *args;
  184. {
  185.     xllastarg(args);
  186.     return (xlygetvalue(self));
  187. }
  188.  
  189. /* obclass - get the class of an object */
  190. LOCAL NODE *obclass(args)
  191.   NODE *args;
  192. {
  193.     /* make sure there aren't any arguments */
  194.     xllastarg(args);
  195.  
  196.     /* return the object's class */
  197.     return (getclass(xlygetvalue(self)));
  198. }
  199.  
  200. /* obshow - show the instance variables of an object */
  201. LOCAL NODE *obshow(args)
  202.   NODE *args;
  203. {
  204.     NODE ***oldstk,*fptr,*obj,*cls,*names;
  205.     int ivtotal,n;
  206.  
  207.     /* create a new stack frame */
  208.     oldstk = xlsave(&fptr,NULL);
  209.  
  210.     /* get the file pointer */
  211.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  212.     xllastarg(args);
  213.  
  214.     /* get the object and its class */
  215.     obj = xlygetvalue(self);
  216.     cls = getclass(obj);
  217.  
  218.     /* print the object and class */
  219.     xlputstr(fptr,"Object is ");
  220.     xlprint(fptr,obj,TRUE);
  221.     xlputstr(fptr,", Class is ");
  222.     xlprint(fptr,cls,TRUE);
  223.     xlterpri(fptr);
  224.  
  225.     /* print the object's instance variables */
  226.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
  227.     names = getivar(cls,IVARS);
  228.     ivtotal = getivcnt(cls,IVARTOTAL);
  229.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  230.         xlputstr(fptr,"  ");
  231.         xlprint(fptr,car(names),TRUE);
  232.         xlputstr(fptr," = ");
  233.         xlprint(fptr,getivar(obj,n),TRUE);
  234.         xlterpri(fptr);
  235.         names = cdr(names);
  236.     }
  237.     }
  238.  
  239.     /* restore the previous stack frame */
  240.     xlstack = oldstk;
  241.  
  242.     /* return the object */
  243.     return (obj);
  244. }
  245.  
  246. /* obsendsuper - send a message to an object's superclass */
  247. LOCAL NODE *obsendsuper(args)
  248.   NODE *args;
  249. {
  250.     NODE *obj,*super,*msg;
  251.  
  252.     /* get the object */
  253.     obj = xlygetvalue(self);
  254.  
  255.     /* get the object's superclass */
  256.     super = getivar(getclass(obj),SUPERCLASS);
  257.  
  258.     /* find the message binding for this message */
  259.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  260.     xlfail("no method for this message");
  261.  
  262.     /* send the message */
  263.     return (sendmsg(obj,msg,args));
  264. }
  265.  
  266. /* clnew - create a new object instance */
  267. LOCAL NODE *clnew()
  268. {
  269.     NODE *cls;
  270.     cls = xlygetvalue(self);
  271.     return (newobject(cls,getivcnt(cls,IVARTOTAL)));
  272. }
  273.  
  274. /* clisnew - initialize a new class */
  275. LOCAL NODE *clisnew(args)
  276.   NODE *args;
  277. {
  278.     NODE *ivars,*cvars,*super,*cls;
  279.     int n;
  280.  
  281.     /* get the ivars, cvars and superclass */
  282.     ivars = xlmatch(LIST,&args);
  283.     cvars = (args ? xlmatch(LIST,&args) : NIL);
  284.     super = (args ? xlmatch(OBJ,&args) : object);
  285.     xllastarg(args);
  286.  
  287.     /* get the new class object */
  288.     cls = xlygetvalue(self);
  289.  
  290.     /* store the instance and class variable lists and the superclass */
  291.     setivar(cls,IVARS,ivars);
  292.     setivar(cls,CVARS,cvars);
  293.     setivar(cls,CVALS,newvector(listlength(cvars)));
  294.     setivar(cls,SUPERCLASS,super);
  295.  
  296.     /* compute the instance variable count */
  297.     n = listlength(ivars);
  298.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
  299.     n += getivcnt(super,IVARTOTAL);
  300.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
  301.  
  302.     /* return the new class object */
  303.     return (cls);
  304. }
  305.  
  306. /* clanswer - define a method for answering a message */
  307. LOCAL NODE *clanswer(args)
  308.   NODE *args;
  309. {
  310.     NODE ***oldstk,*arg,*msg,*fargs,*code,*obj,*mptr;
  311.  
  312.     /* create a new stack frame */
  313.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  314.  
  315.     /* initialize */
  316.     arg = args;
  317.  
  318.     /* message symbol, formal argument list and code */
  319.     msg = xlmatch(SYM,&arg);
  320.     fargs = xlmatch(LIST,&arg);
  321.     code = xlmatch(LIST,&arg);
  322.     xllastarg(arg);
  323.  
  324.     /* get the object node */
  325.     obj = xlygetvalue(self);
  326.  
  327.     /* make a new message list entry */
  328.     mptr = entermsg(obj,msg);
  329.  
  330.     /* setup the message node */
  331.     rplacd(mptr,cons(fargs,code));
  332.  
  333.     /* restore the previous stack frame */
  334.     xlstack = oldstk;
  335.  
  336.     /* return the object */
  337.     return (obj);
  338. }
  339.  
  340. /* entermsg - add a message to a class */
  341. LOCAL NODE *entermsg(cls,msg)
  342.   NODE *cls,*msg;
  343. {
  344.     NODE ***oldstk,*lptr,*mptr;
  345.  
  346.     /* lookup the message */
  347.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  348.     if (car(mptr = car(lptr)) == msg)
  349.         return (mptr);
  350.  
  351.     /* allocate a new message entry if one wasn't found */
  352.     oldstk = xlsave(&mptr,NULL);
  353.     mptr = consa(msg);
  354.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  355.     xlstack = oldstk;
  356.  
  357.     /* return the symbol node */
  358.     return (mptr);
  359. }
  360.  
  361. /* findmsg - find the message binding given an object and a class */
  362. LOCAL NODE *findmsg(cls,sym)
  363.   NODE *cls,*sym;
  364. {
  365.     NODE *lptr,*msg;
  366.  
  367.     /* look for the message in the class or superclasses */
  368.     for (msgcls = cls; msgcls != NIL; ) {
  369.  
  370.     /* lookup the message in this class */
  371.     for (lptr = getivar(msgcls,MESSAGES); lptr != NIL; lptr = cdr(lptr))
  372.         if ((msg = car(lptr)) != NIL && car(msg) == sym)
  373.         return (msg);
  374.  
  375.     /* look in class's superclass */
  376.     msgcls = getivar(msgcls,SUPERCLASS);
  377.     }
  378.  
  379.     /* message not found */
  380.     return (NIL);
  381. }
  382.  
  383. /* sendmsg - send a message to an object */
  384. LOCAL NODE *sendmsg(obj,msg,args)
  385.   NODE *obj,*msg,*args;
  386. {
  387.     NODE ***oldstk,*oldenv,*newenv,*method,*cptr,*val,*isnewmsg;
  388.  
  389.     /* create a new stack frame */
  390.     oldstk = xlsave(&oldenv,&newenv,&method,&cptr,&val,NULL);
  391.  
  392.     /* get the method for this message */
  393.     method = cdr(msg);
  394.  
  395.     /* make sure its a function or a subr */
  396.     if (!subrp(method) && !consp(method))
  397.     xlfail("bad method");
  398.  
  399.     /* create a new environment frame */
  400.     newenv = xlframe(NIL);
  401.     oldenv = xlenv;
  402.  
  403.     /* bind the symbols 'self' and 'msgclass' */
  404.     xlbind(self,obj,newenv);
  405.     xlbind(msgclass,msgcls,newenv);
  406.  
  407.     /* evaluate the function call */
  408.     if (subrp(method)) {
  409.     xlenv = newenv;
  410.     val = (*getsubr(method))(args);
  411.     }
  412.     else {
  413.  
  414.     /* bind the formal arguments */
  415.     xlabind(car(method),args,newenv);
  416.     xlenv = newenv;
  417.  
  418.     /* execute the code */
  419.     cptr = cdr(method);
  420.     while (cptr)
  421.         val = xlevarg(&cptr);
  422.     }
  423.  
  424.     /* restore the environment */
  425.     xlenv = oldenv;
  426.  
  427.     /* after creating an object, send it the "isnew" message */
  428.     if (car(msg) == new && val) {
  429.     if ((isnewmsg = findmsg(getclass(val),isnew)) == NIL)
  430.         xlfail("no method for the isnew message");
  431.     sendmsg(val,isnewmsg,args);
  432.     }
  433.  
  434.     /* restore the previous stack frame */
  435.     xlstack = oldstk;
  436.  
  437.     /* return the result value */
  438.     return (val);
  439. }
  440.  
  441. /* getivcnt - get the number of instance variables for a class */
  442. LOCAL int getivcnt(cls,ivar)
  443.   NODE *cls; int ivar;
  444. {
  445.     NODE *cnt;
  446.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  447.     xlfail("bad value for instance variable count");
  448.     return ((int)getfixnum(cnt));
  449. }
  450.  
  451. /* listlength - find the length of a list */
  452. LOCAL int listlength(list)
  453.   NODE *list;
  454. {
  455.     int len;
  456.     for (len = 0; consp(list); len++)
  457.     list = cdr(list);
  458.     return (len);
  459. }
  460.  
  461. /* xloinit - object function initialization routine */
  462. xloinit()
  463. {
  464.     /* don't confuse the garbage collector */
  465.     class = object = NIL;
  466.  
  467.     /* enter the object related symbols */
  468.     self    = xlsenter("SELF");
  469.     msgclass    = xlsenter("MSGCLASS");
  470.     new        = xlsenter(":NEW");
  471.     isnew    = xlsenter(":ISNEW");
  472.  
  473.     /* create the 'Class' object */
  474.     class = xlclass("CLASS",CLASSSIZE);
  475.     setelement(class,0,class);
  476.  
  477.     /* create the 'Object' object */
  478.     object = xlclass("OBJECT",0);
  479.  
  480.     /* finish initializing 'class' */
  481.     setivar(class,SUPERCLASS,object);
  482.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  483.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  484.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  485.     xladdivar(class,"CVALS");        /* ivar number 3 */
  486.     xladdivar(class,"CVARS");        /* ivar number 2 */
  487.     xladdivar(class,"IVARS");        /* ivar number 1 */
  488.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  489.     xladdmsg(class,":NEW",clnew);
  490.     xladdmsg(class,":ISNEW",clisnew);
  491.     xladdmsg(class,":ANSWER",clanswer);
  492.  
  493.     /* finish initializing 'object' */
  494.     xladdmsg(object,":ISNEW",obisnew);
  495.     xladdmsg(object,":CLASS",obclass);
  496.     xladdmsg(object,":SHOW",obshow);
  497.     xladdmsg(object,":SENDSUPER",obsendsuper);
  498. }
  499.