home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / XLSP21TC.ZIP / XLOBJ.C < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-14  |  11.7 KB  |  474 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. /* external variables */
  9. extern LVAL xlenv,xlfenv,xlvalue;
  10. extern LVAL s_stdout,s_lambda;
  11.  
  12. /* local variables */
  13. static LVAL s_self,k_new,k_isnew;
  14. static LVAL class,object;
  15.  
  16. /* instance variable numbers for the class 'Class' */
  17. #define MESSAGES    0    /* list of messages */
  18. #define IVARS        1    /* list of instance variable names */
  19. #define CVARS        2    /* list of class variable names */
  20. #define CVALS        3    /* list of class variable values */
  21. #define SUPERCLASS    4    /* pointer to the superclass */
  22. #define IVARCNT        5    /* number of class instance variables */
  23. #define IVARTOTAL    6    /* total number of instance variables */
  24.  
  25. /* number of instance variables for the class 'Class' */
  26. #define CLASSSIZE    7
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL entermsg();
  30. FORWARD LVAL sendmsg();
  31. FORWARD LVAL evmethod();
  32.  
  33. /* xsend - send a message to an object */
  34. LVAL xsend()
  35. {
  36.     LVAL obj;
  37.     obj = xlgaobject();
  38.     return (sendmsg(obj,getclass(obj),xlgasymbol()));
  39. }
  40.  
  41. /* xsendsuper - send a message to the superclass of an object */
  42. LVAL xsendsuper()
  43. {
  44.     LVAL env,p;
  45.     for (env = xlenv; env; env = cdr(env))
  46.     if ((p = car(env)) && objectp(car(p)))
  47.         return (sendmsg(car(p),
  48.                 getivar(cdr(p),SUPERCLASS),
  49.                 xlgasymbol()));
  50.     xlfail("not in a method");
  51. }
  52.  
  53. /* xlclass - define a class */
  54. LVAL xlclass(name,vcnt)
  55.   char *name; int vcnt;
  56. {
  57.     LVAL sym,cls;
  58.  
  59.     /* create the class */
  60.     sym = xlenter(name);
  61.     cls = newobject(class,CLASSSIZE);
  62.     setvalue(sym,cls);
  63.  
  64.     /* set the instance variable counts */
  65.     setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
  66.     setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
  67.  
  68.     /* set the superclass to 'Object' */
  69.     setivar(cls,SUPERCLASS,object);
  70.  
  71.     /* return the new class */
  72.     return (cls);
  73. }
  74.  
  75. /* xladdivar - enter an instance variable */
  76. xladdivar(cls,var)
  77.   LVAL cls; char *var;
  78. {
  79.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  80. }
  81.  
  82. /* xladdmsg - add a message to a class */
  83. xladdmsg(cls,msg,offset)
  84.   LVAL cls; char *msg; int offset;
  85. {
  86.     extern FUNDEF funtab[];
  87.     LVAL mptr;
  88.  
  89.     /* enter the message selector */
  90.     mptr = entermsg(cls,xlenter(msg));
  91.  
  92.     /* store the method for this message */
  93.     rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
  94. }
  95.  
  96. /* xlobgetvalue - get the value of an instance variable */
  97. int xlobgetvalue(pair,sym,pval)
  98.   LVAL pair,sym,*pval;
  99. {
  100.     LVAL cls,names;
  101.     int ivtotal,n;
  102.  
  103.     /* find the instance or class variable */
  104.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  105.  
  106.     /* check the instance variables */
  107.     names = getivar(cls,IVARS);
  108.     ivtotal = getivcnt(cls,IVARTOTAL);
  109.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  110.         if (car(names) == sym) {
  111.         *pval = getivar(car(pair),n);
  112.         return (TRUE);
  113.         }
  114.         names = cdr(names);
  115.     }
  116.  
  117.     /* check the class variables */
  118.     names = getivar(cls,CVARS);
  119.     for (n = 0; consp(names); ++n) {
  120.         if (car(names) == sym) {
  121.         *pval = getelement(getivar(cls,CVALS),n);
  122.         return (TRUE);
  123.         }
  124.         names = cdr(names);
  125.     }
  126.     }
  127.  
  128.     /* variable not found */
  129.     return (FALSE);
  130. }
  131.  
  132. /* xlobsetvalue - set the value of an instance variable */
  133. int xlobsetvalue(pair,sym,val)
  134.   LVAL pair,sym,val;
  135. {
  136.     LVAL cls,names;
  137.     int ivtotal,n;
  138.  
  139.     /* find the instance or class variable */
  140.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  141.  
  142.     /* check the instance variables */
  143.     names = getivar(cls,IVARS);
  144.     ivtotal = getivcnt(cls,IVARTOTAL);
  145.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  146.         if (car(names) == sym) {
  147.         setivar(car(pair),n,val);
  148.         return (TRUE);
  149.         }
  150.         names = cdr(names);
  151.     }
  152.  
  153.     /* check the class variables */
  154.     names = getivar(cls,CVARS);
  155.     for (n = 0; consp(names); ++n) {
  156.         if (car(names) == sym) {
  157.         setelement(getivar(cls,CVALS),n,val);
  158.         return (TRUE);
  159.         }
  160.         names = cdr(names);
  161.     }
  162.     }
  163.  
  164.     /* variable not found */
  165.     return (FALSE);
  166. }
  167.  
  168. /* obisnew - default 'isnew' method */
  169. LVAL obisnew()
  170. {
  171.     LVAL self;
  172.     self = xlgaobject();
  173.     xllastarg();
  174.     return (self);
  175. }
  176.  
  177. /* obclass - get the class of an object */
  178. LVAL obclass()
  179. {
  180.     LVAL self;
  181.     self = xlgaobject();
  182.     xllastarg();
  183.     return (getclass(self));
  184. }
  185.  
  186. /* obshow - show the instance variables of an object */
  187. LVAL obshow()
  188. {
  189.     LVAL self,fptr,cls,names;
  190.     int ivtotal,n;
  191.  
  192.     /* get self and the file pointer */
  193.     self = xlgaobject();
  194.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  195.     xllastarg();
  196.  
  197.     /* get the object's class */
  198.     cls = getclass(self);
  199.  
  200.     /* print the object and class */
  201.     xlputstr(fptr,"Object is ");
  202.     xlprint(fptr,self,TRUE);
  203.     xlputstr(fptr,", Class is ");
  204.     xlprint(fptr,cls,TRUE);
  205.     xlterpri(fptr);
  206.  
  207.     /* print the object's instance variables */
  208.     for (; cls; cls = getivar(cls,SUPERCLASS)) {
  209.     names = getivar(cls,IVARS);
  210.     ivtotal = getivcnt(cls,IVARTOTAL);
  211.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  212.         xlputstr(fptr,"  ");
  213.         xlprint(fptr,car(names),TRUE);
  214.         xlputstr(fptr," = ");
  215.         xlprint(fptr,getivar(self,n),TRUE);
  216.         xlterpri(fptr);
  217.         names = cdr(names);
  218.     }
  219.     }
  220.  
  221.     /* return the object */
  222.     return (self);
  223. }
  224.  
  225. /* clnew - create a new object instance */
  226. LVAL clnew()
  227. {
  228.     LVAL self;
  229.     self = xlgaobject();
  230.     return (newobject(self,getivcnt(self,IVARTOTAL)));
  231. }
  232.  
  233. /* clisnew - initialize a new class */
  234. LVAL clisnew()
  235. {
  236.     LVAL self,ivars,cvars,super;
  237.     int n;
  238.  
  239.     /* get self, the ivars, cvars and superclass */
  240.     self = xlgaobject();
  241.     ivars = xlgalist();
  242.     cvars = (moreargs() ? xlgalist() : NIL);
  243.     super = (moreargs() ? xlgaobject() : object);
  244.     xllastarg();
  245.  
  246.     /* store the instance and class variable lists and the superclass */
  247.     setivar(self,IVARS,ivars);
  248.     setivar(self,CVARS,cvars);
  249.     setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
  250.     setivar(self,SUPERCLASS,super);
  251.  
  252.     /* compute the instance variable count */
  253.     n = listlength(ivars);
  254.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  255.     n += getivcnt(super,IVARTOTAL);
  256.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  257.  
  258.     /* return the new class object */
  259.     return (self);
  260. }
  261.  
  262. /* clanswer - define a method for answering a message */
  263. LVAL clanswer()
  264. {
  265.     LVAL self,msg,fargs,code,mptr;
  266.  
  267.     /* message symbol, formal argument list and code */
  268.     self = xlgaobject();
  269.     msg = xlgasymbol();
  270.     fargs = xlgalist();
  271.     code = xlgalist();
  272.     xllastarg();
  273.  
  274.     /* make a new message list entry */
  275.     mptr = entermsg(self,msg);
  276.  
  277.     /* setup the message node */
  278.     xlprot1(fargs);
  279.     fargs = cons(s_self,fargs); /* add 'self' as the first argument */
  280.     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
  281.     xlpop();
  282.  
  283.     /* return the object */
  284.     return (self);
  285. }
  286.  
  287. /* entermsg - add a message to a class */
  288. LOCAL LVAL entermsg(cls,msg)
  289.   LVAL cls,msg;
  290. {
  291.     LVAL lptr,mptr;
  292.  
  293.     /* lookup the message */
  294.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  295.     if (car(mptr = car(lptr)) == msg)
  296.         return (mptr);
  297.  
  298.     /* allocate a new message entry if one wasn't found */
  299.     xlsave1(mptr);
  300.     mptr = consa(msg);
  301.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  302.     xlpop();
  303.  
  304.     /* return the symbol node */
  305.     return (mptr);
  306. }
  307.  
  308. /* sendmsg - send a message to an object */
  309. LOCAL LVAL sendmsg(obj,cls,sym)
  310.   LVAL obj,cls,sym;
  311. {
  312.     LVAL msg,msgcls,method,val,p;
  313.  
  314.     /* look for the message in the class or superclasses */
  315.     for (msgcls = cls; msgcls; ) {
  316.  
  317.     /* lookup the message in this class */
  318.     for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
  319.         if ((msg = car(p)) && car(msg) == sym)
  320.         goto send_message;
  321.  
  322.     /* look in class's superclass */
  323.     msgcls = getivar(msgcls,SUPERCLASS);
  324.     }
  325.  
  326.     /* message not found */
  327.     xlerror("no method for this message",sym);
  328.  
  329. send_message:
  330.  
  331.     /* insert the value for 'self' (overwrites message selector) */
  332.     *--xlargv = obj;
  333.     ++xlargc;
  334.     
  335.     /* invoke the method */
  336.     if ((method = cdr(msg)) == NULL)
  337.     xlerror("bad method",method);
  338.     switch (ntype(method)) {
  339.     case SUBR:
  340.     val = (*getsubr(method))();
  341.     break;
  342.     case CLOSURE:
  343.     if (gettype(method) != s_lambda)
  344.         xlerror("bad method",method);
  345.     val = evmethod(obj,msgcls,method);
  346.     break;
  347.     default:
  348.     xlerror("bad method",method);
  349.     }
  350.  
  351.     /* after creating an object, send it the ":isnew" message */
  352.     if (car(msg) == k_new && val) {
  353.     xlprot1(val);
  354.     sendmsg(val,getclass(val),k_isnew);
  355.     xlpop();
  356.     }
  357.     
  358.     /* return the result value */
  359.     return (val);
  360. }
  361.  
  362. /* evmethod - evaluate a method */
  363. LOCAL LVAL evmethod(obj,msgcls,method)
  364.   LVAL obj,msgcls,method;
  365. {
  366.     LVAL oldenv,oldfenv,cptr,name,val;
  367.     CONTEXT cntxt;
  368.  
  369.     /* protect some pointers */
  370.     xlstkcheck(3);
  371.     xlsave(oldenv);
  372.     xlsave(oldfenv);
  373.     xlsave(cptr);
  374.  
  375.     /* create an 'object' stack entry and a new environment frame */
  376.     oldenv = xlenv;
  377.     oldfenv = xlfenv;
  378.     xlenv = cons(cons(obj,msgcls),getenv(method));
  379.     xlenv = xlframe(xlenv);
  380.     xlfenv = getfenv(method);
  381.  
  382.     /* bind the formal parameters */
  383.     xlabind(method,xlargc,xlargv);
  384.  
  385.     /* setup the implicit block */
  386.     if (name = getname(method))
  387.     xlbegin(&cntxt,CF_RETURN,name);
  388.  
  389.     /* execute the block */
  390.     if (name && setjmp(cntxt.c_jmpbuf))
  391.     val = xlvalue;
  392.     else
  393.     for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
  394.         val = xleval(car(cptr));
  395.  
  396.     /* finish the block context */
  397.     if (name)
  398.     xlend(&cntxt);
  399.  
  400.     /* restore the environment */
  401.     xlenv = oldenv;
  402.     xlfenv = oldfenv;
  403.  
  404.     /* restore the stack */
  405.     xlpopn(3);
  406.  
  407.     /* return the result value */
  408.     return (val);
  409. }
  410.  
  411. /* getivcnt - get the number of instance variables for a class */
  412. LOCAL int getivcnt(cls,ivar)
  413.   LVAL cls; int ivar;
  414. {
  415.     LVAL cnt;
  416.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  417.     xlfail("bad value for instance variable count");
  418.     return ((int)getfixnum(cnt));
  419. }
  420.  
  421. /* listlength - find the length of a list */
  422. LOCAL int listlength(list)
  423.   LVAL list;
  424. {
  425.     int len;
  426.     for (len = 0; consp(list); len++)
  427.     list = cdr(list);
  428.     return (len);
  429. }
  430.  
  431. /* obsymbols - initialize symbols */
  432. obsymbols()
  433. {
  434.     /* enter the object related symbols */
  435.     s_self  = xlenter("SELF");
  436.     k_new   = xlenter(":NEW");
  437.     k_isnew = xlenter(":ISNEW");
  438.  
  439.     /* get the Object and Class symbol values */
  440.     object = getvalue(xlenter("OBJECT"));
  441.     class  = getvalue(xlenter("CLASS"));
  442. }
  443.  
  444. /* xloinit - object function initialization routine */
  445. xloinit()
  446. {
  447.     /* create the 'Class' object */
  448.     class = xlclass("CLASS",CLASSSIZE);
  449.     setelement(class,0,class);
  450.  
  451.     /* create the 'Object' object */
  452.     object = xlclass("OBJECT",0);
  453.  
  454.     /* finish initializing 'class' */
  455.     setivar(class,SUPERCLASS,object);
  456.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  457.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  458.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  459.     xladdivar(class,"CVALS");        /* ivar number 3 */
  460.     xladdivar(class,"CVARS");        /* ivar number 2 */
  461.     xladdivar(class,"IVARS");        /* ivar number 1 */
  462.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  463.     xladdmsg(class,":NEW",FT_CLNEW);
  464.     xladdmsg(class,":ISNEW",FT_CLISNEW);
  465.     xladdmsg(class,":ANSWER",FT_CLANSWER);
  466.  
  467.     /* finish initializing 'object' */
  468.     setivar(object,SUPERCLASS,NIL);
  469.     xladdmsg(object,":ISNEW",FT_OBISNEW);
  470.     xladdmsg(object,":CLASS",FT_OBCLASS);
  471.     xladdmsg(object,":SHOW",FT_OBSHOW);
  472. }
  473.  
  474.