home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlobj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  13.8 KB  |  526 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlobj.c
  5. * RCS:          $Header: xlobj.c,v 1.5 91/03/24 22:25:15 mayer Exp $
  6. * Description:  xlisp object functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:07:16 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlobj.c,v 1.5 91/03/24 22:25:15 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern LVAL xlenv,xlfenv,xlvalue;
  49. extern LVAL s_stdout,s_lambda;
  50.  
  51. /* local variables */
  52. static LVAL s_self,k_new,k_isnew;
  53. static LVAL class,object;
  54.  
  55. /* instance variable numbers for the class 'Class' */
  56. #define MESSAGES    0    /* list of messages */
  57. #define IVARS        1    /* list of instance variable names */
  58. #define CVARS        2    /* list of class variable names */
  59. #define CVALS        3    /* list of class variable values */
  60. #define SUPERCLASS    4    /* pointer to the superclass */
  61. #define IVARCNT        5    /* number of class instance variables */
  62. #define IVARTOTAL    6    /* total number of instance variables */
  63.  
  64. /* number of instance variables for the class 'Class' */
  65. #define CLASSSIZE    7
  66.  
  67. /* forward declarations */
  68. LOCAL FORWARD LVAL entermsg();    /* NPM: changed this to LOCAL */
  69. LOCAL FORWARD LVAL sendmsg();    /* NPM: changed this to LOCAL */
  70. LOCAL FORWARD LVAL evmethod();    /* NPM: changed this to LOCAL */
  71.  
  72. /* xsend - send a message to an object */
  73. LVAL xsend()
  74. {
  75.     LVAL obj;
  76.     obj = xlgaobject();
  77.     return (sendmsg(obj,getclass(obj),xlgasymbol()));
  78. }
  79.  
  80. /* xsendsuper - send a message to the superclass of an object */
  81. LVAL xsendsuper()
  82. {
  83.     LVAL env,p;
  84.     for (env = xlenv; env; env = cdr(env))
  85.     if ((p = car(env)) && objectp(car(p)))
  86.         return (sendmsg(car(p),
  87.                 getivar(cdr(p),SUPERCLASS),
  88.                 xlgasymbol()));
  89.     xlfail("not in a method");
  90. }
  91.  
  92. /* xlclass - define a class */
  93. LVAL xlclass(name,vcnt)
  94.   char *name; int vcnt;
  95. {
  96.     LVAL sym,cls;
  97.  
  98.     /* create the class */
  99.     sym = xlenter(name);
  100.     cls = newobject(class,CLASSSIZE);
  101.     setvalue(sym,cls);
  102.  
  103.     /* set the instance variable counts */
  104.     setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
  105.     setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
  106.  
  107.     /* set the superclass to 'Object' */
  108.     setivar(cls,SUPERCLASS,object);
  109.  
  110.     /* return the new class */
  111.     return (cls);
  112. }
  113.  
  114. #ifdef WINTERP
  115. /* xlclass_p -- check if object is a class object as created by xlclass() */
  116. int xlclass_p(o_class)
  117.      LVAL o_class;        /* assume type==OBJECT */
  118. {
  119.   return (getclass(o_class) == class);
  120. }
  121. #endif
  122.  
  123. /* xladdivar - enter an instance variable */
  124. xladdivar(cls,var)
  125.   LVAL cls; char *var;
  126. {
  127.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  128. }
  129.  
  130. /* xladdmsg - add a message to a class */
  131. xladdmsg(cls,msg,offset)
  132.   LVAL cls; char *msg; int offset;
  133. {
  134.     extern FUNDEF funtab[];
  135.     LVAL mptr;
  136.  
  137.     /* enter the message selector */
  138.     mptr = entermsg(cls,xlenter(msg));
  139.  
  140.     /* store the method for this message */
  141.     rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
  142. }
  143.  
  144. /* xlobgetvalue - get the value of an instance variable */
  145. int xlobgetvalue(pair,sym,pval)
  146.   LVAL pair,sym,*pval;
  147. {
  148.     LVAL cls,names;
  149.     int ivtotal,n;
  150.  
  151.     /* find the instance or class variable */
  152.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  153.  
  154.     /* check the instance variables */
  155.     names = getivar(cls,IVARS);
  156.     ivtotal = getivcnt(cls,IVARTOTAL);
  157.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  158.         if (car(names) == sym) {
  159.         *pval = getivar(car(pair),n);
  160.         return (TRUE);
  161.         }
  162.         names = cdr(names);
  163.     }
  164.  
  165.     /* check the class variables */
  166.     names = getivar(cls,CVARS);
  167.     for (n = 0; consp(names); ++n) {
  168.         if (car(names) == sym) {
  169.         *pval = getelement(getivar(cls,CVALS),n);
  170.         return (TRUE);
  171.         }
  172.         names = cdr(names);
  173.     }
  174.     }
  175.  
  176.     /* variable not found */
  177.     return (FALSE);
  178. }
  179.  
  180. /* xlobsetvalue - set the value of an instance variable */
  181. int xlobsetvalue(pair,sym,val)
  182.   LVAL pair,sym,val;
  183. {
  184.     LVAL cls,names;
  185.     int ivtotal,n;
  186.  
  187.     /* find the instance or class variable */
  188.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  189.  
  190.     /* check the instance variables */
  191.     names = getivar(cls,IVARS);
  192.     ivtotal = getivcnt(cls,IVARTOTAL);
  193.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  194.         if (car(names) == sym) {
  195.         setivar(car(pair),n,val);
  196.         return (TRUE);
  197.         }
  198.         names = cdr(names);
  199.     }
  200.  
  201.     /* check the class variables */
  202.     names = getivar(cls,CVARS);
  203.     for (n = 0; consp(names); ++n) {
  204.         if (car(names) == sym) {
  205.         setelement(getivar(cls,CVALS),n,val);
  206.         return (TRUE);
  207.         }
  208.         names = cdr(names);
  209.     }
  210.     }
  211.  
  212.     /* variable not found */
  213.     return (FALSE);
  214. }
  215.  
  216. /* obisnew - default 'isnew' method */
  217. LVAL obisnew()
  218. {
  219.     LVAL self;
  220.     self = xlgaobject();
  221.     xllastarg();
  222.     return (self);
  223. }
  224.  
  225. /* obclass - get the class of an object */
  226. LVAL obclass()
  227. {
  228.     LVAL self;
  229.     self = xlgaobject();
  230.     xllastarg();
  231.     return (getclass(self));
  232. }
  233.  
  234. /* obshow - show the instance variables of an object */
  235. LVAL obshow()
  236. {
  237.     LVAL self,fptr,cls,names;
  238.     int ivtotal,n;
  239.  
  240.     /* get self and the file pointer */
  241.     self = xlgaobject();
  242.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  243.     xllastarg();
  244.  
  245.     /* get the object's class */
  246.     cls = getclass(self);
  247.  
  248.     /* print the object and class */
  249.     xlputstr(fptr,"Object is ");
  250.     xlprint(fptr,self,TRUE);
  251.     xlputstr(fptr,", Class is ");
  252.     xlprint(fptr,cls,TRUE);
  253.     xlterpri(fptr);
  254.  
  255.     /* print the object's instance variables */
  256.     for (; cls; cls = getivar(cls,SUPERCLASS)) {
  257.     names = getivar(cls,IVARS);
  258.     ivtotal = getivcnt(cls,IVARTOTAL);
  259.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  260.         xlputstr(fptr,"  ");
  261.         xlprint(fptr,car(names),TRUE);
  262.         xlputstr(fptr," = ");
  263.         xlprint(fptr,getivar(self,n),TRUE);
  264.         xlterpri(fptr);
  265.         names = cdr(names);
  266.     }
  267.     }
  268.  
  269.     /* return the object */
  270.     return (self);
  271. }
  272.  
  273. /* clnew - create a new object instance */
  274. LVAL clnew()
  275. {
  276.     LVAL self;
  277.     self = xlgaobject();
  278.     return (newobject(self,getivcnt(self,IVARTOTAL)));
  279. }
  280.  
  281. /* clisnew - initialize a new class */
  282. LVAL clisnew()
  283. {
  284.     LVAL self,ivars,cvars,super;
  285.     int n;
  286.  
  287.     /* get self, the ivars, cvars and superclass */
  288.     self = xlgaobject();
  289.     ivars = xlgalist();
  290.     cvars = (moreargs() ? xlgalist() : NIL);
  291.     super = (moreargs() ? xlgaobject() : object);
  292.     xllastarg();
  293.  
  294.     /* store the instance and class variable lists and the superclass */
  295.     setivar(self,IVARS,ivars);
  296.     setivar(self,CVARS,cvars);
  297.     setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
  298.     setivar(self,SUPERCLASS,super);
  299.  
  300.     /* compute the instance variable count */
  301.     n = listlength(ivars);
  302.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  303.     n += getivcnt(super,IVARTOTAL);
  304.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  305.  
  306.     /* return the new class object */
  307.     return (self);
  308. }
  309.  
  310. /* clanswer - define a method for answering a message */
  311. LVAL clanswer()
  312. {
  313.     LVAL self,msg,fargs,code,mptr;
  314.  
  315.     /* message symbol, formal argument list and code */
  316.     self = xlgaobject();
  317.     msg = xlgasymbol();
  318.     fargs = xlgalist();
  319.     code = xlgalist();
  320.     xllastarg();
  321.  
  322.     /* make a new message list entry */
  323.     mptr = entermsg(self,msg);
  324.  
  325.     /* setup the message node */
  326.     xlprot1(fargs);
  327.     fargs = cons(s_self,fargs); /* add 'self' as the first argument */
  328.     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,xlenv,xlfenv));    /* changed by NPM -- pass in lexical and functional environment */
  329.     xlpop();
  330.  
  331.     /* return the object */
  332.     return (self);
  333. }
  334.  
  335. /* entermsg - add a message to a class */
  336. LOCAL LVAL entermsg(cls,msg)
  337.   LVAL cls,msg;
  338. {
  339.     LVAL lptr,mptr;
  340.  
  341.     /* lookup the message */
  342.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  343.     if (car(mptr = car(lptr)) == msg)
  344.         return (mptr);
  345.  
  346.     /* allocate a new message entry if one wasn't found */
  347.     xlsave1(mptr);
  348.     mptr = consa(msg);
  349.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  350.     xlpop();
  351.  
  352.     /* return the symbol node */
  353.     return (mptr);
  354. }
  355.  
  356. /* sendmsg - send a message to an object */
  357. LOCAL LVAL sendmsg(obj,cls,sym)
  358.   LVAL obj,cls,sym;
  359. {
  360.     LVAL msg,msgcls,method,val,p;
  361.  
  362.     /* look for the message in the class or superclasses */
  363.     for (msgcls = cls; msgcls; ) {
  364.  
  365.     /* lookup the message in this class */
  366.     for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
  367.         if ((msg = car(p)) && car(msg) == sym)
  368.         goto send_message;
  369.  
  370.     /* look in class's superclass */
  371.     msgcls = getivar(msgcls,SUPERCLASS);
  372.     }
  373.  
  374.     /* message not found */
  375.     xlerror("no method for this message",sym);
  376.  
  377. send_message:
  378.  
  379.     /* insert the value for 'self' (overwrites message selector) */
  380.     *--xlargv = obj;
  381.     ++xlargc;
  382.     
  383.     /* invoke the method */
  384.     if ((method = cdr(msg)) == NULL)
  385.     xlerror("bad method",method);
  386.     switch (ntype(method)) {
  387.     case SUBR:
  388.     val = (*getsubr(method))();
  389.     break;
  390.     case CLOSURE:
  391.     if (gettype(method) != s_lambda)
  392.         xlerror("bad method",method);
  393.     val = evmethod(obj,msgcls,method);
  394.     break;
  395.     default:
  396.     xlerror("bad method",method);
  397.     }
  398.  
  399.     /* after creating an object, send it the ":isnew" message */
  400.     if (car(msg) == k_new && val) {
  401.     xlprot1(val);
  402.     sendmsg(val,getclass(val),k_isnew);
  403.     xlpop();
  404.     }
  405.     
  406.     /* return the result value */
  407.     return (val);
  408. }
  409.  
  410. /* evmethod - evaluate a method */
  411. LOCAL LVAL evmethod(obj,msgcls,method)
  412.   LVAL obj,msgcls,method;
  413. {
  414.     LVAL oldenv,oldfenv,cptr,name,val;
  415.     CONTEXT cntxt;
  416.  
  417.     /* protect some pointers */
  418.     xlstkcheck(3);
  419.     xlsave(oldenv);
  420.     xlsave(oldfenv);
  421.     xlsave(cptr);
  422.  
  423.     /* create an 'object' stack entry and a new environment frame */
  424.     oldenv = xlenv;
  425.     oldfenv = xlfenv;
  426. #ifdef WINTERP            /* note: changed getenv()-->getenvt() due to name conflict with stdlib.h:getenv() */
  427.     xlenv = cons(cons(obj,msgcls),getenvt(method));
  428. #else
  429.     xlenv = cons(cons(obj,msgcls),getenv(method));
  430. #endif                /* WINTERP */
  431.     xlenv = xlframe(xlenv);
  432.     xlfenv = getfenv(method);
  433.  
  434.     /* bind the formal parameters */
  435.     xlabind(method,xlargc,xlargv);
  436.  
  437.     /* setup the implicit block */
  438.     if (name = getname(method))
  439.     xlbegin(&cntxt,CF_RETURN,name);
  440.  
  441.     /* execute the block */
  442.     if (name && setjmp(cntxt.c_jmpbuf))
  443.     val = xlvalue;
  444.     else
  445.     for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
  446.         val = xleval(car(cptr));
  447.  
  448.     /* finish the block context */
  449.     if (name)
  450.     xlend(&cntxt);
  451.  
  452.     /* restore the environment */
  453.     xlenv = oldenv;
  454.     xlfenv = oldfenv;
  455.  
  456.     /* restore the stack */
  457.     xlpopn(3);
  458.  
  459.     /* return the result value */
  460.     return (val);
  461. }
  462.  
  463. /* getivcnt - get the number of instance variables for a class */
  464. LOCAL int getivcnt(cls,ivar)
  465.   LVAL cls; int ivar;
  466. {
  467.     LVAL cnt;
  468.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  469.     xlfail("bad value for instance variable count");
  470.     return ((int)getfixnum(cnt));
  471. }
  472.  
  473. /* listlength - find the length of a list */
  474. LOCAL int listlength(list)
  475.   LVAL list;
  476. {
  477.     int len;
  478.     for (len = 0; consp(list); len++)
  479.     list = cdr(list);
  480.     return (len);
  481. }
  482.  
  483. /* obsymbols - initialize symbols */
  484. obsymbols()
  485. {
  486.     /* enter the object related symbols */
  487.     s_self  = xlenter("SELF");
  488.     k_new   = xlenter(":NEW");
  489.     k_isnew = xlenter(":ISNEW");
  490.  
  491.     /* get the Object and Class symbol values */
  492.     object = getvalue(xlenter("OBJECT"));
  493.     class  = getvalue(xlenter("CLASS"));
  494. }
  495.  
  496. /* xloinit - object function initialization routine */
  497. xloinit()
  498. {
  499.     /* create the 'Class' object */
  500.     class = xlclass("CLASS",CLASSSIZE);
  501.     setelement(class,0,class);
  502.  
  503.     /* create the 'Object' object */
  504.     object = xlclass("OBJECT",0);
  505.  
  506.     /* finish initializing 'class' */
  507.     setivar(class,SUPERCLASS,object);
  508.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  509.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  510.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  511.     xladdivar(class,"CVALS");        /* ivar number 3 */
  512.     xladdivar(class,"CVARS");        /* ivar number 2 */
  513.     xladdivar(class,"IVARS");        /* ivar number 1 */
  514.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  515.     xladdmsg(class,":NEW",FT_CLNEW);
  516.     xladdmsg(class,":ISNEW",FT_CLISNEW);
  517.     xladdmsg(class,":ANSWER",FT_CLANSWER);
  518.  
  519.     /* finish initializing 'object' */
  520.     setivar(object,SUPERCLASS,NIL);
  521.     xladdmsg(object,":ISNEW",FT_OBISNEW);
  522.     xladdmsg(object,":CLASS",FT_OBCLASS);
  523.     xladdmsg(object,":SHOW",FT_OBSHOW);
  524. }
  525.  
  526.