home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xschm22 / src / xsobj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-04-18  |  9.1 KB  |  357 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)),0),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.     cpush(cons(xlenter("%%CLASS"),copylists(cvars,NIL)));
  167.     
  168.     /* create the class variable environment */
  169.     xlval = newframe(getivar(super,CVARS),listlength(xlval)+1);
  170.     setelement(car(xlval),0,pop());
  171.     setelement(car(xlval),1,self);
  172.     push(xlval);
  173.  
  174.     /* store the instance and class variable lists and the superclass */
  175.     setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
  176.     setivar(self,CVARS,pop());
  177.     setivar(self,SUPERCLASS,super);
  178.  
  179.     /* compute the instance variable count */
  180.     n = listlength(ivars);
  181.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  182.     n += getivcnt(super,IVARTOTAL);
  183.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  184.  
  185.     /* return the new class object */
  186.     return (self);
  187. }
  188.  
  189. /* clanswer - define a method for answering a message */
  190. LVAL clanswer()
  191. {
  192.     extern LVAL xlfunction();
  193.     LVAL self,msg,fargs,code,mptr;
  194.  
  195.     /* message symbol, formal argument list and code */
  196.     self = xlgaobject();
  197.     msg = xlgasymbol();
  198.     fargs = xlgetarg();
  199.     code = xlgalist();
  200.     xllastarg();
  201.  
  202.     /* make a new message list entry */
  203.     mptr = entermsg(self,msg);
  204.  
  205.     /* add 'self' to the argument list */
  206.     cpush(cons(s_self,fargs));
  207.  
  208.     /* extend the class variable environment with the instance variables */
  209.     xlval = newframe(getivar(self,CVARS),1);
  210.     setelement(car(xlval),0,getivar(self,IVARS));
  211.     
  212.     /* compile and store the method */
  213.     xlval = xlfunction(msg,top(),code,xlval);
  214.     rplacd(mptr,cvmethod(xlval,getivar(self,CVARS)));
  215.     drop(1);
  216.  
  217.     /* return the object */
  218.     return (self);
  219. }
  220.  
  221. /* addivar - enter an instance variable */
  222. LOCAL addivar(cls,var)
  223.   LVAL cls; char *var;
  224. {
  225.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  226. }
  227.  
  228. /* addmsg - add a message to a class */
  229. LOCAL addmsg(cls,msg,fname)
  230.   LVAL cls; char *msg,*fname;
  231. {
  232.     LVAL mptr;
  233.  
  234.     /* enter the message selector */
  235.     mptr = entermsg(cls,xlenter(msg));
  236.  
  237.     /* store the method for this message */
  238.     rplacd(mptr,getvalue(xlenter(fname)));
  239. }
  240.  
  241. /* entermsg - add a message to a class */
  242. LOCAL LVAL entermsg(cls,msg)
  243.   LVAL cls,msg;
  244. {
  245.     LVAL lptr,mptr;
  246.  
  247.     /* lookup the message */
  248.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  249.     if (car(mptr = car(lptr)) == msg)
  250.         return (mptr);
  251.  
  252.     /* allocate a new message entry if one wasn't found */
  253.     cpush(cons(msg,NIL));
  254.     setivar(cls,MESSAGES,cons(top(),getivar(cls,MESSAGES)));
  255.  
  256.     /* return the symbol node */
  257.     return (pop());
  258. }
  259.  
  260. /* getivcnt - get the number of instance variables for a class */
  261. LOCAL int getivcnt(cls,ivar)
  262.   LVAL cls; int ivar;
  263. {
  264.     LVAL cnt;
  265.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  266.     xlerror("bad value for instance variable count",cnt);
  267.     return ((int)getfixnum(cnt));
  268. }
  269.  
  270. /* copylist - make a copy of a list */
  271. LOCAL LVAL copylists(list1,list2)
  272.   LVAL list1,list2;
  273. {
  274.     LVAL last,next;
  275.     
  276.     /* initialize */
  277.     cpush(NIL); last = NIL;
  278.     
  279.     /* copy the first list */
  280.     for (; consp(list1); list1 = cdr(list1)) {
  281.     next = cons(car(list1),NIL);
  282.     if (last) rplacd(last,next);
  283.     else settop(next);
  284.     last = next;
  285.     }
  286.     
  287.     /* append the second list */
  288.     for (; consp(list2); list2 = cdr(list2)) {
  289.     next = cons(car(list2),NIL);
  290.     if (last) rplacd(last,next);
  291.     else settop(next);
  292.     last = next;
  293.     }
  294.     return (pop());
  295. }
  296.  
  297. /* listlength - find the length of a list */
  298. LOCAL int listlength(list)
  299.   LVAL list;
  300. {
  301.     int len;
  302.     for (len = 0; consp(list); len++)
  303.     list = cdr(list);
  304.     return (len);
  305. }
  306.  
  307. /* obsymbols - initialize symbols */
  308. obsymbols()
  309. {
  310.     /* enter the object related symbols */
  311.     s_self  = xlenter("SELF");
  312.     k_isnew = xlenter("ISNEW");
  313.  
  314.     /* get the Object and Class symbol values */
  315.     object = getvalue(xlenter("OBJECT"));
  316.     class  = getvalue(xlenter("CLASS"));
  317. }
  318.  
  319. /* xloinit - object function initialization routine */
  320. xloinit()
  321. {
  322.     LVAL sym;
  323.     
  324.     /* create the 'Object' object */
  325.     sym = xlenter("OBJECT");
  326.     object = newobject(NIL,CLASSSIZE);
  327.     setvalue(sym,object);
  328.     setivar(object,IVARS,cons(xlenter("%%CLASS"),NIL));
  329.     setivar(object,IVARCNT,cvfixnum((FIXTYPE)0));
  330.     setivar(object,IVARTOTAL,cvfixnum((FIXTYPE)0));
  331.     addmsg(object,"ISNEW","%OBJECT-ISNEW");
  332.     addmsg(object,"CLASS","%OBJECT-CLASS");
  333.     addmsg(object,"SHOW","%OBJECT-SHOW");
  334.     
  335.     /* create the 'Class' object */
  336.     sym = xlenter("CLASS");
  337.     class = newobject(NIL,CLASSSIZE);
  338.     setvalue(sym,class);
  339.     addivar(class,"IVARTOTAL");    /* ivar number 6 */
  340.     addivar(class,"IVARCNT");    /* ivar number 5 */
  341.     addivar(class,"SUPERCLASS");/* ivar number 4 */
  342.     addivar(class,"CVARS");    /* ivar number 3 */
  343.     addivar(class,"IVARS");    /* ivar number 2 */
  344.     addivar(class,"MESSAGES");    /* ivar number 1 */
  345.     setivar(class,IVARS,cons(xlenter("%%CLASS"),getivar(class,IVARS)));
  346.     setivar(class,IVARCNT,cvfixnum((FIXTYPE)CLASSSIZE));
  347.     setivar(class,IVARTOTAL,cvfixnum((FIXTYPE)CLASSSIZE));
  348.     setivar(class,SUPERCLASS,object);
  349.     addmsg(class,"NEW","%CLASS-NEW");
  350.     addmsg(class,"ISNEW","%CLASS-ISNEW");
  351.     addmsg(class,"ANSWER","%CLASS-ANSWER");
  352.  
  353.     /* patch the class into 'object' and 'class' */
  354.     setclass(object,class);
  355.     setclass(class,class);
  356. }
  357.