home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / xsobj.c < prev    next >
C/C++ Source or Header  |  1990-10-10  |  10KB  |  358 lines
  1. /* xsobj.c - xscheme object-oriented programming support */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlval;
  10. extern LVAL s_stdout;
  11.  
  12. /* local variables */
  13. static LVAL s_self,k_isnew;
  14. static LVAL class,object;
  15.  
  16. /* instance variable numbers for the class 'Class' */
  17. #define MESSAGES    2    /* list of messages */
  18. #define IVARS        3    /* list of instance variable names */
  19. #define CVARS        4    /* env containing class variables */
  20. #define SUPERCLASS    5    /* pointer to the superclass */
  21. #define IVARCNT        6    /* number of class instance variables */
  22. #define IVARTOTAL    7    /* total number of instance variables */
  23.  
  24. /* number of instance variables for the class 'Class' */
  25. #define CLASSSIZE    6
  26.  
  27. /* forward declarations */
  28. FORWARD LVAL entermsg();
  29. FORWARD LVAL copylists();
  30.  
  31. /* xlsend - send a message to an object */
  32. xlsend(obj,sym)
  33.   LVAL obj,sym;
  34. {
  35.     LVAL msg,cls,p;
  36.  
  37.     /* look for the message in the class or superclasses */
  38.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS))
  39.     for (p = getivar(cls,MESSAGES); p; p = cdr(p))
  40.         if ((msg = car(p)) && car(msg) == sym) {
  41.         push(obj); ++xlargc; /* insert 'self' argument */
  42.         xlval = cdr(msg);    /* get the method */
  43.         xlapply();         /* invoke the method */
  44.         return;
  45.         }
  46.  
  47.     /* message not found */
  48.     xlerror("no method for this message",sym);
  49. }
  50.  
  51. /* xsendsuper - built-in function 'send-super' */
  52. LVAL xsendsuper()
  53. {
  54.     LVAL obj,sym,msg,cls,p;
  55.  
  56.     /* get the message selector */
  57.     sym = xlgasymbol();
  58.  
  59.     /* find the 'self' object */
  60.     for (obj = xlenv; obj; obj = cdr(obj))
  61.     if (ntype(car(obj)) == OBJECT)
  62.         goto find_method;
  63.     xlerror("not in a method",sym);
  64.  
  65. find_method:
  66.     /* get the message class and the 'self' object */
  67.     cls = getivar(getelement(car(cdr(obj)),1),SUPERCLASS);
  68.     obj = car(obj);
  69.  
  70.     /* look for the message in the class or superclasses */
  71.     for (; cls; cls = getivar(cls,SUPERCLASS))
  72.     for (p = getivar(cls,MESSAGES); p; p = cdr(p))
  73.         if ((msg = car(p)) && car(msg) == sym) {
  74.         push(obj); ++xlargc; /* insert 'self' argument */
  75.         xlval = cdr(msg);    /* get the method */
  76.         xlapply();         /* invoke the method */
  77.         return;
  78.         }
  79.  
  80.     /* message not found */
  81.     xlerror("no method for this message",sym);
  82. }
  83.  
  84. /* obisnew - default 'isnew' method */
  85. LVAL obisnew()
  86. {
  87.     LVAL self;
  88.     self = xlgaobject();
  89.     xllastarg();
  90.     return (self);
  91. }
  92.  
  93. /* obclass - get the class of an object */
  94. LVAL obclass()
  95. {
  96.     LVAL self;
  97.     self = xlgaobject();
  98.     xllastarg();
  99.     return (getclass(self));
  100. }
  101.  
  102. /* obshow - show the instance variables of an object */
  103. LVAL obshow()
  104. {
  105.     LVAL self,fptr,cls,names;
  106.     int maxi,i;
  107.  
  108.     /* get self and the file pointer */
  109.     self = xlgaobject();
  110.     fptr = (moreargs() ? xlgaoport() : getvalue(s_stdout));
  111.     xllastarg();
  112.  
  113.     /* get the object's class */
  114.     cls = getclass(self);
  115.  
  116.     /* print the object and class */
  117.     xlputstr(fptr,"Object is ");
  118.     xlprin1(self,fptr);
  119.     xlputstr(fptr,", Class is ");
  120.     xlprin1(cls,fptr);
  121.     xlterpri(fptr);
  122.  
  123.     /* print the object's instance variables */
  124.     names = cdr(getivar(cls,IVARS));
  125.     maxi = getivcnt(cls,IVARTOTAL)+1;
  126.     for (i = 2; i <= maxi; ++i) {
  127.     xlputstr(fptr,"  ");
  128.     xlprin1(car(names),fptr);
  129.     xlputstr(fptr," = ");
  130.     xlprin1(getivar(self,i),fptr);
  131.     xlterpri(fptr);
  132.     names = cdr(names);
  133.     }
  134.  
  135.     /* return the object */
  136.     return (self);
  137. }
  138.  
  139. /* clnew - create a new object instance */
  140. LVAL clnew()
  141. {
  142.     LVAL self;
  143.  
  144.     /* create a new object */
  145.     self = xlgaobject();
  146.     xlval = newobject(self,getivcnt(self,IVARTOTAL));
  147.  
  148.     /* send the 'isnew' message */
  149.     xlsend(xlval,k_isnew);
  150. }
  151.  
  152. /* clisnew - initialize a new class */
  153. LVAL clisnew()
  154. {
  155.     LVAL self,ivars,cvars,super;
  156.     int n;
  157.  
  158.     /* get self, the ivars, cvars and superclass */
  159.     self = xlgaobject();
  160.     ivars = xlgalist();
  161.     cvars = (moreargs() ? xlgalist() : NIL);
  162.     super = (moreargs() ? xlgaobject() : object);
  163.     xllastarg();
  164.  
  165.     /* create the class variable name list */
  166.     xlval = copylists(cvars,NIL);
  167.     cpush(cons(xlenter("%%CLASS"),xlval));
  168.  
  169.     /* create the class variable environment */
  170.     xlval = newframe(getivar(super,CVARS),listlength(top())+1);
  171.     setelement(car(xlval),0,pop());
  172.     setelement(car(xlval),1,self);
  173.     push(xlval);
  174.  
  175.     /* store the instance and class variable lists and the superclass */
  176.     setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
  177.     setivar(self,CVARS,pop());
  178.     setivar(self,SUPERCLASS,super);
  179.  
  180.     /* compute the instance variable count */
  181.     n = listlength(ivars);
  182.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  183.     n += getivcnt(super,IVARTOTAL);
  184.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  185.  
  186.     /* return the new class object */
  187.     return (self);
  188. }
  189.  
  190. /* clanswer - define a method for answering a message */
  191. LVAL clanswer()
  192. {
  193.     extern LVAL xlfunction();
  194.     LVAL self,msg,fargs,code,mptr;
  195.  
  196.     /* message symbol, formal argument list and code */
  197.     self = xlgaobject();
  198.     msg = xlgasymbol();
  199.     fargs = xlgetarg();
  200.     code = xlgalist();
  201.     xllastarg();
  202.  
  203.     /* make a new message list entry */
  204.     mptr = entermsg(self,msg);
  205.  
  206.     /* add 'self' to the argument list */
  207.     cpush(cons(s_self,fargs));
  208.  
  209.     /* extend the class variable environment with the instance variables */
  210.     xlval = newframe(getivar(self,CVARS),1);
  211.     setelement(car(xlval),0,getivar(self,IVARS));
  212.  
  213.     /* compile and store the method */
  214.     xlval = xlfunction(msg,top(),code,xlval);
  215.     rplacd(mptr,cvmethod(xlval,getivar(self,CVARS)));
  216.     drop(1);
  217.  
  218.     /* return the object */
  219.     return (self);
  220. }
  221.  
  222. /* addivar - enter an instance variable */
  223. LOCAL addivar(cls,var)
  224.   LVAL cls; char *var;
  225. {
  226.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  227. }
  228.  
  229. /* addmsg - add a message to a class */
  230. LOCAL addmsg(cls,msg,fname)
  231.   LVAL cls; char *msg,*fname;
  232. {
  233.     LVAL mptr;
  234.  
  235.     /* enter the message selector */
  236.     mptr = entermsg(cls,xlenter(msg));
  237.  
  238.     /* store the method for this message */
  239.     rplacd(mptr,getvalue(xlenter(fname)));
  240. }
  241.  
  242. /* entermsg - add a message to a class */
  243. LOCAL LVAL entermsg(cls,msg)
  244.   LVAL cls,msg;
  245. {
  246.     LVAL lptr,mptr;
  247.  
  248.     /* lookup the message */
  249.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  250.     if (car(mptr = car(lptr)) == msg)
  251.         return (mptr);
  252.  
  253.     /* allocate a new message entry if one wasn't found */
  254.     cpush(cons(msg,NIL));
  255.     setivar(cls,MESSAGES,cons(top(),getivar(cls,MESSAGES)));
  256.  
  257.     /* return the symbol node */
  258.     return (pop());
  259. }
  260.  
  261. /* getivcnt - get the number of instance variables for a class */
  262. LOCAL int getivcnt(cls,ivar)
  263.   LVAL cls; int ivar;
  264. {
  265.     LVAL cnt;
  266.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  267.     xlerror("bad value for instance variable count",cnt);
  268.     return ((int)getfixnum(cnt));
  269. }
  270.  
  271. /* copylist - make a copy of a list */
  272. LOCAL LVAL copylists(list1,list2)
  273.   LVAL list1,list2;
  274. {
  275.     LVAL last,next;
  276.  
  277.     /* initialize */
  278.     cpush(NIL); last = NIL;
  279.  
  280.     /* copy the first list */
  281.     for (; consp(list1); list1 = cdr(list1)) {
  282.     next = cons(car(list1),NIL);
  283.     if (last) rplacd(last,next);
  284.     else settop(next);
  285.     last = next;
  286.     }
  287.  
  288.     /* append the second list */
  289.     for (; consp(list2); list2 = cdr(list2)) {
  290.     next = cons(car(list2),NIL);
  291.     if (last) rplacd(last,next);
  292.     else settop(next);
  293.     last = next;
  294.     }
  295.     return (pop());
  296. }
  297.  
  298. /* listlength - find the length of a list */
  299. LOCAL int listlength(list)
  300.   LVAL list;
  301. {
  302.     int len;
  303.     for (len = 0; consp(list); len++)
  304.     list = cdr(list);
  305.     return (len);
  306. }
  307.  
  308. /* obsymbols - initialize symbols */
  309. obsymbols()
  310. {
  311.     /* enter the object related symbols */
  312.     s_self  = xlenter("SELF");
  313.     k_isnew = xlenter("ISNEW");
  314.  
  315.     /* get the Object and Class symbol values */
  316.     object = getvalue(xlenter("OBJECT"));
  317.     class  = getvalue(xlenter("CLASS"));
  318. }
  319.  
  320. /* xloinit - object function initialization routine */
  321. xloinit()
  322. {
  323.     LVAL sym;
  324.  
  325.     /* create the 'Object' object */
  326.     sym = xlenter("OBJECT");
  327.     object = newobject(NIL,CLASSSIZE);
  328.     setvalue(sym,object);
  329.     setivar(object,IVARS,cons(xlenter("%%CLASS"),NIL));
  330.     setivar(object,IVARCNT,cvfixnum((FIXTYPE)0));
  331.     setivar(object,IVARTOTAL,cvfixnum((FIXTYPE)0));
  332.     addmsg(object,"ISNEW","%OBJECT-ISNEW");
  333.     addmsg(object,"CLASS","%OBJECT-CLASS");
  334.     addmsg(object,"SHOW","%OBJECT-SHOW");
  335.  
  336.     /* create the 'Class' object */
  337.     sym = xlenter("CLASS");
  338.     class = newobject(NIL,CLASSSIZE);
  339.     setvalue(sym,class);
  340.     addivar(class,"IVARTOTAL");    /* ivar number 6 */
  341.     addivar(class,"IVARCNT");    /* ivar number 5 */
  342.     addivar(class,"SUPERCLASS");/* ivar number 4 */
  343.     addivar(class,"CVARS");    /* ivar number 3 */
  344.     addivar(class,"IVARS");    /* ivar number 2 */
  345.     addivar(class,"MESSAGES");    /* ivar number 1 */
  346.     setivar(class,IVARS,cons(xlenter("%%CLASS"),getivar(class,IVARS)));
  347.     setivar(class,IVARCNT,cvfixnum((FIXTYPE)CLASSSIZE));
  348.     setivar(class,IVARTOTAL,cvfixnum((FIXTYPE)CLASSSIZE));
  349.     setivar(class,SUPERCLASS,object);
  350.     addmsg(class,"NEW","%CLASS-NEW");
  351.     addmsg(class,"ISNEW","%CLASS-ISNEW");
  352.     addmsg(class,"ANSWER","%CLASS-ANSWER");
  353.  
  354.     /* patch the class into 'object' and 'class' */
  355.     setclass(object,class);
  356.     setclass(class,class);
  357. }
  358.