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