leo.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* LEO.C
00003 /*      Object Oriented Programming Facilities
00004 /*      Every data structures in EUS is defined as an object.
00005 /*      Refer to eus.h and makes.c for the detail of the structures
00006 /*      of objects.
00007 /*
00008 /*      Copyright: Toshihiro Matsui, Electrotechnical Laboratory
00009 /*      Original: 1986-May
00010 /*      */
00011 static char *rcsid="@(#)$Id$";
00012 
00013 #include "eus.h"
00014 
00015 extern pointer K_METHOD_DOCUMENTATION;
00016 
00017 #if THREADED
00018 /* static mutex_t mcache_lock; */ /* This variable is not used. */
00019 #endif
00020 
00021 int mchit=0, mcmiss=0, trycache=1;      /*statistic for method cacheing*/
00022 
00023 pointer GETCLASS(ctx,n,argv)
00024 register context *ctx;
00025 int n;
00026 pointer argv[];
00027 { pointer v;
00028   ckarg(1);
00029   if (isnum(argv[0])) return(NIL);
00030   return(classof(argv[0]));}
00031 
00032 pointer CLASSP(ctx,n,argv)
00033 register context *ctx;
00034 int n;
00035 pointer argv[];
00036 { 
00037   if (n!=1) error(E_MISMATCHARG);
00038   return(isclass(argv[0])?T:NIL);}
00039 
00040 pointer SUBCLASSP(ctx,n,argv)
00041 register context *ctx;
00042 int n;
00043 register pointer argv[];
00044 { register int k,s;
00045   ckarg(2);
00046   if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
00047   if (!isclass(argv[1])) error(E_NOCLASS,argv[1]);
00048   k=intval(argv[0]->c.cls.cix);
00049   s=intval(argv[1]->c.cls.cix);
00050   if  (k>=s && k<=classtab[s].subcix) return(T); else return(NIL); }
00051 
00052 pointer DERIVEDP(ctx,n,argv)
00053 register context *ctx;
00054 int n;
00055 pointer argv[];
00056 { register pointer obj,klass;
00057   register int objcix,klasscix;
00058   ckarg(2);
00059   obj=argv[0]; klass=argv[1];
00060   if (isnum(obj)) {
00061     if ((klass==QFLOAT || klass==K_FLOAT)&& isflt(obj)) return(T);
00062     else if ((klass==QINTEGER || klass==K_INTEGER) && isint(obj)) return(T);
00063     else return(NIL);}
00064   if (!isclass(klass)) error(E_NOCLASS,klass);
00065   objcix=obj->cix;
00066   klasscix=intval(klass->c.cls.cix);
00067   if (objcix>=klasscix && objcix<=classtab[klasscix].subcix) return(T);
00068   else return(NIL);}
00069 
00070 
00071 /****************************************************************/
00072 /* define new class
00073 /****************************************************************/
00074 
00075 pointer ENTERCLASS(ctx,n,argv)
00076 register context *ctx;
00077 int n;
00078 register pointer argv[];
00079 { ckarg(1);
00080   if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
00081   enterclass(argv[0]);
00082   return(argv[0]);}
00083 
00084 /****************************************************************/
00085 /* add new method definition to a class
00086 /****************************************************************/
00087         
00088 extern pointer K_CLASS;
00089 
00090 void addmethod(ctx,meth,class,doc)
00091 register context *ctx;
00092 register pointer meth,class,doc;
00093 { extern pointer putprop(), assq();
00094   register pointer selector,methods,classes,medoc,medoc2;
00095   register int i,j;
00096   vpush(meth);
00097   selector=ccar(meth); methods=class->c.cls.methods;
00098   if (!issymbol(selector)) error(E_NOSYMBOL);
00099   classes=assq(K_CLASS,selector->c.sym.plist);
00100   if (classes!=NIL) classes=ccdr(classes);
00101   putprop(ctx,selector,cons(ctx,class,classes),K_CLASS);
00102 /* */
00103   if (doc!=NIL) {
00104     medoc=assq(K_METHOD_DOCUMENTATION, selector->c.sym.plist);
00105 /*    prinx(medoc,STDOUT); */
00106     if (medoc==NIL) putprop(ctx,selector,cons(ctx,cons(ctx,class,doc),NIL),
00107                                      K_METHOD_DOCUMENTATION);
00108     else {
00109       medoc2=assq(class,ccdr(medoc));
00110       if (medoc2==NIL)
00111       {pointer_update(medoc->c.cons.cdr,cons(ctx,cons(ctx,class,doc),ccdr(medoc)));}
00112       else pointer_update(medoc2->c.cons.cdr,doc); } }
00113 /* */
00114   if (methods==NIL) {pointer_update(class->c.cls.methods,cons(ctx,meth,NIL));}
00115   else if (ccar(ccar(methods))==selector) {pointer_update(ccar(methods),meth);}
00116   else {
00117     while(ccdr(methods)!=NIL) {
00118       methods=ccdr(methods);
00119       if (ccar(ccar(methods))==selector) {
00120         ccar(methods)=meth;
00121         goto purgecache; } }
00122     pointer_update(ccdr(methods),cons(ctx,meth,NIL)); }
00123   /*nullify method cache for this selctor*/
00124 purgecache:
00125   vpop();
00126   for (j=0; j<MAXTHREAD; j++) {
00127     if ((ctx=euscontexts[j]))
00128       for (i=0; i<MAXMETHCACHE; i++) 
00129         if (ctx->methcache[i].selector==selector)
00130           pointer_update(ctx->methcache[i].selector,NIL); }
00131   }
00132   
00133 void addcmethod(ctx,mod,cfunc,sel,class,doc)
00134 register context *ctx;
00135 pointer sel,mod,class,doc;
00136 pointer (*cfunc)();
00137 { if (!issymbol(class)) error(E_NOCLASS,class);
00138   class=speval(class);
00139   if (class==UNBOUND || !isclass(class)) error(E_NOCLASS,class);
00140   addmethod(ctx,cons(ctx,sel,
00141                         cons(ctx,makecode(mod,cfunc,SUBR_FUNCTION),NIL)),
00142                 class,doc);}
00143 
00144 pointer DEFMETHOD(ctx,arg)      /*special form*/
00145 register context *ctx;
00146 pointer arg;
00147 { register pointer class,selector,classsym,body,doc;
00148   classsym=carof(arg,E_MISMATCHARG); arg=ccdr(arg);
00149   if (!issymbol(classsym)) error(E_NOSYMBOL);
00150   class=speval(classsym);
00151   if (class==UNBOUND) error(E_UNBOUND,classsym);
00152   if (!isclass(class)) error(E_NOCLASS,class);
00153   while (islist(arg)) {
00154     body=ccar(arg);     /* (:selector (args) . body) */
00155     if (!iscons(body)) error(E_NOLIST);
00156     doc=ccdr(ccdr(body));
00157     if (isstring(ccar(doc))) doc=ccar(doc); else doc=NIL;
00158     addmethod(ctx,body,class,doc); arg=ccdr(arg);}
00159   return(classsym);}
00160 
00161 pointer INSTANTIATE(ctx,n,argv)
00162 register context *ctx;
00163 int n;
00164 pointer argv[];
00165 { pointer a;
00166   int s;
00167   extern pointer makeobject();
00168   a=argv[0];
00169   if (isvecclass(a)) {
00170     s=intval(a->c.vcls.size);
00171     if (s<0) { ckarg(2); s=ckintval(argv[1]);}
00172     else ckarg(1);
00173 #ifdef SAFETY
00174     {
00175       pointer tmp = makevector(a,s);
00176       take_care(tmp);
00177       return(tmp);
00178     }
00179 #else
00180     return(makevector(a,s));
00181 #endif
00182   }
00183   else if (isclass(a)) {
00184     ckarg(1);
00185 #ifdef SAFETY
00186     {
00187       pointer tmp = makeobject(a);
00188       take_care(tmp);
00189       return(tmp);
00190     }
00191 #else
00192     return(makeobject(a));
00193 #endif
00194   }
00195   else error(E_NOCLASS,a);}
00196 
00197 
00198 /****************************************************************/
00199 /* send a message to an object
00200 /*      method is searched by method-cache
00201 /*****************************************************************/
00202 
00203 pointer findmethod(ctx,sel,search, curclass)
00204 register context *ctx;
00205 register pointer sel,search, *curclass;
00206 { register pointer meths,klass=search;
00207   register struct methdef *mt;
00208   register int h;
00209 
00210   if (trycache) {
00211     h=(((eusinteger_t)sel+(eusinteger_t)klass)>>3) & (MAXMETHCACHE-1);/* ???? */
00212     mt= &ctx->methcache[h];
00213     if (mt->selector==sel && mt->class==search) {
00214       /* hit! */
00215       mchit++;
00216       *curclass = mt->ownerclass;
00217       return(mt->method);}}
00218   while (isclass(klass) || isvecclass(klass)) {
00219     mcmiss++;
00220     meths=klass->c.cls.methods;
00221     while (islist(meths))       /*find the method in this class*/
00222       if (ccar(ccar(meths))==sel) {
00223         if (trycache) {
00224             pointer_update(mt->selector,sel);
00225             pointer_update(mt->class,search);
00226             pointer_update(mt->ownerclass,klass);
00227             pointer_update(mt->method,ccar(meths));
00228           }
00229         *curclass = klass; return(ccar(meths));}
00230       else meths=ccdr(meths);
00231     klass= /*spevalof*/ (klass->c.cls.super);} /*try superclass*/
00232   return(NIL);}
00233 
00234 pointer findforward(ctx,selector,klass,obj,component,classfound)
00235 context *ctx;
00236 register pointer selector,klass,obj, *component, *classfound;
00237 { register pointer forwards=klass->c.cls.forwards,flist,meth;
00238   register int i=0,vcount=vecsize(forwards);
00239   while (i<vcount) {
00240     flist=forwards->c.vec.v[i];
00241     if (flist==T || memq(selector,flist)!=NIL) {
00242       *component = obj->c.obj.iv[i];
00243       if (!isnum(*component)) {
00244         meth=findmethod(ctx,selector,classof(*component),classfound);
00245         if (meth!=NIL) return(meth);}
00246       else error(E_NOOBJECT);}
00247     i++;}
00248   return(NIL);}
00249 
00250 pointer SEND(ctx,n,argv)
00251 register context *ctx;
00252 int n;
00253 register pointer argv[];
00254 { register pointer receiver,klass,selector,meth,result;
00255   register pointer *spsave=ctx->vsp, *altargv;
00256   pointer curclass, component;
00257   struct bindframe *bf,*bfsave=ctx->bindfp;
00258   struct specialbindframe *sbfpsave=ctx->sbindfp;
00259   int sbcount=ctx->special_bind_count;
00260   int i,argoffset;
00261 #if defined(DEBUG_COUNT) || defined(SEND_DEBUG)
00262   static int count = 0;
00263 
00264   count++;
00265 #endif
00266 
00267 #ifdef SEND_DEBUG
00268   printf( "SEND:%d\n", count );
00269 #endif
00270 
00271   if (n<2) error(E_MISMATCHARG);
00272   receiver=argv[0];
00273   selector=argv[1];
00274   if (isnum(receiver)) error(E_NOOBJECT);
00275   klass=classof(receiver);
00276   meth=findmethod(ctx,selector,klass, &curclass);
00277   if (meth==NIL) {
00278     /*try forwarding*/
00279     meth=findforward(ctx,selector,klass,receiver, &component, &curclass);
00280     if (meth!=NIL) { argv[0]=component; receiver=component; argoffset=2;}
00281     else {
00282       meth=findmethod(ctx,K_NOMETHOD,klass, &curclass);
00283       if (meth==NIL) error(E_NOMETHOD,selector);
00284       if (iscode(ccar(ccdr(meth)))) {
00285         altargv=ctx->vsp;
00286         vpush(receiver);  vpush(selector);
00287         i=1;
00288         while (i<n) ckpush(argv[i++]);
00289         argv=altargv;
00290         n++;}
00291       else argoffset=1;} }
00292   else argoffset=2;
00293 
00294   if (iscode(ccar(ccdr(meth)))) {
00295     argv[1]=curclass;
00296     result=funcode(ctx,ccar(ccdr(meth)),(pointer)argv,n);
00297     }
00298   else {
00299     bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
00300 #if SunOS4_1
00301     bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */ 
00302 #else
00303     bf=fastbind(ctx,SELF,receiver,bf);
00304 #endif
00305     bf=fastbind(ctx,CLASS,curclass,bf);
00306     result=funlambda(ctx,ccar(meth),ccar(ccdr(meth)),ccdr(ccdr(meth)),
00307                      &argv[argoffset],bf,n-argoffset);
00308     ctx->bindfp=bfsave;
00309     /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
00310     unbindspecial(ctx,sbfpsave+1);
00311     } 
00312   ctx->vsp=spsave;
00313   return(result);}
00314 
00315 pointer SEND_IF_FOUND(ctx,n,argv)
00316 register context *ctx;
00317 int n;
00318 register pointer argv[];
00319 { register pointer receiver,klass,selector,meth,result;
00320   register pointer *spsave=ctx->vsp,*altargv;
00321   pointer curclass, component;
00322   struct bindframe *bf,*bfsave=ctx->bindfp;
00323   struct specialbindframe *sbfpsave=ctx->sbindfp;
00324   int argoffset;
00325 
00326   if (n<3) error(E_MISMATCHARG);
00327   receiver=argv[1];
00328   selector=argv[2];
00329   if (isnum(receiver)) return(argv[0]);
00330   klass=classof(receiver);
00331   meth=findmethod(ctx,selector,klass, &curclass);
00332   if (meth==NIL) {
00333     /*try forwarding*/
00334     meth=findforward(ctx,selector,klass,receiver, &component, NULL);
00335     if (meth!=NIL) { argv[1]=component; receiver=component; argoffset=3;}
00336     else return(argv[0]); }
00337   else argoffset=3;
00338 
00339   if (iscode(ccar(ccdr(meth)))) {
00340     argv[2]=curclass;
00341     result=funcode(ctx,ccar(ccdr(meth)), (pointer)&argv[1],n-1);
00342     }
00343   else {
00344     bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
00345 #if SunOS4_1
00346     bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */
00347 #else
00348     bf=fastbind(ctx,SELF,receiver,bf);
00349 #endif
00350     bf=fastbind(ctx,CLASS,curclass,bf);
00351     result=funlambda(ctx,ccar(meth),ccar(ccdr(meth)),ccdr(ccdr(meth)),
00352                      &argv[argoffset],bf,n-argoffset);
00353     ctx->bindfp=bfsave;
00354     /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
00355     unbindspecial(ctx,sbfpsave+1);
00356     }
00357   ctx->vsp=spsave;
00358 #ifdef SAFETY
00359   take_care(result);
00360 #endif
00361   return(result);}
00362 
00363 pointer SENDMESSAGE(ctx,n,argv)
00364 register context *ctx;
00365 int n;
00366 pointer argv[];
00367 /* (send-message obj search selector [args]) */
00368 { pointer receiver,search,selector,meth,form,result,*spsave, curclass;
00369   struct bindframe *bf,*bfsave=ctx->bindfp;
00370   struct specialbindframe *sbfpsave=ctx->sbindfp;
00371 
00372   if (n<3) error(E_MISMATCHARG);
00373   receiver=argv[0]; search=argv[1]; selector=argv[2];
00374   if (issymbol(search)) search=speval(search);
00375   if (search==UNBOUND || (!isclass(search) && !isvecclass(search)))
00376     error(E_NOCLASS,search);
00377 
00378   meth=findmethod(ctx,selector,search, &curclass);
00379   if (meth==NIL) error(E_NOMETHOD);
00380   form=ctx->callfp->form;
00381   if (iscode(ccar(ccdr(meth)))) {
00382     argv[1]=receiver; argv[2]=curclass;
00383     result=ufuncall(ctx,form,ccar(ccdr(meth)),(pointer)&argv[1],NULL,n-1);}
00384   else {
00385     spsave=ctx->vsp;
00386     bf=fastbind(ctx,classof(receiver)->c.cls.vars,receiver,NULL);
00387 #if SunOS4_1
00388     bf=fastbind(ctx,QSELF,receiver,bf); /* SunOS 4.1 already use SELF */
00389 #else
00390     bf=fastbind(ctx,SELF,receiver,bf);
00391 #endif
00392     bf=fastbind(ctx,CLASS,curclass,bf);
00393     result=ufuncall(ctx,form,meth,(pointer)&argv[3],bf,n-3);
00394     ctx->bindfp=bfsave;
00395     /* while (sbfpsave<ctx->sbindfp) unbindx(ctx,1); */
00396     unbindspecial(ctx,sbfpsave+1);
00397     ctx->vsp=spsave;}
00398 #ifdef SAFETY
00399   take_care(result);
00400 #endif
00401   return(result);}
00402 
00403 pointer CLONE(ctx,n,argv)
00404 register context *ctx;
00405 int n;
00406 pointer argv[];
00407 { pointer a=argv[0],klass,x;
00408   register int i,s;
00409   int etype;
00410   ckarg(1);
00411   if (ispointer(a)) {
00412     klass=classof(a);
00413     if (isvecclass(klass)) {
00414       etype=intval(klass->c.vcls.elmtype);
00415       s=vecsize(a);
00416       switch(etype) {
00417         case ELM_BIT: n=(s+WORD_SIZE-1)/WORD_SIZE; break;
00418         case ELM_CHAR: case ELM_BYTE: n=(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
00419         default: n=s; break;}
00420       n++;
00421       x=makevector(klass,s);
00422       }
00423     else {
00424       n=vecsize(klass->c.cls.vars);
00425       x=makeobject(klass);}
00426     for (i=0; i<n; i++) x->c.obj.iv[i]=a->c.obj.iv[i];
00427 #ifdef SAFETY
00428     take_care(x);
00429 #endif
00430     return(x);}
00431   else error(E_INSTANTIATE);}
00432 
00433 pointer METHCACHE(ctx,n,argv)
00434 register context *ctx;
00435 int n;
00436 pointer argv[];
00437 { /* return method cache hit ratio*/
00438   register int i;
00439   if (n==1) {
00440     trycache=(argv[0]!=NIL);
00441     for (i=0; i<MAXMETHCACHE; i++) {
00442        pointer_update(ctx->methcache[i].class,NIL);
00443        pointer_update(ctx->methcache[i].selector,NIL);
00444     }
00445   }
00446 #ifdef SAFETY
00447   {
00448     pointer tmp = cons(ctx,makeint(mchit),cons(ctx,makeint(mcmiss),NIL));
00449     take_care(tmp);
00450     return(tmp);
00451   }
00452 #else
00453   return(cons(ctx,makeint(mchit),cons(ctx,makeint(mcmiss),NIL)));
00454 #endif
00455 }
00456 
00457 pointer FINDMETHOD(ctx,n,argv)
00458 register context *ctx;
00459 int n;
00460 pointer argv[];
00461 { pointer a;
00462   pointer curclass;
00463   ckarg(2);
00464   a=argv[0];
00465   if (isnum(a)) error(E_NOOBJECT);
00466   a=findmethod(ctx,argv[1],classof(a), &curclass);
00467   if (a!=NIL)  a=cons(ctx,curclass,cons(ctx,a,NIL));
00468 #ifdef SAFETY
00469   take_care(a);
00470 #endif
00471   return(a);}
00472 
00473 int getslotindex(obj,klass,varid)
00474 register pointer obj,klass,varid;
00475 { 
00476   register int objcix,klasscix,index;
00477   register pointer vvec;
00478   extern pointer equal();
00479 
00480   if (!isclass(klass)) error(E_NOCLASS,klass);
00481   objcix=obj->cix;
00482   klasscix=intval(klass->c.cls.cix);
00483   if (objcix>=klasscix && objcix<=classtab[klasscix].subcix) {
00484     vvec=klass->c.cls.vars;
00485     if (isint(varid)) index=intval(varid);
00486     else if (issymbol(varid)) {
00487       index=0;
00488       while (index<vecsize(vvec))
00489         if (vvec->c.vec.v[index]==varid) break;  else index++;}
00490     else if (isstring(varid)) {
00491       index=0;
00492       while (index<vecsize(vvec))
00493         if (equal(vvec->c.vec.v[index]->c.sym.pname, varid)==T) break;
00494         else index++;}
00495     else error(E_NOINT);
00496     if (index>=vecsize(vvec)) error(E_NOOBJVAR,varid);
00497     return(index);}
00498   else error(E_NOOBJVAR,varid);}
00499 
00500 pointer SLOT(ctx,n,argv)
00501 register context *ctx;
00502 register int n;
00503 register pointer argv[];
00504 { register pointer a;
00505   ckarg(3);     /* (slot obj class index) */
00506   n=getslotindex(argv[0],argv[1],argv[2]);
00507   a=argv[0]->c.obj.iv[n];
00508   if (a==UNBOUND) return(QUNBOUND);
00509   else return(a);}
00510 
00511 pointer SETSLOT(ctx,n,argv)
00512 register context *ctx;
00513 register int n;
00514 register pointer argv[];
00515 { ckarg(4);     /* (setslot obj class index newval) */
00516   n=getslotindex(argv[0],argv[1],argv[2]);
00517   pointer_update(argv[0]->c.obj.iv[n],argv[3]);
00518   return(argv[3]);}
00519 
00520 /* test methods*/
00521 pointer CONSCAR(ctx,n,argv)
00522 register context *ctx;
00523 int n;
00524 pointer argv[];
00525 { pointer self=argv[0];
00526   if (n>=3) pointer_update(self->c.cons.car,argv[2]);
00527   return(self->c.cons.car);}
00528 
00529 pointer CONSCDR(ctx,n,argv)
00530 register context *ctx;
00531 int n;
00532 pointer argv[];
00533 { pointer self=argv[0];
00534   if (n>=3) pointer_update(self->c.cons.cdr,argv[2]);
00535   return(self->c.cons.cdr);}
00536 
00537 /****************************************************************/
00538 /* copy complex objects preserving reference topology
00539 /****************************************************************/
00540 
00541 #define p_marked(p) (bpointerof(p)->h.pmark)
00542 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
00543 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
00544 
00545 static pointer *cpvec;
00546 static int cpx;
00547 static jmp_buf cpyjmp;
00548 
00549 pointer copyobj(ctx,org)
00550 register context *ctx;
00551 register pointer org;
00552 { register pointer clone;
00553   pointer klass,x;
00554   register int i,s;
00555   int etype;
00556 
00557   if (isnum(org) || issymbol(org) || isclass(org)) return(org);
00558   /* eus_rbar *//* if ((org==0) || isnum(org) || issymbol(org) || isclass(org)) return(org); */
00559   x=org->c.obj.iv[1];
00560   if (p_marked(org)) return(cpvec[intval(x)]);
00561   p_mark_on(org);
00562   klass=classof(org);
00563   if (isvecclass(klass)) {
00564     etype=elmtypeof(org);
00565     s=vecsize(org);
00566     clone=makevector(klass,s);
00567     elmtypeof(clone)=etype;
00568     switch(etype) {
00569       case ELM_BIT: s=(s+WORD_SIZE-1)/WORD_SIZE; break;
00570       case ELM_BYTE: case ELM_CHAR: s=(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
00571         case ELM_FOREIGN: s=1; break; }}
00572   else {
00573     etype=ELM_FIXED;
00574     s=objsize(org);
00575     clone=(pointer)makeobject(klass);}
00576 
00577   if (ctx->vsp>ctx->stacklimit)
00578     { p_mark_off(org);
00579       fprintf(stderr,"cannot copy\n"); euslongjmp(cpyjmp,ERR);}
00580 #ifdef RGC /* R.Hanai */
00581   if (etype == ELM_FIXED || etype == ELM_POINTER) {
00582     pointer_update(org->c.obj.iv[1],makeint(cpx));
00583   } else {
00584     org->c.obj.iv[1] = makeint(cpx);
00585   }
00586 #else
00587   pointer_update(org->c.obj.iv[1],makeint(cpx));
00588 #endif
00589   vpush(clone);
00590   vpush(x);
00591   cpx += 2;
00592   switch (etype) {
00593     case ELM_FIXED:
00594             clone->c.obj.iv[1]=copyobj(ctx,x);
00595             if (s>0) clone->c.obj.iv[0]=copyobj(ctx,org->c.obj.iv[0]);
00596             for (i=2; i<s; i++) clone->c.obj.iv[i]=copyobj(ctx,org->c.obj.iv[i]);
00597             break;
00598     case ELM_POINTER:
00599             clone->c.vec.v[0]=copyobj(ctx,x);
00600             for (i=1; i<s; i++) clone->c.vec.v[i]=copyobj(ctx,org->c.vec.v[i]);
00601             break;
00602     default:
00603             clone->c.vec.v[0]=x; /*copyobj(ctx,x) fails */
00604             for (i=1; i<s; i++) clone->c.ivec.iv[i]=org->c.ivec.iv[i];
00605             break;}
00606 #ifdef SAFETY
00607   take_care(clone);
00608 #endif
00609   return(clone);}
00610 
00611 void copyunmark(obj)
00612 register pointer obj;
00613 { pointer x,klass;
00614   register int i,s;
00615 
00616   if (isnum(obj) || pissymbol(obj) || pisclass(obj)) return;
00617   x=obj->c.obj.iv[1];
00618   if (p_marked(obj)) {
00619     pointer_update(obj->c.obj.iv[1],cpvec[intval(x)+1]);
00620     p_mark_off(obj);
00621     if (pisvector(obj)) {
00622       if (elmtypeof(obj)<ELM_POINTER) return;
00623       s=vecsize(obj);
00624       for (i=0; i<s; i++) copyunmark(obj->c.vec.v[i]); }
00625     else { /* struct object */
00626       s=objsize(obj);
00627       for (i=0; i<s; i++) copyunmark(obj->c.obj.iv[i]); }
00628     }
00629   }
00630 
00631 pointer COPYOBJ(ctx,n,argv)
00632 register context *ctx;
00633 int n;
00634 pointer argv[];
00635 { pointer a=argv[0],b;
00636   pointer *spsave=ctx->vsp;
00637   ckarg(1);
00638 #if THREADED
00639   mutex_lock(&mark_lock);
00640 #endif
00641   cpx=0;
00642   cpvec= ctx->vsp;
00643   if ((b=(pointer)eussetjmp(cpyjmp))==0) b=copyobj(ctx,a); 
00644   copyunmark(a);
00645   ctx->vsp=spsave;
00646 #if THREADED
00647   mutex_unlock(&mark_lock);
00648 #endif
00649   ctx->vsp=spsave;
00650   if (b==(pointer)ERR) error(E_USER,(pointer)"too big to copy");
00651   else return(b);
00652   }
00653 
00654 pointer BECOME(ctx,n,argv)
00655 register context *ctx;
00656 int n;
00657 register pointer argv[];
00658 { int e1,e2, newsize;
00659   ckarg(2);
00660   if (isnum(argv[0])) error(E_NOOBJECT);
00661   if (isvecclass(argv[1])) {
00662     e1=elmtypeof(argv[0]); e2=intval(argv[1]->c.vcls.elmtype);
00663     if (e1==ELM_FIXED) error(E_USER,(pointer)"a record type object cannot become a vector");
00664     if (e1==ELM_POINTER && e1!=e2) error(E_USER,(pointer)"element type mismatch");
00665     /*chage length field*/
00666     n=vecsize(argv[0]);
00667     switch(e1) {
00668     case ELM_BIT: switch(e2) {
00669                     case ELM_CHAR: case ELM_BYTE: n=(n+7)/8; break;
00670                     case ELM_BIT: break;
00671                     default: n=(n+WORD_SIZE-1)/WORD_SIZE; break;} break;
00672     case ELM_CHAR: case ELM_BYTE:
00673                   switch(e2) {
00674                     case ELM_CHAR: case ELM_BYTE: break;
00675                     case ELM_BIT: n*=8; break;
00676                     default: n=(n+sizeof(eusinteger_t)-1)/sizeof(eusinteger_t); break;} break;
00677     default:      switch(e2) {
00678                     case ELM_CHAR: case ELM_BYTE: n*=sizeof(pointer); break;
00679                     case ELM_BIT: n*=WORD_SIZE; break;
00680                     default: break;} break; }
00681     argv[0]->c.vec.size=makeint(n);
00682     /*change class index*/
00683     argv[0]->cix=intval(argv[1]->c.vcls.cix);
00684     elmtypeof(argv[0])=e2;
00685     return(argv[0]);}
00686   else if (isint(argv[1])) {
00687     newsize=ckintval(argv[1]);
00688     /* get word count to accomodate the newsize of object*/ 
00689     switch(elmtypeof(argv[0])) {
00690       case ELM_BIT: n=(newsize+WORD_SIZE-1)/WORD_SIZE; break;
00691       case ELM_BYTE: case ELM_CHAR:
00692                 n=(newsize+(WORD_SIZE/8)-1)/(WORD_SIZE/8); break; 
00693       default: n=newsize; }
00694     if (buddysize[bixof(argv[0])]>=n+2)  argv[0]->c.vec.size=makeint(newsize);
00695     else error(E_ARRAYINDEX);
00696     return(argv[0]);
00697     }
00698   else error(E_USER,(pointer)"vector class or number expected");
00699   }
00700 
00701 pointer REPLACEOBJECT(ctx,n,argv)
00702 register context *ctx;
00703 register int n;
00704 pointer argv[];
00705 { register pointer dest=argv[0],src=argv[1];
00706   int nsrc,ndest;
00707   ckarg(2);
00708   if (isnum(src) || isnum(dest)) return(src);
00709   nsrc=objsize(src); ndest=objsize(dest);
00710   n=min(nsrc,ndest);
00711   while (n-->0) pointer_update(dest->c.obj.iv[n],src->c.obj.iv[n]);
00712   return(dest);}
00713 
00714 void leo(ctx,mod)
00715 register context *ctx;
00716 pointer mod;
00717 {
00718   defun(ctx,"CLASS",mod,GETCLASS,NULL);
00719   defun(ctx,"ENTER-CLASS",mod,ENTERCLASS,NULL);
00720 /*  defspecial("DEFCLASS",mod,DEFCLASS); */
00721   defspecial(ctx,"DEFMETHOD",mod,DEFMETHOD);
00722   defun(ctx,"SEND",mod,SEND,NULL);
00723   defun(ctx,"SEND-MSG",mod,SEND,NULL);
00724   defun(ctx,"SEND-IF-FOUND",mod,SEND_IF_FOUND,NULL);
00725   defun(ctx,"SEND-MESSAGE",mod,SENDMESSAGE,NULL);
00726   defun(ctx,"INSTANTIATE",mod,INSTANTIATE,NULL);
00727   defun(ctx,"CLASSP",mod,CLASSP,NULL);
00728   defun(ctx,"SUBCLASSP",mod,SUBCLASSP,NULL);
00729   defun(ctx,"DERIVEDP",mod,DERIVEDP,NULL);
00730   defun(ctx,"CLONE",mod,CLONE,NULL);
00731   defun(ctx,"SLOT",mod,SLOT,NULL);
00732   defun(ctx,"SETSLOT",mod,SETSLOT,NULL);
00733   defun(ctx,"FIND-METHOD",mod,FINDMETHOD,NULL);
00734   defunpkg(ctx,"METHOD-CACHE",mod,METHCACHE,syspkg);
00735   addcmethod(ctx,mod,CONSCAR,defkeyword(ctx,"CAR"),QCONS,NIL);
00736   addcmethod(ctx,mod,CONSCDR,defkeyword(ctx,"CDR"),QCONS,NIL);
00737   defun(ctx,"COPY-OBJECT",mod,COPYOBJ,NULL);
00738   defun(ctx,"BECOME",mod,BECOME,NULL);
00739   defun(ctx,"REPLACE-OBJECT",mod,REPLACEOBJECT,NULL);
00740   }
00741 


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53