leo.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* LEO.C
3 /* Object Oriented Programming Facilities
4 /* Every data structures in EUS is defined as an object.
5 /* Refer to eus.h and makes.c for the detail of the structures
6 /* of objects.
7 /*
8 /* Copyright: Toshihiro Matsui, Electrotechnical Laboratory
9 /* Original: 1986-May
10 /* */
11 static char *rcsid="@(#)$Id$";
12 
13 #include "eus.h"
14 
16 
17 #if THREADED
18 /* static mutex_t mcache_lock; */ /* This variable is not used. */
19 #endif
20 
21 int mchit=0, mcmiss=0, trycache=1; /*statistic for method cacheing*/
22 
23 pointer GETCLASS(ctx,n,argv)
24 register context *ctx;
25 int n;
26 pointer argv[];
27 { pointer v;
28  ckarg(1);
29  if (isnum(argv[0])) return(NIL);
30  return(classof(argv[0]));}
31 
32 pointer CLASSP(ctx,n,argv)
33 register context *ctx;
34 int n;
35 pointer argv[];
36 {
37  if (n!=1) error(E_MISMATCHARG);
38  return(isclass(argv[0])?T:NIL);}
39 
40 pointer SUBCLASSP(ctx,n,argv)
41 register context *ctx;
42 int n;
43 register pointer argv[];
44 { register int k,s;
45  ckarg(2);
46  if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
47  if (!isclass(argv[1])) error(E_NOCLASS,argv[1]);
48  k=intval(argv[0]->c.cls.cix);
49  s=intval(argv[1]->c.cls.cix);
50  if (k>=s && k<=classtab[s].subcix) return(T); else return(NIL); }
51 
52 pointer DERIVEDP(ctx,n,argv)
53 register context *ctx;
54 int n;
55 pointer argv[];
56 { register pointer obj,klass;
57  register int objcix,klasscix;
58  ckarg(2);
59  obj=argv[0]; klass=argv[1];
60  if (isnum(obj)) {
61  if ((klass==QFLOAT || klass==K_FLOAT)&& isflt(obj)) return(T);
62  else if ((klass==QINTEGER || klass==K_INTEGER) && isint(obj)) return(T);
63  else return(NIL);}
64  if (!isclass(klass)) error(E_NOCLASS,klass);
65  objcix=obj->cix;
66  klasscix=intval(klass->c.cls.cix);
67  if (objcix>=klasscix && objcix<=classtab[klasscix].subcix) return(T);
68  else return(NIL);}
69 
70 
71 /****************************************************************/
72 /* define new class
73 /****************************************************************/
74 
75 pointer ENTERCLASS(ctx,n,argv)
76 register context *ctx;
77 int n;
78 register pointer argv[];
79 { ckarg(1);
80  if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
81  enterclass(argv[0]);
82  return(argv[0]);}
83 
84 /****************************************************************/
85 /* add new method definition to a class
86 /****************************************************************/
87 
88 extern pointer K_CLASS;
89 
90 void addmethod(ctx,meth,class,doc)
91 register context *ctx;
92 register pointer meth,class,doc;
93 { extern pointer putprop(), assq();
94  register pointer selector,methods,classes,medoc,medoc2;
95  register int i,j;
96  vpush(meth);
97  selector=ccar(meth); methods=class->c.cls.methods;
98  if (!issymbol(selector)) error(E_NOSYMBOL);
99  classes=assq(K_CLASS,selector->c.sym.plist);
100  if (classes!=NIL) classes=ccdr(classes);
101  putprop(ctx,selector,cons(ctx,class,classes),K_CLASS);
102 /* */
103  if (doc!=NIL) {
104  medoc=assq(K_METHOD_DOCUMENTATION, selector->c.sym.plist);
105 /* prinx(medoc,STDOUT); */
106  if (medoc==NIL) putprop(ctx,selector,cons(ctx,cons(ctx,class,doc),NIL),
108  else {
109  medoc2=assq(class,ccdr(medoc));
110  if (medoc2==NIL)
111  {pointer_update(medoc->c.cons.cdr,cons(ctx,cons(ctx,class,doc),ccdr(medoc)));}
112  else pointer_update(medoc2->c.cons.cdr,doc); } }
113 /* */
114  if (methods==NIL) {pointer_update(class->c.cls.methods,cons(ctx,meth,NIL));}
115  else if (ccar(ccar(methods))==selector) {pointer_update(ccar(methods),meth);}
116  else {
117  while(ccdr(methods)!=NIL) {
118  methods=ccdr(methods);
119  if (ccar(ccar(methods))==selector) {
120  ccar(methods)=meth;
121  goto purgecache; } }
122  pointer_update(ccdr(methods),cons(ctx,meth,NIL)); }
123  /*nullify method cache for this selctor*/
124 purgecache:
125  vpop();
126  for (j=0; j<MAXTHREAD; j++) {
127  if ((ctx=euscontexts[j]))
128  for (i=0; i<MAXMETHCACHE; i++)
129  if (ctx->methcache[i].selector==selector)
130  pointer_update(ctx->methcache[i].selector,NIL); }
131  }
132 
133 void addcmethod(ctx,mod,cfunc,sel,class,doc)
134 register context *ctx;
135 pointer sel,mod,class,doc;
136 pointer (*cfunc)();
137 { if (!issymbol(class)) error(E_NOCLASS,class);
138  class=speval(class);
139  if (class==UNBOUND || !isclass(class)) error(E_NOCLASS,class);
140  addmethod(ctx,cons(ctx,sel,
141  cons(ctx,makecode(mod,cfunc,SUBR_FUNCTION),NIL)),
142  class,doc);}
143 
144 pointer DEFMETHOD(ctx,arg) /*special form*/
145 register context *ctx;
146 pointer arg;
147 { register pointer class,selector,classsym,body,doc;
148  classsym=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
149  if (!issymbol(classsym)) error(E_NOSYMBOL);
150  class=speval(classsym);
151  if (class==UNBOUND) error(E_UNBOUND,classsym);
152  if (!isclass(class)) error(E_NOCLASS,class);
153  while (islist(arg)) {
154  body=ccar(arg); /* (:selector (args) . body) */
155  if (!iscons(body)) error(E_NOLIST);
156  doc=ccdr(ccdr(body));
157  if (isstring(ccar(doc))) doc=ccar(doc); else doc=NIL;
158  addmethod(ctx,body,class,doc); arg=ccdr(arg);}
159  return(classsym);}
160 
162 register context *ctx;
163 int n;
164 pointer argv[];
165 { pointer a;
166  int s;
167  extern pointer makeobject();
168  a=argv[0];
169  if (isvecclass(a)) {
170  s=intval(a->c.vcls.size);
171  if (s<0) { ckarg(2); s=ckintval(argv[1]);}
172  else ckarg(1);
173 #ifdef SAFETY
174  {
175  pointer tmp = makevector(a,s);
176  take_care(tmp);
177  return(tmp);
178  }
179 #else
180  return(makevector(a,s));
181 #endif
182  }
183  else if (isclass(a)) {
184  ckarg(1);
185 #ifdef SAFETY
186  {
187  pointer tmp = makeobject(a);
188  take_care(tmp);
189  return(tmp);
190  }
191 #else
192  return(makeobject(a));
193 #endif
194  }
195  else error(E_NOCLASS,a);}
196 
197 
198 /****************************************************************/
199 /* send a message to an object
200 /* method is searched by method-cache
201 /*****************************************************************/
202 
203 pointer findmethod(ctx,sel,search, curclass)
204 register context *ctx;
205 register pointer sel,search, *curclass;
206 { register pointer meths,klass=search;
207  register struct methdef *mt;
208  register int h;
209 
210  if (trycache) {
211  h=(((eusinteger_t)sel+(eusinteger_t)klass)>>3) & (MAXMETHCACHE-1);/* ???? */
212  mt= &ctx->methcache[h];
213  if (mt->selector==sel && mt->class==search) {
214  /* hit! */
215  mchit++;
216  *curclass = mt->ownerclass;
217  return(mt->method);}}
218  while (isclass(klass) || isvecclass(klass)) {
219  mcmiss++;
220  meths=klass->c.cls.methods;
221  while (islist(meths)) /*find the method in this class*/
222  if (ccar(ccar(meths))==sel) {
223  if (trycache) {
224  pointer_update(mt->selector,sel);
225  pointer_update(mt->class,search);
226  pointer_update(mt->ownerclass,klass);
227  pointer_update(mt->method,ccar(meths));
228  }
229  *curclass = klass; return(ccar(meths));}
230  else meths=ccdr(meths);
231  klass= /*spevalof*/ (klass->c.cls.super);} /*try superclass*/
232  return(NIL);}
233 
234 pointer findforward(ctx,selector,klass,obj,component,classfound)
235 context *ctx;
236 register pointer selector,klass,obj, *component, *classfound;
237 { register pointer forwards=klass->c.cls.forwards,flist,meth;
238  register int i=0,vcount=vecsize(forwards);
239  while (i<vcount) {
240  flist=forwards->c.vec.v[i];
241  if (flist==T || memq(selector,flist)!=NIL) {
242  *component = obj->c.obj.iv[i];
243  if (!isnum(*component)) {
244  meth=findmethod(ctx,selector,classof(*component),classfound);
245  if (meth!=NIL) return(meth);}
246  else error(E_NOOBJECT);}
247  i++;}
248  return(NIL);}
249 
250 pointer SEND(ctx,n,argv)
251 register context *ctx;
252 int n;
253 register pointer argv[];
254 { register pointer receiver,klass,selector,meth,result;
255  register pointer *spsave=ctx->vsp, *altargv;
256  pointer curclass, component;
257  struct bindframe *bf,*bfsave=ctx->bindfp;
258  struct specialbindframe *sbfpsave=ctx->sbindfp;
259  int sbcount=ctx->special_bind_count;
260  int i,argoffset;
261 #if defined(DEBUG_COUNT) || defined(SEND_DEBUG)
262  static int count = 0;
263 
264  count++;
265 #endif
266 
267 #ifdef SEND_DEBUG
268  printf( "SEND:%d\n", count );
269 #endif
270 
271  if (n<2) error(E_MISMATCHARG);
272  receiver=argv[0];
273  selector=argv[1];
274  if (isnum(receiver)) error(E_NOOBJECT);
275  klass=classof(receiver);
276  meth=findmethod(ctx,selector,klass, &curclass);
277  if (meth==NIL) {
278  /*try forwarding*/
279  meth=findforward(ctx,selector,klass,receiver, &component, &curclass);
280  if (meth!=NIL) { argv[0]=component; receiver=component; argoffset=2;}
281  else {
282  meth=findmethod(ctx,K_NOMETHOD,klass, &curclass);
283  if (meth==NIL) error(E_NOMETHOD,selector);
284  if (iscode(ccar(ccdr(meth)))) {
285  altargv=ctx->vsp;
286  vpush(receiver); vpush(selector);
287  i=1;
288  while (i<n) ckpush(argv[i++]);
289  argv=altargv;
290  n++;}
291  else argoffset=1;} }
292  else argoffset=2;
293 
294  if (iscode(ccar(ccdr(meth)))) {
295  argv[1]=curclass;
296  result=funcode(ctx,ccar(ccdr(meth)),(pointer)argv,n);
297  }
298  else {
299  bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
300 #if SunOS4_1
301  bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */
302 #else
303  bf=fastbind(ctx,SELF,receiver,bf);
304 #endif
305  bf=fastbind(ctx,CLASS,curclass,bf);
306  result=funlambda(ctx,ccar(meth),ccar(ccdr(meth)),ccdr(ccdr(meth)),
307  &argv[argoffset],bf,n-argoffset);
308  ctx->bindfp=bfsave;
309  /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
310  unbindspecial(ctx,sbfpsave+1);
311  }
312  ctx->vsp=spsave;
313  return(result);}
314 
316 register context *ctx;
317 int n;
318 register pointer argv[];
319 { register pointer receiver,klass,selector,meth,result;
320  register pointer *spsave=ctx->vsp,*altargv;
321  pointer curclass, component;
322  struct bindframe *bf,*bfsave=ctx->bindfp;
323  struct specialbindframe *sbfpsave=ctx->sbindfp;
324  int argoffset;
325 
326  if (n<3) error(E_MISMATCHARG);
327  receiver=argv[1];
328  selector=argv[2];
329  if (isnum(receiver)) return(argv[0]);
330  klass=classof(receiver);
331  meth=findmethod(ctx,selector,klass, &curclass);
332  if (meth==NIL) {
333  /*try forwarding*/
334  meth=findforward(ctx,selector,klass,receiver, &component, NULL);
335  if (meth!=NIL) { argv[1]=component; receiver=component; argoffset=3;}
336  else return(argv[0]); }
337  else argoffset=3;
338 
339  if (iscode(ccar(ccdr(meth)))) {
340  argv[2]=curclass;
341  result=funcode(ctx,ccar(ccdr(meth)), (pointer)&argv[1],n-1);
342  }
343  else {
344  bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
345 #if SunOS4_1
346  bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */
347 #else
348  bf=fastbind(ctx,SELF,receiver,bf);
349 #endif
350  bf=fastbind(ctx,CLASS,curclass,bf);
351  result=funlambda(ctx,ccar(meth),ccar(ccdr(meth)),ccdr(ccdr(meth)),
352  &argv[argoffset],bf,n-argoffset);
353  ctx->bindfp=bfsave;
354  /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
355  unbindspecial(ctx,sbfpsave+1);
356  }
357  ctx->vsp=spsave;
358 #ifdef SAFETY
359  take_care(result);
360 #endif
361  return(result);}
362 
364 register context *ctx;
365 int n;
366 pointer argv[];
367 /* (send-message obj search selector [args]) */
368 { pointer receiver,search,selector,meth,form,result,*spsave, curclass;
369  struct bindframe *bf,*bfsave=ctx->bindfp;
370  struct specialbindframe *sbfpsave=ctx->sbindfp;
371 
372  if (n<3) error(E_MISMATCHARG);
373  receiver=argv[0]; search=argv[1]; selector=argv[2];
374  if (issymbol(search)) search=speval(search);
375  if (search==UNBOUND || (!isclass(search) && !isvecclass(search)))
376  error(E_NOCLASS,search);
377 
378  meth=findmethod(ctx,selector,search, &curclass);
379  if (meth==NIL) error(E_NOMETHOD);
380  form=ctx->callfp->form;
381  if (iscode(ccar(ccdr(meth)))) {
382  argv[1]=receiver; argv[2]=curclass;
383  result=ufuncall(ctx,form,ccar(ccdr(meth)),(pointer)&argv[1],NULL,n-1);}
384  else {
385  spsave=ctx->vsp;
386  bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
387 #if SunOS4_1
388  bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */
389 #else
390  bf=fastbind(ctx,SELF,receiver,bf);
391 #endif
392  bf=fastbind(ctx,CLASS,curclass,bf);
393  result=ufuncall(ctx,form,meth,(pointer)&argv[3],bf,n-3);
394  ctx->bindfp=bfsave;
395  /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
396  unbindspecial(ctx,sbfpsave+1);
397  ctx->vsp=spsave;}
398 #ifdef SAFETY
399  take_care(result);
400 #endif
401  return(result);}
402 
403 pointer CLONE(ctx,n,argv)
404 register context *ctx;
405 int n;
406 pointer argv[];
407 { pointer a=argv[0],klass,x;
408  register int i,s;
409  int etype;
410  ckarg(1);
411  if (ispointer(a)) {
412  klass=classof(a);
413  if (isvecclass(klass)) {
414  etype=intval(klass->c.vcls.elmtype);
415  s=vecsize(a);
416  switch(etype) {
417  case ELM_BIT: n=(s+WORD_SIZE-1)/WORD_SIZE; break;
418  case ELM_CHAR: case ELM_BYTE: n=(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
419  default: n=s; break;}
420  n++;
421  x=makevector(klass,s);
422  }
423  else {
424  n=vecsize(klass->c.cls.vars);
425  x=makeobject(klass);}
426  for (i=0; i<n; i++) x->c.obj.iv[i]=a->c.obj.iv[i];
427 #ifdef SAFETY
428  take_care(x);
429 #endif
430  return(x);}
431  else error(E_INSTANTIATE);}
432 
433 pointer METHCACHE(ctx,n,argv)
434 register context *ctx;
435 int n;
436 pointer argv[];
437 { /* return method cache hit ratio*/
438  register int i;
439  if (n==1) {
440  trycache=(argv[0]!=NIL);
441  for (i=0; i<MAXMETHCACHE; i++) {
442  pointer_update(ctx->methcache[i].class,NIL);
443  pointer_update(ctx->methcache[i].selector,NIL);
444  }
445  }
446 #ifdef SAFETY
447  {
448  pointer tmp = cons(ctx,makeint(mchit),cons(ctx,makeint(mcmiss),NIL));
449  take_care(tmp);
450  return(tmp);
451  }
452 #else
453  return(cons(ctx,makeint(mchit),cons(ctx,makeint(mcmiss),NIL)));
454 #endif
455 }
456 
458 register context *ctx;
459 int n;
460 pointer argv[];
461 { pointer a;
462  pointer curclass;
463  ckarg(2);
464  a=argv[0];
465  if (isnum(a)) error(E_NOOBJECT);
466  a=findmethod(ctx,argv[1],classof(a), &curclass);
467  if (a!=NIL) a=cons(ctx,curclass,cons(ctx,a,NIL));
468 #ifdef SAFETY
469  take_care(a);
470 #endif
471  return(a);}
472 
473 int getslotindex(obj,klass,varid)
474 register pointer obj,klass,varid;
475 {
476  register int objcix,klasscix,index;
477  register pointer vvec;
478  extern pointer equal();
479 
480  if (!isclass(klass)) error(E_NOCLASS,klass);
481  objcix=obj->cix;
482  klasscix=intval(klass->c.cls.cix);
483  if (objcix>=klasscix && objcix<=classtab[klasscix].subcix) {
484  vvec=klass->c.cls.vars;
485  if (isint(varid)) index=intval(varid);
486  else if (issymbol(varid)) {
487  index=0;
488  while (index<vecsize(vvec))
489  if (vvec->c.vec.v[index]==varid) break; else index++;}
490  else if (isstring(varid)) {
491  index=0;
492  while (index<vecsize(vvec))
493  if (equal(vvec->c.vec.v[index]->c.sym.pname, varid)==T) break;
494  else index++;}
495  else error(E_NOINT);
496  if (index>=vecsize(vvec)) error(E_NOOBJVAR,varid);
497  return(index);}
498  else error(E_NOOBJVAR,varid);}
499 
500 pointer SLOT(ctx,n,argv)
501 register context *ctx;
502 register int n;
503 register pointer argv[];
504 { register pointer a;
505  ckarg(3); /* (slot obj class index) */
506  n=getslotindex(argv[0],argv[1],argv[2]);
507  a=argv[0]->c.obj.iv[n];
508  if (a==UNBOUND) return(QUNBOUND);
509  else return(a);}
510 
511 pointer SETSLOT(ctx,n,argv)
512 register context *ctx;
513 register int n;
514 register pointer argv[];
515 { ckarg(4); /* (setslot obj class index newval) */
516  n=getslotindex(argv[0],argv[1],argv[2]);
517  pointer_update(argv[0]->c.obj.iv[n],argv[3]);
518  return(argv[3]);}
519 
520 /* test methods*/
521 pointer CONSCAR(ctx,n,argv)
522 register context *ctx;
523 int n;
524 pointer argv[];
525 { pointer self=argv[0];
526  if (n>=3) pointer_update(self->c.cons.car,argv[2]);
527  return(self->c.cons.car);}
528 
529 pointer CONSCDR(ctx,n,argv)
530 register context *ctx;
531 int n;
532 pointer argv[];
533 { pointer self=argv[0];
534  if (n>=3) pointer_update(self->c.cons.cdr,argv[2]);
535  return(self->c.cons.cdr);}
536 
537 /****************************************************************/
538 /* copy complex objects preserving reference topology
539 /****************************************************************/
540 
541 #define p_marked(p) (bpointerof(p)->h.pmark)
542 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
543 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
544 
545 static pointer *cpvec;
546 static int cpx;
547 static jmp_buf cpyjmp;
548 
549 pointer copyobj(ctx,org)
550 register context *ctx;
551 register pointer org;
552 { register pointer clone;
553  pointer klass,x;
554  register int i,s;
555  int etype;
556 
557  if (isnum(org) || issymbol(org) || isclass(org)) return(org);
558  /* eus_rbar *//* if ((org==0) || isnum(org) || issymbol(org) || isclass(org)) return(org); */
559  x=org->c.obj.iv[1];
560  if (p_marked(org)) return(cpvec[intval(x)]);
561  p_mark_on(org);
562  klass=classof(org);
563  if (isvecclass(klass)) {
564  etype=elmtypeof(org);
565  s=vecsize(org);
566  clone=makevector(klass,s);
567  elmtypeof(clone)=etype;
568  switch(etype) {
569  case ELM_BIT: s=(s+WORD_SIZE-1)/WORD_SIZE; break;
570  case ELM_BYTE: case ELM_CHAR: s=(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
571  case ELM_FOREIGN: s=1; break; }}
572  else {
573  etype=ELM_FIXED;
574  s=objsize(org);
575  clone=(pointer)makeobject(klass);}
576 
577  if (ctx->vsp>ctx->stacklimit)
578  { p_mark_off(org);
579  fprintf(stderr,"cannot copy\n"); euslongjmp(cpyjmp,ERR);}
580 #ifdef RGC /* R.Hanai */
581  if (etype == ELM_FIXED || etype == ELM_POINTER) {
582  pointer_update(org->c.obj.iv[1],makeint(cpx));
583  } else {
584  org->c.obj.iv[1] = makeint(cpx);
585  }
586 #else
587  pointer_update(org->c.obj.iv[1],makeint(cpx));
588 #endif
589  vpush(clone);
590  vpush(x);
591  cpx += 2;
592  switch (etype) {
593  case ELM_FIXED:
594  clone->c.obj.iv[1]=copyobj(ctx,x);
595  if (s>0) clone->c.obj.iv[0]=copyobj(ctx,org->c.obj.iv[0]);
596  for (i=2; i<s; i++) clone->c.obj.iv[i]=copyobj(ctx,org->c.obj.iv[i]);
597  break;
598  case ELM_POINTER:
599  clone->c.vec.v[0]=copyobj(ctx,x);
600  for (i=1; i<s; i++) clone->c.vec.v[i]=copyobj(ctx,org->c.vec.v[i]);
601  break;
602  default:
603  clone->c.vec.v[0]=x; /*copyobj(ctx,x) fails */
604  for (i=1; i<s; i++) clone->c.ivec.iv[i]=org->c.ivec.iv[i];
605  break;}
606 #ifdef SAFETY
607  take_care(clone);
608 #endif
609  return(clone);}
610 
611 void copyunmark(obj)
612 register pointer obj;
613 { pointer x,klass;
614  register int i,s;
615 
616  if (isnum(obj) || pissymbol(obj) || pisclass(obj)) return;
617  x=obj->c.obj.iv[1];
618  if (p_marked(obj)) {
619  pointer_update(obj->c.obj.iv[1],cpvec[intval(x)+1]);
620  p_mark_off(obj);
621  if (pisvector(obj)) {
622  if (elmtypeof(obj)<ELM_POINTER) return;
623  s=vecsize(obj);
624  for (i=0; i<s; i++) copyunmark(obj->c.vec.v[i]); }
625  else { /* struct object */
626  s=objsize(obj);
627  for (i=0; i<s; i++) copyunmark(obj->c.obj.iv[i]); }
628  }
629  }
630 
631 pointer COPYOBJ(ctx,n,argv)
632 register context *ctx;
633 int n;
634 pointer argv[];
635 { pointer a=argv[0],b;
636  pointer *spsave=ctx->vsp;
637  ckarg(1);
638 #if THREADED
639  mutex_lock(&mark_lock);
640 #endif
641  cpx=0;
642  cpvec= ctx->vsp;
643  if ((b=(pointer)eussetjmp(cpyjmp))==0) b=copyobj(ctx,a);
644  copyunmark(a);
645  ctx->vsp=spsave;
646 #if THREADED
647  mutex_unlock(&mark_lock);
648 #endif
649  ctx->vsp=spsave;
650  if (b==(pointer)ERR) error(E_USER,(pointer)"too big to copy");
651  else return(b);
652  }
653 
654 pointer BECOME(ctx,n,argv)
655 register context *ctx;
656 int n;
657 register pointer argv[];
658 { int e1,e2, newsize;
659  ckarg(2);
660  if (isnum(argv[0])) error(E_NOOBJECT);
661  if (isvecclass(argv[1])) {
662  e1=elmtypeof(argv[0]); e2=intval(argv[1]->c.vcls.elmtype);
663  if (e1==ELM_FIXED) error(E_USER,(pointer)"a record type object cannot become a vector");
664  if (e1==ELM_POINTER && e1!=e2) error(E_USER,(pointer)"element type mismatch");
665  /*chage length field*/
666  n=vecsize(argv[0]);
667  switch(e1) {
668  case ELM_BIT: switch(e2) {
669  case ELM_CHAR: case ELM_BYTE: n=(n+7)/8; break;
670  case ELM_BIT: break;
671  default: n=(n+WORD_SIZE-1)/WORD_SIZE; break;} break;
672  case ELM_CHAR: case ELM_BYTE:
673  switch(e2) {
674  case ELM_CHAR: case ELM_BYTE: break;
675  case ELM_BIT: n*=8; break;
676  default: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;} break;
677  default: switch(e2) {
678  case ELM_CHAR: case ELM_BYTE: n*=sizeof(pointer); break;
679  case ELM_BIT: n*=WORD_SIZE; break;
680  default: break;} break; }
681  argv[0]->c.vec.size=makeint(n);
682  /*change class index*/
683  argv[0]->cix=intval(argv[1]->c.vcls.cix);
684  elmtypeof(argv[0])=e2;
685  return(argv[0]);}
686  else if (isint(argv[1])) {
687  newsize=ckintval(argv[1]);
688  /* get word count to accomodate the newsize of object*/
689  switch(elmtypeof(argv[0])) {
690  case ELM_BIT: n=(newsize+WORD_SIZE-1)/WORD_SIZE; break;
691  case ELM_BYTE: case ELM_CHAR:
692  n=(newsize+(WORD_SIZE/8)-1)/(WORD_SIZE/8); break;
693  default: n=newsize; }
694  if (buddysize[bixof(argv[0])]>=n+2) argv[0]->c.vec.size=makeint(newsize);
695  else error(E_ARRAYINDEX);
696  return(argv[0]);
697  }
698  else error(E_USER,(pointer)"vector class or number expected");
699  }
700 
702 register context *ctx;
703 register int n;
704 pointer argv[];
705 { register pointer dest=argv[0],src=argv[1];
706  int nsrc,ndest;
707  ckarg(2);
708  if (isnum(src) || isnum(dest)) return(src);
709  nsrc=objsize(src); ndest=objsize(dest);
710  n=min(nsrc,ndest);
711  while (n-->0) pointer_update(dest->c.obj.iv[n],src->c.obj.iv[n]);
712  return(dest);}
713 
714 void leo(ctx,mod)
715 register context *ctx;
716 pointer mod;
717 {
718  defun(ctx,"CLASS",mod,GETCLASS,NULL);
719  defun(ctx,"ENTER-CLASS",mod,ENTERCLASS,NULL);
720 /* defspecial("DEFCLASS",mod,DEFCLASS); */
721  defspecial(ctx,"DEFMETHOD",mod,DEFMETHOD);
722  defun(ctx,"SEND",mod,SEND,NULL);
723  defun(ctx,"SEND-MSG",mod,SEND,NULL);
724  defun(ctx,"SEND-IF-FOUND",mod,SEND_IF_FOUND,NULL);
725  defun(ctx,"SEND-MESSAGE",mod,SENDMESSAGE,NULL);
726  defun(ctx,"INSTANTIATE",mod,INSTANTIATE,NULL);
727  defun(ctx,"CLASSP",mod,CLASSP,NULL);
728  defun(ctx,"SUBCLASSP",mod,SUBCLASSP,NULL);
729  defun(ctx,"DERIVEDP",mod,DERIVEDP,NULL);
730  defun(ctx,"CLONE",mod,CLONE,NULL);
731  defun(ctx,"SLOT",mod,SLOT,NULL);
732  defun(ctx,"SETSLOT",mod,SETSLOT,NULL);
733  defun(ctx,"FIND-METHOD",mod,FINDMETHOD,NULL);
734  defunpkg(ctx,"METHOD-CACHE",mod,METHCACHE,syspkg);
735  addcmethod(ctx,mod,CONSCAR,defkeyword(ctx,"CAR"),QCONS,NIL);
736  addcmethod(ctx,mod,CONSCDR,defkeyword(ctx,"CDR"),QCONS,NIL);
737  defun(ctx,"COPY-OBJECT",mod,COPYOBJ,NULL);
738  defun(ctx,"BECOME",mod,BECOME,NULL);
739  defun(ctx,"REPLACE-OBJECT",mod,REPLACEOBJECT,NULL);
740  }
741 
SETSLOT
pointer SETSLOT(context *ctx, int n, argv)
Definition: leo.c:511
methdef::method
pointer method
Definition: eus.h:519
cell::cellunion::cls
struct _class cls
Definition: eus.h:418
REPLACEOBJECT
pointer REPLACEOBJECT(context *ctx, int n, argv)
Definition: leo.c:701
fastbind
struct bindframe * fastbind(context *, pointer, pointer, struct bindframe *)
Definition: eval.c:180
NIL
pointer NIL
Definition: eus.c:110
QCONS
pointer QCONS
Definition: eus.c:151
QUNBOUND
pointer QUNBOUND
Definition: eus.c:123
copyobj
pointer copyobj(context *ctx, pointer org)
Definition: leo.c:549
_class::methods
pointer methods
Definition: eus.h:331
body
static GLfloat body[][2]
Definition: dinoshade.c:75
defun
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
FINDMETHOD
pointer FINDMETHOD(context *ctx, int n, argv)
Definition: leo.c:457
QINTEGER
pointer QINTEGER
Definition: eus.c:120
SEND_IF_FOUND
pointer SEND_IF_FOUND(context *ctx, int n, argv)
Definition: leo.c:315
makeint
#define makeint(v)
Definition: sfttest.c:2
context
Definition: eus.h:524
symbol::plist
pointer plist
Definition: eus.h:203
enterclass
void enterclass(pointer)
Definition: makes.c:343
_class::super
pointer super
Definition: eus.h:326
defkeyword
pointer defkeyword(context *, char *)
Definition: makes.c:733
s
short s
Definition: structsize.c:2
mchit
int mchit
Definition: leo.c:21
E_NOCLASS
@ E_NOCLASS
Definition: eus.h:962
methdef
Definition: eus.h:518
CONSCAR
pointer CONSCAR(context *ctx, int n, argv)
Definition: leo.c:521
mcmiss
int mcmiss
Definition: leo.c:21
makevector
pointer makevector(pointer, int)
Definition: makes.c:417
SEND
pointer SEND(context *ctx, int n, argv)
Definition: leo.c:250
addmethod
void addmethod(context *ctx, pointer meth, pointer class, pointer doc)
Definition: leo.c:90
intval
#define intval(p)
Definition: sfttest.c:1
min
#define min(x, y)
Definition: rmflags.c:17
findforward
pointer findforward(context *ctx, pointer selector, pointer klass, pointer obj, pointer *component, pointer *classfound)
Definition: leo.c:234
T
pointer T
Definition: eus.c:110
METHCACHE
pointer METHCACHE(context *ctx, int n, argv)
Definition: leo.c:433
CLASSP
pointer CLASSP(context *ctx, int n, argv)
Definition: leo.c:32
pointer
struct cell * pointer
Definition: eus.h:165
funlambda
pointer funlambda(context *, pointer, pointer, pointer, pointer *, struct bindframe *, int)
Definition: eval.c:346
E_MISMATCHARG
@ E_MISMATCHARG
Definition: eus.h:942
eus.h
cell::cellunion::sym
struct symbol sym
Definition: eus.h:401
CLONE
pointer CLONE(context *ctx, int n, argv)
Definition: leo.c:403
mark_lock
mutex_t mark_lock
Definition: mthread.c:25
ENTERCLASS
pointer ENTERCLASS(context *ctx, int n, argv)
Definition: leo.c:75
symbol::pname
pointer pname
Definition: eus.h:207
DEFMETHOD
pointer DEFMETHOD(context *ctx, pointer arg)
Definition: leo.c:144
funcode
pointer funcode(context *, pointer, pointer, int)
Definition: eval.c:1410
makeobject
pointer makeobject(pointer)
Definition: makes.c:407
unbindspecial
void unbindspecial(context *, struct specialbindframe *)
Definition: eval.c:165
putprop
pointer putprop(context *, pointer, pointer, pointer)
Definition: specials.c:1235
SELF
pointer SELF
Definition: eus.c:116
cell::cellunion::ivec
struct intvector ivec
Definition: eus.h:416
assq
pointer assq(pointer, pointer)
Definition: lists.c:317
_class::cix
pointer cix
Definition: eus.h:327
SLOT
pointer SLOT(context *ctx, int n, argv)
Definition: leo.c:500
SUBCLASSP
pointer SUBCLASSP(context *ctx, int n, argv)
Definition: leo.c:40
cpyjmp
static jmp_buf cpyjmp
Definition: leo.c:547
cons
Definition: eus.h:195
K_NOMETHOD
pointer K_NOMETHOD
Definition: eus.c:132
CLASS
pointer CLASS
Definition: eus.c:118
cell::c
union cell::cellunion c
E_ARRAYINDEX
@ E_ARRAYINDEX
Definition: eus.h:967
cons::cdr
pointer cdr
Definition: eus.h:197
cell::elmtype
unsigned elmtype
Definition: eus.h:389
K_CLASS
pointer K_CLASS
Definition: eus.c:176
trycache
int trycache
Definition: leo.c:21
cell::cix
short cix
Definition: eus.h:398
NULL
#define NULL
Definition: transargv.c:8
defunpkg
pointer defunpkg(context *, char *, pointer, pointer(*)(), pointer)
Definition: makes.c:636
GETCLASS
pointer GETCLASS(context *ctx, int n, argv)
Definition: leo.c:23
E_NOOBJECT
@ E_NOOBJECT
Definition: eus.h:984
findmethod
pointer findmethod(context *ctx, pointer sel, pointer search, pointer *curclass)
Definition: leo.c:203
leo
void leo(context *ctx, pointer mod)
Definition: leo.c:714
E_NOMETHOD
@ E_NOMETHOD
Definition: eus.h:968
vector::v
pointer v[1]
Definition: eus.h:301
euscontexts
context * euscontexts[MAXTHREAD]
Definition: eus.c:105
classtab
struct class_desc classtab[MAXCLASS]
Definition: eus.c:138
class::methods
pointer methods
Definition: eus.old.h:215
bindframe
Definition: eus.h:479
K_METHOD_DOCUMENTATION
pointer K_METHOD_DOCUMENTATION
Definition: eus.c:176
cell::cellunion::cons
struct cons cons
Definition: eus.h:400
K_INTEGER
pointer K_INTEGER
Definition: eus.c:132
rcsid
static char * rcsid
Definition: leo.c:11
object::iv
pointer iv[2]
Definition: eus.h:321
syspkg
pointer syspkg
Definition: eus.c:109
copyunmark
void copyunmark(pointer obj)
Definition: leo.c:611
QSELF
pointer QSELF
Definition: eus.c:114
cons
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
vector::size
pointer size
Definition: eus.h:300
cell::cellunion::obj
struct object obj
Definition: eus.h:417
E_UNBOUND
@ E_UNBOUND
Definition: eus.h:940
E_NOLIST
@ E_NOLIST
Definition: eus.h:949
E_NOINT
@ E_NOINT
Definition: eus.h:956
addcmethod
void addcmethod(context *ctx, pointer mod, pointer(*cfunc)(), pointer sel, pointer class, pointer doc)
Definition: leo.c:133
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
count
int count
Definition: thrtest.c:11
makecode
pointer makecode(pointer, pointer(*)(), pointer)
Definition: makes.c:282
cpvec
static pointer * cpvec
Definition: leo.c:545
QFLOAT
pointer QFLOAT
Definition: eus.c:120
DERIVEDP
pointer DERIVEDP(context *ctx, int n, argv)
Definition: leo.c:52
methdef::selector
pointer selector
Definition: eus.h:519
cell
Definition: eus.h:381
eusinteger_t
long eusinteger_t
Definition: eus.h:19
methdef::class
pointer class
Definition: eus.h:519
defspecial
pointer defspecial(context *, char *, pointer, pointer(*)())
Definition: makes.c:682
buddysize
long buddysize[MAXBUDDY+1]
Definition: eus.c:103
getslotindex
int getslotindex(pointer obj, pointer klass, pointer varid)
Definition: leo.c:473
specialbindframe
Definition: eus.h:484
index
char * index(char *sp, char c)
Definition: eustags.c:1669
E_INSTANTIATE
@ E_INSTANTIATE
Definition: eus.h:966
E_USER
@ E_USER
Definition: eus.h:1006
COPYOBJ
pointer COPYOBJ(context *ctx, int n, argv)
Definition: leo.c:631
ufuncall
pointer ufuncall(context *, pointer, pointer, pointer, struct bindframe *, int)
Definition: eval.c:1469
INSTANTIATE
pointer INSTANTIATE(context *ctx, int n, argv)
Definition: leo.c:161
CONSCDR
pointer CONSCDR(context *ctx, int n, argv)
Definition: leo.c:529
_class::forwards
pointer forwards
Definition: eus.h:330
intvector::iv
eusinteger_t iv[1]
Definition: eus.h:305
cell::cellunion::vec
struct vector vec
Definition: eus.h:414
a
char a[26]
Definition: freq.c:4
equal
pointer equal(pointer, pointer)
Definition: predicates.c:162
memq
pointer memq()
class
Definition: eus.old.h:207
E_NOSYMBOL
@ E_NOSYMBOL
Definition: eus.h:948
n
GLfloat n[6][3]
Definition: cube.c:15
methdef::ownerclass
pointer ownerclass
Definition: eus.h:519
E_NOOBJVAR
@ E_NOOBJVAR
Definition: eus.h:976
cpx
static int cpx
Definition: leo.c:546
SENDMESSAGE
pointer SENDMESSAGE(context *ctx, int n, argv)
Definition: leo.c:363
K_FLOAT
pointer K_FLOAT
Definition: eus.c:133
v
GLfloat v[8][3]
Definition: cube.c:21
BECOME
pointer BECOME(context *ctx, int n, argv)
Definition: leo.c:654
_class::vars
pointer vars
Definition: eus.h:328
ckarg
ckarg(2)


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:43