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