00001
00002
00003
00004
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;
00032 pointer *argv;
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
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");
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
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 (WORD_SIZE == 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);
00126 markon(bp);
00127 if (bp->h.elmtype==ELM_FIXED) {
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) {
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 (WORD_SIZE == 64)
00156 bp=(bpointer)((eusinteger_t)p & ~3L);
00157 #else
00158 bp=(bpointer)((eusinteger_t)p & ~3);
00159 #endif
00160 if (marked(bp)) {
00161 markoff(bp);
00162 reclaim(bp);
00163 if (bp->h.elmtype==ELM_FIXED) {
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) {
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
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
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;
00381 pointer *argv;
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;
00455 pointer *argv;
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;
00472 pointer *argv;
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
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
00685
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();
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
00797
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 pointer_update(Spevalof(PACKAGE),p);
00809 }