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