sysfunc.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* system management functions
00003 /*      1986-Aug
00004 /*      T.Matsui, ETL 
00005 /****************************************************************/
00006 static char *rcsid="@(#)$Id$";
00007 
00008 #include "eus.h"
00009 
00010 #define p_marked(p) (bpointerof(p)->h.pmark)
00011 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
00012 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
00013 
00014 extern long freeheap,totalheap;
00015 extern struct chunk *chunklist;
00016 extern long gccount,marktime,sweeptime;
00017 extern pointer stacknlist(),stacklist();
00018 extern jmp_buf topjbuf;
00019 extern long alloccount[MAXBUDDY];
00020 
00021 pointer GEESEE(ctx,n,argv)
00022 register context *ctx;
00023 int n;
00024 pointer argv[];
00025 { gc();
00026   return(cons(ctx,makeint(freeheap),
00027               cons(ctx,makeint(totalheap),NIL)));}
00028 
00029 pointer SBCOUNT(ctx,n,argv)
00030 context *ctx;
00031 int n; /* unused argument */
00032 pointer *argv; /* unused argument */
00033 {  return(makeint(ctx->special_bind_count));}
00034 
00035 pointer GCTIME(ctx,n,argv)
00036 register context *ctx;
00037 int n;
00038 pointer argv[];
00039 { return(cons(ctx,makeint(gccount),
00040               cons(ctx,makeint(marktime),
00041                    cons(ctx,makeint(sweeptime),NIL))));}
00042 
00043 pointer ALLOC(ctx,n,argv)
00044 register context *ctx;
00045 int n;
00046 pointer argv[];
00047 { int ss,i=2;
00048   ckarg(1);
00049   ss=ckintval(argv[0]);
00050   while (buddysize[i]<ss) i++;
00051   if (i>=MAXBUDDY) error(E_ALLOCATION);
00052 #if defined(RGC) && !defined(__HEAP_EXPANDABLE)
00053   /* heap isn't expandable */
00054 #else
00055 #if defined(RGC)
00056   lock_collector;
00057   DPRINT1("ALLOC: newchunk");
00058 #endif
00059   i=newchunk(i);
00060 #if defined(RGC)
00061   unlock_collector;
00062 #endif
00063 #endif
00064   if (i==ERR) error(E_ALLOCATION);
00065   else return(makeint(buddysize[i]));}
00066 
00067 pointer NEWSTACK(ctx,n,argv)
00068 context *ctx;
00069 pointer argv[];
00070 { eusinteger_t newsize;
00071   if (n==0) return(makeint((ctx->stacklimit+100-ctx->stack)));
00072   else {
00073     newsize=ckintval(argv[0]);
00074     if (newsize>1024*1024*256) error(E_USER,(pointer)"too big stack"); /*max 256MW*/
00075     allocate_stack(ctx,newsize);
00076     euslongjmp(topjbuf,newsize);}
00077   }
00078 
00079 pointer DISPOSE_HOOK(ctx,n,argv)
00080 context *ctx;
00081 pointer argv[];
00082 { 
00083 #ifndef RGC
00084   pointer p;
00085   ckarg2(1,2);
00086   p=argv[0];
00087   if (!ispointer(p)) error(E_NOOBJECT);
00088   else {
00089     if (n==1) return((p->nodispose==0)?NIL:T);
00090     else {
00091       p->nodispose=((argv[1]==NIL)?0:1); 
00092       return(argv[1]); }
00093     }
00094 #endif
00095   }
00096 
00097 #if Solaris2
00098 extern _end();
00099 #else
00100 extern edata();
00101 #endif
00102 
00103 xmark(ctx,p)
00104 register context *ctx;
00105 register pointer p;
00106 { register int s;
00107   register bpointer bp;
00108 #if !alpha && system5
00109   if (p<(pointer)0x100000) return(NULL);
00110 #endif
00111 #if Solaris2
00112   if ((eusinteger_t)p<(eusinteger_t)_end) return(NULL);
00113 #elif sun3 || sun4 || news || (i386 && (!Cygwin && !Darwin)) || alpha || mips /* Cygwin does not have edata */
00114   if ((eusinteger_t)p<(eusinteger_t)edata) return(NULL);
00115 #endif
00116 #if sun4 || vax || i386 
00117   if ((&ctx->stack[0]<=p) && (p<= &ctx->stack[MAXSTACK])) return(NULL);
00118 #endif
00119   if (issymbol(p)) return((long int)NULL);
00120 #if x86_64
00121   bp=(bpointer)((eusinteger_t)p & ~3L);
00122 #else
00123   bp=(bpointer)((eusinteger_t)p & ~3);
00124 #endif
00125   if (marked(bp)) return(0);    /*already marked*/
00126   markon(bp);   /*mark it first to avoid endless marking*/
00127   if (bp->h.elmtype==ELM_FIXED) {       /*contents are all pointers*/
00128 #ifdef RGC
00129     s=buddysize[bp->h.bix&TAGMASK]-1;
00130 #else
00131     s=buddysize[bp->h.bix]-1;
00132 #endif
00133     while (s>0) {
00134       p=bp->b.c[--s];
00135       if (ispointer(p)) xmark(ctx,p);}}
00136   else if (bp->h.elmtype==ELM_POINTER) { /*varing pointers*/
00137     s=intval(bp->b.c[0]);
00138     while (s>0) {
00139       p=bp->b.c[s--];
00140       if (ispointer(p)) xmark(ctx,p);}
00141     }
00142   }
00143 
00144 int xcollect(ctx,p)
00145 register context *ctx;
00146 register pointer p;
00147 { register int s,r=0;
00148   register bpointer bp;
00149 #if !alpha && system5
00150  if (p<(pointer)0x100000) return(NULL);
00151 #endif
00152 #if sun
00153   if (p<(pointer)0x10000) return(NULL);
00154 #endif
00155 #if x86_64
00156   bp=(bpointer)((eusinteger_t)p & ~3L/*0xfffffffc*/);/* ???? */
00157 #else
00158   bp=(bpointer)((eusinteger_t)p & ~3/*0xfffffffc*/);/* ???? */
00159 #endif
00160   if (marked(bp)) {
00161     markoff(bp);
00162     reclaim(bp);
00163     if (bp->h.elmtype==ELM_FIXED) {     /*contents are all pointers*/
00164 #ifdef RGC
00165       s=buddysize[bp->h.bix&TAGMASK]-1;
00166 #else
00167       s=buddysize[bp->h.bix]-1;
00168 #endif
00169       r=s;
00170       while (s>0) {
00171         p=bp->b.c[--s];
00172         if (ispointer(p)) r+=xcollect(ctx,p);}}   /* ???? */
00173     else if (bp->h.elmtype==ELM_POINTER) { /*varing pointers*/
00174       s=intval(bp->b.c[0]);
00175       r=s+1;
00176       while (s>0) {
00177         p=bp->b.c[s--];
00178         if (ispointer(p)) r+=xcollect(ctx,p);}   /* ???? */
00179       }
00180     return(r);}
00181   else return(0); }
00182 
00183 #ifndef RGC
00184 pointer RECLAIM(ctx,n,argv)
00185 register context *ctx;
00186 int n;
00187 pointer argv[];
00188 { pointer p;
00189   bpointer bp;
00190   ckarg(1);
00191   p=argv[0];
00192   if (!ispointer(p)) return(0);
00193   bp=bpointerof(p);
00194 #if THREADED
00195   mutex_lock(&alloc_lock);
00196 #endif
00197   reclaim(bp);
00198 #if THREADED
00199   mutex_unlock(&alloc_lock);
00200 #endif
00201 #ifdef RGC
00202   return(makeint(buddysize[bp->h.bix&TAGMASK]-1));
00203 #else
00204   return(makeint(buddysize[bp->h.bix]-1));
00205 #endif
00206 }
00207 
00208 pointer RECLTREE(ctx,n,argv)
00209 register context *ctx;
00210 int n;
00211 pointer argv[];
00212 { pointer p;
00213   ckarg(1);
00214   p=argv[0];
00215   if (!ispointer(p)) return(0);
00216 #if THREADED
00217   mutex_lock(&mark_lock);
00218   mark_locking="RECLTREE";
00219 #endif
00220   xmark(ctx,p);
00221   n=xcollect(ctx,p);
00222 #if THREADED
00223   mutex_unlock(&mark_lock);
00224 #endif
00225   return(makeint(n));}
00226 
00227 #else /* RGC */
00228 pointer RECLAIM(ctx,n,argv)
00229 register context *ctx;
00230 int n;
00231 pointer argv[];
00232 {
00233 
00234 }
00235 
00236 pointer RECLTREE(ctx,n,argv)
00237 register context *ctx;
00238 int n;
00239 pointer argv[];
00240 {
00241 
00242 }
00243 #endif /* RGC */
00244 
00245 static int cell_count, object_size, cell_size, count_symbol;
00246 
00247 pointer objsize1(x)
00248 pointer x;
00249 { int etype,s,i;
00250   if (isnum(x) || x==UNBOUND || (!count_symbol && pissymbol(x))
00251       || p_marked(x)) return(0);
00252   p_mark_on(x);
00253   etype=elmtypeof(x);
00254   cell_count++;
00255   if (isvector(x)) s=vecsize(x);  else s=objsize(x);
00256   cell_size+=buddysize[bixof(x)];
00257   switch(etype) {
00258     case ELM_FIXED: object_size+= s;
00259                 for (i=0; i<s; i++) objsize1(x->c.obj.iv[i]);
00260                 break;
00261     case ELM_BIT: object_size+=1+(s+WORD_SIZE-1)/WORD_SIZE; break;
00262     case ELM_BYTE: case ELM_CHAR:
00263       object_size += 1+(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
00264     case ELM_POINTER: object_size+=1+s; 
00265                 for (i=0; i<s; i++) objsize1(x->c.vec.v[i]);
00266                 break;
00267     case ELM_INT: case ELM_FLOAT: object_size+=1+s; break;}
00268   }
00269 
00270 void objsize2(x)
00271 pointer x;
00272 { int etype,s,i;
00273   pointer y;
00274   if (isnum(x) || x==UNBOUND || (!count_symbol && pissymbol(x)) ||
00275       !p_marked(x)) return;
00276   p_mark_off(x);
00277   etype=elmtypeof(x);
00278   if (isvector(x)) s=vecsize(x); else s=objsize(x);
00279   switch(etype) {
00280     case ELM_FIXED:
00281                 for (i=0; i<s; i++) objsize2(x->c.obj.iv[i]);
00282                 break;
00283     case ELM_POINTER:
00284                 for (i=0; i<s; i++) objsize2(x->c.vec.v[i]);
00285                 break;}
00286   }
00287 
00288 pointer OBJSIZE(ctx,n,argv)
00289 register context *ctx;
00290 pointer argv[];
00291 { register pointer a=argv[0];
00292   ckarg2(1,2);
00293   if (n==2) count_symbol=(argv[1]!=NIL); else count_symbol=0;
00294   cell_count=object_size=cell_size=0;
00295 #if THREADED
00296   mutex_lock(&mark_lock);
00297   mark_locking="OBJSIZE";
00298 #endif
00299   objsize1(a);
00300   objsize2(a);
00301 #if THREADED
00302   mutex_unlock(&mark_lock);
00303 #endif
00304   return(cons(ctx,makeint(cell_count),
00305               cons(ctx,makeint(object_size),
00306                         cons(ctx,makeint(cell_size),NIL))));}
00307 
00308 pointer BKTRACE(ctx,n,argv)
00309 register context *ctx;
00310 int n;
00311 pointer argv[];
00312 { int i,j;
00313   pointer r=NIL;
00314   struct callframe *cfp=ctx->callfp;
00315   ckarg(1);
00316   i=j=ckintval(argv[0]);
00317   while (i-->0) {
00318     if (cfp==NULL) break;
00319     vpush(cfp->form); cfp=cfp->vlink;}
00320   while (--j>i) r=cons(ctx,vpop(),r);
00321   return(r);}
00322 
00323 pointer MEMORY_REPORT(ctx,n,argv)
00324 register context *ctx;
00325 int n;
00326 pointer *argv;
00327 {
00328   int fcount[MAXBUDDY],tcount[MAXBUDDY];
00329   eusfloat_t loss[MAXBUDDY];
00330   register int i,j;
00331   int s;
00332   bpointer bp,p,tail;
00333   struct chunk *cp;
00334   char cbuf[100];
00335   pointer outs;
00336 
00337   outs=(pointer)getoutstream(ctx,n+1,argv[0]);
00338   for (i=1; i<MAXBUDDY; i++) {
00339     s=0;
00340     bp=buddy[i].bp;
00341     while (0 < (eusinteger_t)bp) { s++; bp=bp->b.nextbcell;}
00342     fcount[i]=s; tcount[i]=0;}
00343   cp=chunklist;
00344   while (cp) {
00345     s=buddysize[cp->chunkbix];
00346     p= &cp->rootcell;
00347     tail=(bpointer)((eusinteger_t)p+(s<<WORDSHIFT));/* ???? */
00348     while (p<tail) {
00349 #ifdef RGC
00350       i=p->h.bix&TAGMASK;
00351 #else
00352       i=p->h.bix;
00353 #endif
00354       tcount[i]++;
00355       p=(bpointer)((eusinteger_t)p+(buddysize[i]<<WORDSHIFT));}/* ???? */
00356     cp=cp->nextchunk;}
00357 
00358   sprintf(cbuf,"buddy   size  free   total   total-size  wanted   wanted-size\n");
00359   writestr(outs,(byte *)cbuf,strlen(cbuf));
00360   
00361   for(i=1; i<MAXBUDDY; i++) {
00362     sprintf(cbuf,"%4d %7ld %5d  %6d  %8ld  %8ld %10ld\n",
00363             i,buddysize[i],fcount[i],tcount[i], tcount[i]*buddysize[i],
00364             alloccount[i],alloccount[i]*buddysize[i]);
00365     writestr(outs,(byte *)cbuf,strlen(cbuf)); }
00366 
00367   sprintf(cbuf, "\ncontext  big_alloc   small_alloc\n");
00368   writestr(outs,(byte *)cbuf,strlen(cbuf));
00369   for (i=1; i<MAXTHREAD; i++) {
00370     if (euscontexts[i]) {
00371       sprintf(cbuf,"%4d %12d %12d\n",
00372             i, euscontexts[i]->alloc_big_count, euscontexts[i]->alloc_small_count);
00373       writestr(outs,(byte *)cbuf,strlen(cbuf)); }
00374     }
00375   return(T);
00376   }
00377 
00378 pointer CLEAR_ALLOCCOUNT(ctx,n,argv)
00379 register context *ctx;
00380 int n; /* unused argument */
00381 pointer *argv; /* unused argument */
00382 { register int i;
00383   for (i=1; i<MAXBUDDY; i++) alloccount[i]=0; 
00384   for (i=1; i<MAXTHREAD; i++) {
00385     if (euscontexts[i]) {
00386       euscontexts[i]->alloc_big_count=euscontexts[i]->alloc_small_count;}}
00387   return(NIL);}
00388 
00389 pointer ROOM(ctx,n,argv)
00390 register context *ctx;
00391 int n;
00392 pointer argv[];
00393 { int counts[MAXCLASS],sizes[MAXCLASS];
00394   int holecount=0,holesize=0;
00395   register int i,s;
00396   char buf[256];
00397   struct chunk *chp;
00398   pointer klass,strm;
00399   bpointer b,tail;
00400 
00401   strm=(pointer)getoutstream(ctx,n+1,argv[0]);
00402   for(i=0; i<MAXCLASS; i++) counts[i]=sizes[i]=0;
00403 #if THREADED
00404   mutex_lock(&mark_lock);
00405   rw_wrlock(&gc_lock);
00406   mark_locking="ROOM";
00407 #endif
00408   markall();
00409   for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
00410     s=buddysize[chp->chunkbix];
00411     b= &chp->rootcell;
00412     tail=(bpointer)((eusinteger_t)b+(s<<WORDSHIFT));/* ???? */
00413     while (b<tail) {
00414       if (marked(b)) {
00415         i=b->h.cix;
00416         if (i<0 || i>=MAXCLASS)
00417           fprintf(stderr,"bad cid %d at %p, bix=%d\n",i,b,b->h.bix);
00418         else {
00419           counts[i]++;
00420 #ifdef RGC
00421           sizes[i]+=buddysize[b->h.bix&TAGMASK]; 
00422 #else
00423           sizes[i]+=buddysize[b->h.bix]; 
00424 #endif
00425         }}
00426       else {
00427         holecount++;
00428 #ifdef RGC
00429         holesize+=buddysize[b->h.bix&TAGMASK];
00430 #else
00431         holesize+=buddysize[b->h.bix];
00432 #endif
00433       }
00434       b=nextbuddy(b);} }
00435   sweepall();
00436 #if THREADED
00437   rw_unlock(&gc_lock);
00438   mutex_unlock(&mark_lock);
00439 #endif
00440   for (i=0; i<MAXCLASS; i++) {
00441     klass=classtab[i].def;
00442     if (klass && isclass(klass)) {
00443       sprintf(buf,"%32s%7d cells %7d words %6ldKB\n", 
00444              klass->c.cls.name->c.sym.pname->c.str.chars,
00445              counts[i],sizes[i],sizes[i]*sizeof(pointer)/1024);
00446       writestr(strm,(byte *)buf,strlen(buf)); } }
00447   sprintf(buf,"%32s%7d cells %7d words %6ldKB\n","holes",holecount,
00448           holesize,holesize*sizeof(pointer)/1024);
00449   writestr(strm,(byte *)buf,strlen(buf));
00450   return(NIL);}
00451 
00452 pointer FREE_COUNTS(ctx,n,argv)
00453 register context *ctx;
00454 int n; /* unused argument */
00455 pointer *argv; /* unused argument */
00456 { int i;
00457   char buf[256];
00458   pointer strm;
00459   extern pointer QTERMIO;
00460   strm=Spevalof(QTERMIO);
00461   strm=strm->c.iostream.out;
00462   for (i=0; i<MAXBUDDY; i++) {
00463     sprintf(buf, "%3d %10ld * %6d = %10ld\n",
00464          i, buddysize[i], buddy[i].count, buddysize[i]*buddy[i].count);
00465     writestr(strm,(byte *)buf,strlen(buf));
00466     }
00467   return(T);}
00468 
00469 pointer LIST_ALL_CHUNKS(ctx,n,argv)
00470 register context *ctx;
00471 int n; /* unused argument */
00472 pointer *argv; /* unused argument */
00473 { pointer r=NIL,p;
00474   struct chunk *cnk;
00475   ckarg(0);
00476   for (cnk=chunklist; cnk!=NULL; cnk=cnk->nextchunk) {
00477     vpush(r);
00478     p=cons(ctx,makeint((eusinteger_t)cnk),cons(ctx,makeint(buddysize[cnk->chunkbix]),NIL));
00479     r=cons(ctx,p,vpop());}
00480   return(r);}
00481 
00482 pointer INSTANCELIST(ctx,n,argv)
00483 register context *ctx;
00484 int n;
00485 pointer argv[];
00486 { pointer klass;
00487   register pointer r=NIL;
00488   register short cid;
00489   struct chunk *chp;
00490   pointer *spsave=ctx->vsp;
00491   int s,sub=0,objcid;
00492   bpointer b,tail;
00493 
00494   ckarg2(1,2);
00495   if (n==2) sub=(argv[1]!=NIL);
00496   klass=argv[0];
00497   if (!isclass(klass)) error(E_NOCLASS);
00498   cid=intval(klass->c.cls.cix);
00499 #if THREADED
00500   mutex_lock(&mark_lock);
00501   mark_locking="INSTANCELIST";
00502 #endif
00503   markall();
00504   for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
00505     s=buddysize[chp->chunkbix];
00506     b= &chp->rootcell;
00507     tail=(bpointer)((eusinteger_t)b+(s<<WORDSHIFT));/* ???? */
00508     while (b<tail) {
00509       if (marked(b)) {
00510         objcid=b->h.cix;
00511         if (objcid==cid || 
00512             (sub && (objcid>=cid && objcid<=classtab[cid].subcix))) {
00513           vpush(makepointer(b));
00514           if (ctx->vsp >= ctx->stacklimit) {
00515             sweepall();
00516             error(E_USER,(pointer)"not enough stack space");}} }
00517       b=nextbuddy(b);} }
00518   sweepall();
00519 #if THREADED
00520   mutex_unlock(&mark_lock);
00521 #endif
00522   while (ctx->vsp > spsave) r=cons(ctx,vpop(),r);
00523   return(r);}
00524 
00525 pointer LISTALLREFERENCES(ctx,n,argv)
00526 register context *ctx;
00527 int n;
00528 pointer argv[];
00529 { register pointer target=argv[0],p,r=NIL;
00530   struct chunk *chp;
00531   pointer *spsave=ctx->vsp;
00532   register int s,bsize,size;
00533   bpointer b,tail;
00534 
00535   ckarg(1);
00536 #if THREADED
00537   mutex_lock(&mark_lock);
00538   mark_locking="LISTALLREF";
00539 #endif
00540   markall();
00541   for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
00542     bsize=buddysize[chp->chunkbix];
00543     b= &chp->rootcell;
00544     tail=(bpointer)((eusinteger_t)b+(bsize<<WORDSHIFT));/* ???? */
00545     while (b<tail) {
00546       if (marked(b)) {
00547           p=makepointer(b);
00548           switch(elmtypeof(p)) {
00549             case ELM_POINTER:
00550                         size=vecsize(p);
00551                         for (s=0; s<size; s++)
00552                           if (p->c.vec.v[s]==target) goto found;
00553                         break;
00554             case ELM_FIXED:
00555                         size=objsize(p);
00556                         for (s=0; s<size; s++)
00557                           if (p->c.obj.iv[s]==target) goto found;
00558                         break;
00559             default: break;}
00560           goto next_buddy;
00561   found:
00562           vpush(p);
00563           if (ctx->vsp>=ctx->stacklimit) {
00564             sweepall();
00565             error(E_USER,(pointer)"not enough stack space");}     }
00566   next_buddy:
00567       b=nextbuddy(b);} }
00568   sweepall();
00569 #if THREADED
00570   mutex_unlock(&mark_lock);
00571 #endif
00572   while (ctx->vsp>spsave) r=cons(ctx,vpop(),r);  
00573   return(r);}
00574 
00575 
00576 /****************************************************************/
00577 /* direct access to memory */
00578 /****************************************************************/
00579 
00580 pointer ADDRESS(ctx,n,argv)
00581 register context *ctx;
00582 int n;
00583 pointer argv[];
00584 { eusinteger_t p;/* ???? */
00585   ckarg(1);
00586   p=(eusinteger_t)bpointerof(argv[0]);/* ???? */
00587   return(mkbigint(p));}
00588 
00589 pointer PEEK(ctx,n,argv)
00590 register context *ctx;
00591 int n;
00592 pointer argv[];
00593 { union un {
00594     byte b;
00595     short s;
00596     int i;
00597     long l;
00598     float f;
00599     double d;
00600     void *p;} *u;
00601   long x,etype;
00602   unsigned long y;
00603   pointer p,size;
00604   numunion nu;
00605 
00606   ckarg2(1,3);
00607   p=argv[0];
00608   if (isvector(p)) {
00609     etype=elmtypeof(p);
00610     if (etype==ELM_CHAR || etype==ELM_BYTE) {
00611       u= (union un *)&p->c.str.chars[ckintval(argv[1])];
00612       if (n==3) size=argv[2]; else size=K_LONG;}
00613     else if (etype==ELM_FOREIGN) {
00614       u= (union un *)&((byte *)(p->c.ivec.iv[0]))[ckintval(argv[1])];
00615       if (n==3) size=argv[2]; else size=K_LONG;}
00616     else error(E_NOSTRING);}
00617   else{
00618     x=bigintval(argv[0]);
00619     u=(union un *)x;
00620     if (n==2) size=argv[1]; else size=K_LONG;}
00621 #if (WORD_SIZE == 64)
00622   if (size==K_LONG) return mkbigint(u->l);
00623   if (size==K_INTEGER) return makeint(u->i);
00624 #else
00625   if (size==K_LONG || size==K_INTEGER) {
00626     y=u->l;
00627     return(mkbigint(y));}
00628 #endif
00629   if (size==K_BYTE || size==K_CHAR) return(makeint(u->b));
00630   if (size==K_SHORT) return(makeint(u->s));
00631   if (size==K_FLOAT) return(makeflt(u->f));
00632   if (size==K_DOUBLE) return(makeflt(u->d));
00633   if (size==K_POINTER) return(mkbigint((eusinteger_t)(u->p))); /* ???? */
00634   else error(E_USER,(pointer)"unknown access mode");}
00635 
00636 pointer POKE(ctx,n,argv)
00637 register context *ctx;
00638 int n;
00639 pointer argv[];
00640 { union un {
00641     byte b;
00642     short s;
00643     int i;
00644     long l;
00645     float f;
00646     double d;
00647     void *p;} *u;
00648   eusinteger_t x;
00649   int etype;
00650   pointer p,size,val;
00651   numunion nu;
00652   
00653   ckarg2(2,4);
00654   val=argv[0];
00655   p=argv[1];
00656   if (isvector(p)) {
00657     etype=elmtypeof(p);
00658     if (etype==ELM_CHAR || etype==ELM_BYTE) {
00659       u= (union un *)&p->c.str.chars[ckintval(argv[2])];
00660       if (n==4) size=argv[3]; else size=K_LONG;}
00661     else if (etype==ELM_FOREIGN) {
00662       u= (union un *)&((byte *)(p->c.ivec.iv[0]))[ckintval(argv[2])];
00663       if (n==4) size=argv[3]; else size=K_LONG;}
00664     else error(E_NOSTRING);}
00665   else{
00666     x=bigintval(argv[1]);
00667     u=(union un *)x;
00668     if (n==3) size=argv[2]; else size=K_LONG;}
00669 #if (WORD_SIZE == 64)
00670   if (size==K_LONG) u->l=bigintval(val);
00671   else if (size==K_INTEGER) u->i=ckintval(val);
00672 #else
00673   if (size==K_LONG || size==K_INTEGER)  u->l=bigintval(val);
00674 #endif
00675   else if (size==K_BYTE || size==K_CHAR) u->b=ckintval(val);
00676   else if (size==K_SHORT) u->s=ckintval(val);
00677   else if (size==K_FLOAT) u->f=ckfltval(val);
00678   else if (size==K_DOUBLE) u->d=ckfltval(val);
00679   else if (size==K_POINTER) u->p=(void*)ckintval(val);
00680   else error(E_USER,(pointer)"unknown access mode");
00681   return(val);}
00682 
00683 /****************************************************************/
00684 /* stack frame access
00685 /* 1988-Apr-26
00686 /****************************************************************/
00687 pointer LISTALLCATCHERS(ctx,n,argv)
00688 register context *ctx;
00689 int n;
00690 pointer *argv;
00691 { pointer catchers=NIL;
00692   struct catchframe *cfp=ctx->catchfp;
00693   int i=0;
00694   while (cfp) {
00695     vpush(cfp->label);
00696     i++;
00697     cfp=cfp->nextcatch;}
00698   return(stacknlist(ctx,i));}
00699 
00700 pointer LISTBINDINGS(ctx,n,argv)
00701 register context *ctx;
00702 int n;
00703 pointer *argv;
00704 { struct bindframe *bfp=ctx->bindfp, *nextbfp;
00705   int i=0;
00706   while (bfp) {
00707     vpush(cons(ctx,bfp->sym,bfp->val));
00708     i++;
00709     nextbfp=bfp->dynblink;
00710     if (nextbfp==NULL) nextbfp=bfp->lexblink;
00711     bfp=nextbfp;}
00712   return(stacknlist(ctx,i));}
00713 
00714 pointer LISTSPECIALBINDINGS(ctx,n,argv)
00715 register context *ctx;
00716 int n;
00717 pointer *argv;
00718 { struct specialbindframe *sbfp=ctx->sbindfp;
00719   int i=0;
00720   while (sbfp) {
00721     vpush(cons(ctx,sbfp->sym,sbfp->oldval));
00722     i++;
00723     sbfp=sbfp->sblink;}
00724   return(stacknlist(ctx,i));}
00725         
00726 pointer LISTALLCLASSES(ctx,n,argv)
00727 register context *ctx;
00728 int n;
00729 pointer argv[];
00730 { for (n=nextcix; n>0; ) ckpush(classtab[--n].def);
00731   return(stacknlist(ctx,nextcix));}
00732 
00733 pointer EXPORTALL(ctx,n,argv)
00734 register context *ctx;
00735 int n;
00736 pointer argv[];
00737 { ckarg(1);
00738   export_all = (argv[0]!=NIL);
00739   return(export_all?T:NIL);}
00740 
00741 pointer NEXT_SPECIAL_INDEX(ctx,n,argv)
00742 context *ctx;
00743 int n;
00744 pointer argv[];
00745 { int x;
00746   x=special_index();    /*generate a new special value index*/
00747   return(makeint(x));}
00748 
00749 pointer THREAD_SPECIALS(ctx,n,argv)
00750 context *ctx;
00751 int n;
00752 pointer argv[];
00753 { int x;
00754   context *con;
00755   pointer p;
00756 
00757   if (n==0) con=ctx;
00758   else {
00759     x=ckintval(argv[0]);
00760     if (x<0 || x>MAXTHREAD) error(E_USER,(pointer)"no such thread");
00761     if (x==0) con=ctx;
00762     else con=euscontexts[x];}
00763   p=con->specials;  
00764   if (p==NULL) return(NIL);
00765   if (n>1) {
00766     x=ckintval(argv[1]);
00767     return(p->c.vec.v[x]); }
00768   else return(p);}
00769 
00770 
00771 void sysfunc(ctx,mod)
00772 register context *ctx;
00773 pointer mod;
00774 { pointer pkgname,pkgnick,p=Spevalof(PACKAGE);
00775 
00776   pointer_update(Spevalof(PACKAGE),syspkg);
00777 
00778   defun(ctx,"SBCOUNT",mod,SBCOUNT);
00779   defun(ctx,"GC",mod,GEESEE);
00780   defun(ctx,"GCTIME",mod,GCTIME);
00781   defun(ctx,"ALLOC",mod,ALLOC);
00782   defun(ctx,"NEWSTACK",mod,NEWSTACK);
00783   defun(ctx,"RECLAIM",mod,RECLAIM);
00784   defun(ctx,"RECLAIM-TREE",mod,RECLTREE);
00785   defun(ctx,"OBJECT-SIZE",mod,OBJSIZE);
00786   defun(ctx,"BKTRACE",mod,BKTRACE);
00787   defun(ctx,"MEMORY-REPORT",mod,MEMORY_REPORT);
00788   defun(ctx,"CLEAR-MEMORY-REPORT",mod,CLEAR_ALLOCCOUNT);
00789   defun(ctx,"ROOM",mod,ROOM);
00790   defun(ctx,"FREE-COUNT",mod,FREE_COUNTS);
00791   defun(ctx,"LIST-ALL-CHUNKS",mod,LIST_ALL_CHUNKS);
00792   defun(ctx,"LIST-ALL-INSTANCES",mod,INSTANCELIST);
00793   defun(ctx,"ADDRESS",mod,ADDRESS);
00794   defun(ctx,"PEEK",mod,PEEK);
00795   defun(ctx,"POKE",mod,POKE);
00796 /*  defun(ctx,"MALLOC_DEBUG",mod,MALLOC_DEBUG);
00797 /*  defun(ctx,"MALLOC_VERIFY",mod,MALLOC_VERIFY); */
00798   defun(ctx,"LIST-ALL-REFERENCES",mod,LISTALLREFERENCES);
00799   defun(ctx,"LIST-ALL-CATCHERS",mod,LISTALLCATCHERS);
00800   defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS);
00801   defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS);
00802   defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES);
00803   defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL);
00804   defun(ctx,"NEXT-SPECIAL-INDEX", mod, NEXT_SPECIAL_INDEX);
00805   defun(ctx,"THREAD-SPECIALS", mod, THREAD_SPECIALS);
00806   defun(ctx,"DISPOSE-HOOK", mod, DISPOSE_HOOK);
00807 
00808 /* restore package*/  pointer_update(Spevalof(PACKAGE),p);
00809 }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:20