sysfunc.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* system management functions
3 /* 1986-Aug
4 /* T.Matsui, ETL
5 /****************************************************************/
6 static char *rcsid="@(#)$Id$";
7 
8 #include "eus.h"
9 
10 #define p_marked(p) (bpointerof(p)->h.pmark)
11 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
12 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
13 
14 extern long freeheap,totalheap;
15 extern struct chunk *chunklist;
16 extern long gccount,marktime,sweeptime;
17 extern pointer stacknlist(),stacklist();
18 extern jmp_buf topjbuf;
19 extern long alloccount[MAXBUDDY];
20 
21 pointer GEESEE(ctx,n,argv)
22 register context *ctx;
23 int n;
24 pointer argv[];
25 { gc();
26  return(cons(ctx,makeint(freeheap),
27  cons(ctx,makeint(totalheap),NIL)));}
28 
29 pointer SBCOUNT(ctx,n,argv)
30 context *ctx;
31 int n; /* unused argument */
32 pointer *argv; /* unused argument */
33 { return(makeint(ctx->special_bind_count));}
34 
35 pointer GCTIME(ctx,n,argv)
36 register context *ctx;
37 int n;
38 pointer argv[];
39 { return(cons(ctx,makeint(gccount),
40  cons(ctx,makeint(marktime),
41  cons(ctx,makeint(sweeptime),NIL))));}
42 
43 pointer ALLOC(ctx,n,argv)
44 register context *ctx;
45 int n;
46 pointer argv[];
47 { int ss,i=2;
48  ckarg(1);
49  ss=ckintval(argv[0]);
50  while (buddysize[i]<ss) i++;
51  if (i>=MAXBUDDY) error(E_ALLOCATION);
52 #if defined(RGC) && !defined(__HEAP_EXPANDABLE)
53  /* heap isn't expandable */
54 #else
55 #if defined(RGC)
57  DPRINT1("ALLOC: newchunk");
58 #endif
59  i=newchunk(i);
60 #if defined(RGC)
62 #endif
63 #endif
64  if (i==ERR) error(E_ALLOCATION);
65  else return(makeint(buddysize[i]));}
66 
67 pointer NEWSTACK(ctx,n,argv)
68 context *ctx;
69 int n;
70 pointer argv[];
71 { eusinteger_t newsize;
72  if (n==0) return(makeint((ctx->stacklimit+100-ctx->stack)));
73  else {
74  newsize=ckintval(argv[0]);
75  if (newsize>1024*1024*256) error(E_USER,(pointer)"too big stack"); /*max 256MW*/
76  allocate_stack(ctx,newsize);
77  euslongjmp(topjbuf,newsize);}
78  }
79 
81 context *ctx;
82 int n;
83 pointer argv[];
84 {
85 #ifndef RGC
86  pointer p;
87  ckarg2(1,2);
88  p=argv[0];
89  if (!ispointer(p)) error(E_NOOBJECT);
90  else {
91  if (n==1) return((p->nodispose==0)?NIL:T);
92  else {
93  p->nodispose=((argv[1]==NIL)?0:1);
94  return(argv[1]); }
95  }
96 #endif
97  }
98 
99 #if Solaris2
100 extern _end();
101 #else
102 extern eusinteger_t edata();
103 #endif
104 
105 int xmark(ctx,p)
106 register context *ctx;
107 register pointer p;
108 { register int s;
109  register bpointer bp;
110 #if !alpha && system5
111  if (p<(pointer)0x100000) return(NULL);
112 #endif
113 #if Solaris2
114  if ((eusinteger_t)p<(eusinteger_t)_end) return(NULL);
115 #elif sun3 || sun4 || news || (i386 && (!Cygwin && !Darwin)) || alpha || mips /* Cygwin does not have edata */
116  if ((eusinteger_t)p<(eusinteger_t)edata) return(NULL);
117 #endif
118 #if sun4 || vax || i386
119  if ((&ctx->stack[0]<=p) && (p<= &ctx->stack[MAXSTACK])) return(NULL);
120 #endif
121  if (issymbol(p)) return((long int)NULL);
122 #if (WORD_SIZE == 64)
123  bp=(bpointer)((eusinteger_t)p & ~3L);
124 #else
125  bp=(bpointer)((eusinteger_t)p & ~3);
126 #endif
127  if (marked(bp)) return(0); /*already marked*/
128  markon(bp); /*mark it first to avoid endless marking*/
129  if (bp->h.elmtype==ELM_FIXED) { /*contents are all pointers*/
130 #ifdef RGC
131  s=buddysize[bp->h.bix&TAGMASK]-1;
132 #else
133  s=buddysize[bp->h.bix]-1;
134 #endif
135  while (s>0) {
136  p=bp->b.c[--s];
137  if (ispointer(p)) xmark(ctx,p);}}
138  else if (bp->h.elmtype==ELM_POINTER) { /*varing pointers*/
139  s=intval(bp->b.c[0]);
140  while (s>0) {
141  p=bp->b.c[s--];
142  if (ispointer(p)) xmark(ctx,p);}
143  }
144  }
145 
146 int xcollect(ctx,p)
147 register context *ctx;
148 register pointer p;
149 { register int s,r=0;
150  register bpointer bp;
151 #if !alpha && system5
152  if (p<(pointer)0x100000) return(NULL);
153 #endif
154 #if sun
155  if (p<(pointer)0x10000) return(NULL);
156 #endif
157 #if (WORD_SIZE == 64)
158  bp=(bpointer)((eusinteger_t)p & ~3L/*0xfffffffc*/);/* ???? */
159 #else
160  bp=(bpointer)((eusinteger_t)p & ~3/*0xfffffffc*/);/* ???? */
161 #endif
162  if (marked(bp)) {
163  markoff(bp);
164  reclaim(bp);
165  if (bp->h.elmtype==ELM_FIXED) { /*contents are all pointers*/
166 #ifdef RGC
167  s=buddysize[bp->h.bix&TAGMASK]-1;
168 #else
169  s=buddysize[bp->h.bix]-1;
170 #endif
171  r=s;
172  while (s>0) {
173  p=bp->b.c[--s];
174  if (ispointer(p)) r+=xcollect(ctx,p);}} /* ???? */
175  else if (bp->h.elmtype==ELM_POINTER) { /*varing pointers*/
176  s=intval(bp->b.c[0]);
177  r=s+1;
178  while (s>0) {
179  p=bp->b.c[s--];
180  if (ispointer(p)) r+=xcollect(ctx,p);} /* ???? */
181  }
182  return(r);}
183  else return(0); }
184 
185 #ifndef RGC
186 pointer RECLAIM(ctx,n,argv)
187 register context *ctx;
188 int n;
189 pointer argv[];
190 { pointer p;
191  bpointer bp;
192  ckarg(1);
193  p=argv[0];
194  if (!ispointer(p)) return(0);
195  bp=bpointerof(p);
196 #if THREADED
197  mutex_lock(&alloc_lock);
198 #endif
199  reclaim(bp);
200 #if THREADED
201  mutex_unlock(&alloc_lock);
202 #endif
203 #ifdef RGC
204  return(makeint(buddysize[bp->h.bix&TAGMASK]-1));
205 #else
206  return(makeint(buddysize[bp->h.bix]-1));
207 #endif
208 }
209 
210 pointer RECLTREE(ctx,n,argv)
211 register context *ctx;
212 int n;
213 pointer argv[];
214 { pointer p;
215  ckarg(1);
216  p=argv[0];
217  if (!ispointer(p)) return(0);
218 #if THREADED
219  mutex_lock(&mark_lock);
220  mark_locking="RECLTREE";
221 #endif
222  xmark(ctx,p);
223  n=xcollect(ctx,p);
224 #if THREADED
225  mutex_unlock(&mark_lock);
226 #endif
227  return(makeint(n));}
228 
229 #else /* RGC */
230 pointer RECLAIM(ctx,n,argv)
231 register context *ctx;
232 int n;
233 pointer argv[];
234 {
235 
236 }
237 
238 pointer RECLTREE(ctx,n,argv)
239 register context *ctx;
240 int n;
241 pointer argv[];
242 {
243 
244 }
245 #endif /* RGC */
246 
248 
250 pointer x;
251 { int etype,s,i;
252  if (isnum(x) || x==UNBOUND || (!count_symbol && pissymbol(x))
253  || p_marked(x)) return(0);
254  p_mark_on(x);
255  etype=elmtypeof(x);
256  cell_count++;
257  if (isvector(x)) s=vecsize(x); else s=objsize(x);
258  cell_size+=buddysize[bixof(x)];
259  switch(etype) {
260  case ELM_FIXED: object_size+= s;
261  for (i=0; i<s; i++) objsize1(x->c.obj.iv[i]);
262  break;
263  case ELM_BIT: object_size+=1+(s+WORD_SIZE-1)/WORD_SIZE; break;
264  case ELM_BYTE: case ELM_CHAR:
265  object_size += 1+(s+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
266  case ELM_POINTER: object_size+=1+s;
267  for (i=0; i<s; i++) objsize1(x->c.vec.v[i]);
268  break;
269  case ELM_INT: case ELM_FLOAT: object_size+=1+s; break;}
270  }
271 
272 void objsize2(x)
273 pointer x;
274 { int etype,s,i;
275  pointer y;
276  if (isnum(x) || x==UNBOUND || (!count_symbol && pissymbol(x)) ||
277  !p_marked(x)) return;
278  p_mark_off(x);
279  etype=elmtypeof(x);
280  if (isvector(x)) s=vecsize(x); else s=objsize(x);
281  switch(etype) {
282  case ELM_FIXED:
283  for (i=0; i<s; i++) objsize2(x->c.obj.iv[i]);
284  break;
285  case ELM_POINTER:
286  for (i=0; i<s; i++) objsize2(x->c.vec.v[i]);
287  break;}
288  }
289 
290 pointer OBJSIZE(ctx,n,argv)
291 register context *ctx;
292 int n;
293 pointer argv[];
294 { register pointer a=argv[0];
295  ckarg2(1,2);
296  if (n==2) count_symbol=(argv[1]!=NIL); else count_symbol=0;
298 #if THREADED
299  mutex_lock(&mark_lock);
300  mark_locking="OBJSIZE";
301 #endif
302  objsize1(a);
303  objsize2(a);
304 #if THREADED
305  mutex_unlock(&mark_lock);
306 #endif
307  return(cons(ctx,makeint(cell_count),
308  cons(ctx,makeint(object_size),
309  cons(ctx,makeint(cell_size),NIL))));}
310 
311 pointer BKTRACE(ctx,n,argv)
312 register context *ctx;
313 int n;
314 pointer argv[];
315 { int i,j;
316  pointer r=NIL;
317  struct callframe *cfp=ctx->callfp;
318  ckarg(1);
319  i=j=ckintval(argv[0]);
320  while (i-->0) {
321  if (cfp==NULL) break;
322  vpush(cfp->form); cfp=cfp->vlink;}
323  while (--j>i) r=cons(ctx,vpop(),r);
324  return(r);}
325 
327 register context *ctx;
328 int n;
329 pointer *argv;
330 {
331  int fcount[MAXBUDDY],tcount[MAXBUDDY];
332  eusfloat_t loss[MAXBUDDY];
333  register int i,j;
334  int s;
335  bpointer bp,p,tail;
336  struct chunk *cp;
337  char cbuf[100];
338  pointer outs;
339 
340  outs=(pointer)getoutstream(ctx,n+1,argv[0]);
341  for (i=1; i<MAXBUDDY; i++) {
342  s=0;
343  bp=buddy[i].bp;
344  while (0 < (eusinteger_t)bp) { s++; bp=bp->b.nextbcell;}
345  fcount[i]=s; tcount[i]=0;}
346  cp=chunklist;
347  while (cp) {
348  s=buddysize[cp->chunkbix];
349  p= &cp->rootcell;
350  tail=(bpointer)((eusinteger_t)p+(s<<WORDSHIFT));/* ???? */
351  while (p<tail) {
352 #ifdef RGC
353  i=p->h.bix&TAGMASK;
354 #else
355  i=p->h.bix;
356 #endif
357  tcount[i]++;
358  p=(bpointer)((eusinteger_t)p+(buddysize[i]<<WORDSHIFT));}/* ???? */
359  cp=cp->nextchunk;}
360 
361  sprintf(cbuf,"buddy size free total total-size wanted wanted-size\n");
362  writestr(outs,(byte *)cbuf,strlen(cbuf));
363 
364  for(i=1; i<MAXBUDDY; i++) {
365  sprintf(cbuf,"%4d %7ld %5d %6d %8ld %8ld %10ld\n",
366  i,buddysize[i],fcount[i],tcount[i], tcount[i]*buddysize[i],
367  alloccount[i],alloccount[i]*buddysize[i]);
368  writestr(outs,(byte *)cbuf,strlen(cbuf)); }
369 
370  sprintf(cbuf, "\ncontext big_alloc small_alloc\n");
371  writestr(outs,(byte *)cbuf,strlen(cbuf));
372  for (i=1; i<MAXTHREAD; i++) {
373  if (euscontexts[i]) {
374  sprintf(cbuf,"%4d %12d %12d\n",
375  i, euscontexts[i]->alloc_big_count, euscontexts[i]->alloc_small_count);
376  writestr(outs,(byte *)cbuf,strlen(cbuf)); }
377  }
378  return(T);
379  }
380 
382 register context *ctx;
383 int n; /* unused argument */
384 pointer *argv; /* unused argument */
385 { register int i;
386  for (i=1; i<MAXBUDDY; i++) alloccount[i]=0;
387  for (i=1; i<MAXTHREAD; i++) {
388  if (euscontexts[i]) {
390  return(NIL);}
391 
392 pointer ROOM(ctx,n,argv)
393 register context *ctx;
394 int n;
395 pointer argv[];
396 { int counts[MAXCLASS],sizes[MAXCLASS];
397  int holecount=0,holesize=0;
398  register int i,s;
399  char buf[256];
400  struct chunk *chp;
401  pointer klass,strm;
402  bpointer b,tail;
403 
404  strm=(pointer)getoutstream(ctx,n+1,argv[0]);
405  for(i=0; i<MAXCLASS; i++) counts[i]=sizes[i]=0;
406 #if THREADED
407  mutex_lock(&mark_lock);
408  rw_wrlock(&gc_lock);
409  mark_locking="ROOM";
410 #endif
411  markall();
412  for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
413  s=buddysize[chp->chunkbix];
414  b= &chp->rootcell;
415  tail=(bpointer)((eusinteger_t)b+(s<<WORDSHIFT));/* ???? */
416  while (b<tail) {
417  if (marked(b)) {
418  i=b->h.cix;
419  if (i<0 || i>=MAXCLASS)
420  fprintf(stderr,"bad cid %d at %p, bix=%d\n",i,b,b->h.bix);
421  else {
422  counts[i]++;
423 #ifdef RGC
424  sizes[i]+=buddysize[b->h.bix&TAGMASK];
425 #else
426  sizes[i]+=buddysize[b->h.bix];
427 #endif
428  }}
429  else {
430  holecount++;
431 #ifdef RGC
432  holesize+=buddysize[b->h.bix&TAGMASK];
433 #else
434  holesize+=buddysize[b->h.bix];
435 #endif
436  }
437  b=nextbuddy(b);} }
438  sweepall();
439 #if THREADED
440  rw_unlock(&gc_lock);
441  mutex_unlock(&mark_lock);
442 #endif
443  for (i=0; i<MAXCLASS; i++) {
444  klass=classtab[i].def;
445  if (klass && isclass(klass)) {
446  sprintf(buf,"%32s%7d cells %7d words %6ldKB\n",
447  klass->c.cls.name->c.sym.pname->c.str.chars,
448  counts[i],sizes[i],sizes[i]*sizeof(pointer)/1024);
449  writestr(strm,(byte *)buf,strlen(buf)); } }
450  sprintf(buf,"%32s%7d cells %7d words %6ldKB\n","holes",holecount,
451  holesize,holesize*sizeof(pointer)/1024);
452  writestr(strm,(byte *)buf,strlen(buf));
453  return(NIL);}
454 
456 register context *ctx;
457 int n; /* unused argument */
458 pointer *argv; /* unused argument */
459 { int i;
460  char buf[256];
461  pointer strm;
462  extern pointer QTERMIO;
463  strm=Spevalof(QTERMIO);
464  strm=strm->c.iostream.out;
465  for (i=0; i<MAXBUDDY; i++) {
466  sprintf(buf, "%3d %10ld * %6d = %10ld\n",
467  i, buddysize[i], buddy[i].count, buddysize[i]*buddy[i].count);
468  writestr(strm,(byte *)buf,strlen(buf));
469  }
470  return(T);}
471 
473 register context *ctx;
474 int n; /* unused argument */
475 pointer *argv; /* unused argument */
476 { pointer r=NIL,p;
477  struct chunk *cnk;
478  ckarg(0);
479  for (cnk=chunklist; cnk!=NULL; cnk=cnk->nextchunk) {
480  vpush(r);
481  p=cons(ctx,makeint((eusinteger_t)cnk),cons(ctx,makeint(buddysize[cnk->chunkbix]),NIL));
482  r=cons(ctx,p,vpop());}
483  return(r);}
484 
486 register context *ctx;
487 int n;
488 pointer argv[];
489 { pointer klass;
490  register pointer r=NIL;
491  register short cid;
492  struct chunk *chp;
493  pointer *spsave=ctx->vsp;
494  int s,sub=0,objcid;
495  bpointer b,tail;
496 
497  ckarg2(1,2);
498  if (n==2) sub=(argv[1]!=NIL);
499  klass=argv[0];
500  if (!isclass(klass)) error(E_NOCLASS);
501  cid=intval(klass->c.cls.cix);
502 #if THREADED
503  mutex_lock(&mark_lock);
504  mark_locking="INSTANCELIST";
505 #endif
506  markall();
507  for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
508  s=buddysize[chp->chunkbix];
509  b= &chp->rootcell;
510  tail=(bpointer)((eusinteger_t)b+(s<<WORDSHIFT));/* ???? */
511  while (b<tail) {
512  if (marked(b)) {
513  objcid=b->h.cix;
514  if (objcid==cid ||
515  (sub && (objcid>=cid && objcid<=classtab[cid].subcix))) {
516  vpush(makepointer(b));
517  if (ctx->vsp >= ctx->stacklimit) {
518  sweepall();
519  error(E_USER,(pointer)"not enough stack space");}} }
520  b=nextbuddy(b);} }
521  sweepall();
522 #if THREADED
523  mutex_unlock(&mark_lock);
524 #endif
525  while (ctx->vsp > spsave) r=cons(ctx,vpop(),r);
526  return(r);}
527 
529 register context *ctx;
530 int n;
531 pointer argv[];
532 { register pointer target=argv[0],p,r=NIL;
533  struct chunk *chp;
534  pointer *spsave=ctx->vsp;
535  register int s,bsize,size;
536  bpointer b,tail;
537 
538  ckarg(1);
539 #if THREADED
540  mutex_lock(&mark_lock);
541  mark_locking="LISTALLREF";
542 #endif
543  markall();
544  for (chp=chunklist; chp!=0; chp=chp->nextchunk) {
545  bsize=buddysize[chp->chunkbix];
546  b= &chp->rootcell;
547  tail=(bpointer)((eusinteger_t)b+(bsize<<WORDSHIFT));/* ???? */
548  while (b<tail) {
549  if (marked(b)) {
550  p=makepointer(b);
551  switch(elmtypeof(p)) {
552  case ELM_POINTER:
553  size=vecsize(p);
554  for (s=0; s<size; s++)
555  if (p->c.vec.v[s]==target) goto found;
556  break;
557  case ELM_FIXED:
558  size=objsize(p);
559  for (s=0; s<size; s++)
560  if (p->c.obj.iv[s]==target) goto found;
561  break;
562  default: break;}
563  goto next_buddy;
564  found:
565  vpush(p);
566  if (ctx->vsp>=ctx->stacklimit) {
567  sweepall();
568  error(E_USER,(pointer)"not enough stack space");} }
569  next_buddy:
570  b=nextbuddy(b);} }
571  sweepall();
572 #if THREADED
573  mutex_unlock(&mark_lock);
574 #endif
575  while (ctx->vsp>spsave) r=cons(ctx,vpop(),r);
576  return(r);}
577 
578 
579 /****************************************************************/
580 /* direct access to memory */
581 /****************************************************************/
582 
583 pointer ADDRESS(ctx,n,argv)
584 register context *ctx;
585 int n;
586 pointer argv[];
587 { eusinteger_t p;/* ???? */
588  ckarg(1);
589  p=(eusinteger_t)bpointerof(argv[0]);/* ???? */
590  return(mkbigint(p));}
591 
592 pointer PEEK(ctx,n,argv)
593 register context *ctx;
594 int n;
595 pointer argv[];
596 { union un {
597  byte b;
598  short s;
599  int i;
600  long l;
601  float f;
602  double d;
603  void *p;} *u;
604  long x,etype;
605  unsigned long y;
606  pointer p,size;
607  numunion nu;
608 
609  ckarg2(1,3);
610  p=argv[0];
611  if (isvector(p)) {
612  etype=elmtypeof(p);
613  if (etype==ELM_CHAR || etype==ELM_BYTE) {
614  u= (union un *)&p->c.str.chars[ckintval(argv[1])];
615  if (n==3) size=argv[2]; else size=K_LONG;}
616  else if (etype==ELM_FOREIGN) {
617  u= (union un *)&((byte *)(p->c.ivec.iv[0]))[ckintval(argv[1])];
618  if (n==3) size=argv[2]; else size=K_LONG;}
619  else error(E_NOSTRING);}
620  else{
621  x=bigintval(argv[0]);
622  u=(union un *)x;
623  if (n==2) size=argv[1]; else size=K_LONG;}
624 #if (WORD_SIZE == 64)
625  if (size==K_LONG) return mkbigint(u->l);
626  if (size==K_INTEGER) return makeint(u->i);
627 #else
628  if (size==K_LONG || size==K_INTEGER) {
629  y=u->l;
630  return(mkbigint(y));}
631 #endif
632  if (size==K_BYTE || size==K_CHAR) return(makeint(u->b));
633  if (size==K_SHORT) return(makeint(u->s));
634  if (size==K_FLOAT) return(makeflt(u->f));
635  if (size==K_DOUBLE) return(makeflt(u->d));
636  if (size==K_POINTER) return(mkbigint((eusinteger_t)(u->p))); /* ???? */
637  else error(E_USER,(pointer)"unknown access mode");}
638 
639 pointer POKE(ctx,n,argv)
640 register context *ctx;
641 int n;
642 pointer argv[];
643 { union un {
644  byte b;
645  short s;
646  int i;
647  long l;
648  float f;
649  double d;
650  void *p;} *u;
651  eusinteger_t x;
652  int etype;
653  pointer p,size,val;
654  numunion nu;
655 
656  ckarg2(2,4);
657  val=argv[0];
658  p=argv[1];
659  if (isvector(p)) {
660  etype=elmtypeof(p);
661  if (etype==ELM_CHAR || etype==ELM_BYTE) {
662  u= (union un *)&p->c.str.chars[ckintval(argv[2])];
663  if (n==4) size=argv[3]; else size=K_LONG;}
664  else if (etype==ELM_FOREIGN) {
665  u= (union un *)&((byte *)(p->c.ivec.iv[0]))[ckintval(argv[2])];
666  if (n==4) size=argv[3]; else size=K_LONG;}
667  else error(E_NOSTRING);}
668  else{
669  x=bigintval(argv[1]);
670  u=(union un *)x;
671  if (n==3) size=argv[2]; else size=K_LONG;}
672 #if (WORD_SIZE == 64)
673  if (size==K_LONG) u->l=bigintval(val);
674  else if (size==K_INTEGER) u->i=ckintval(val);
675 #else
676  if (size==K_LONG || size==K_INTEGER) u->l=bigintval(val);
677 #endif
678  else if (size==K_BYTE || size==K_CHAR) u->b=ckintval(val);
679  else if (size==K_SHORT) u->s=ckintval(val);
680  else if (size==K_FLOAT) u->f=ckfltval(val);
681  else if (size==K_DOUBLE) u->d=ckfltval(val);
682  else if (size==K_POINTER) u->p=(void*)ckintval(val);
683  else error(E_USER,(pointer)"unknown access mode");
684  return(val);}
685 
686 /****************************************************************/
687 /* stack frame access
688 /* 1988-Apr-26
689 /****************************************************************/
691 register context *ctx;
692 int n;
693 pointer *argv;
694 { pointer catchers=NIL;
695  struct catchframe *cfp=ctx->catchfp;
696  int i=0;
697  while (cfp) {
698  vpush(cfp->label);
699  i++;
700  cfp=cfp->nextcatch;}
701  return(stacknlist(ctx,i));}
702 
704 register context *ctx;
705 int n;
706 pointer *argv;
707 { struct bindframe *bfp=ctx->bindfp, *nextbfp;
708  int i=0;
709  while (bfp) {
710  vpush(cons(ctx,bfp->sym,bfp->val));
711  i++;
712  nextbfp=bfp->dynblink;
713  if (nextbfp==NULL) nextbfp=bfp->lexblink;
714  bfp=nextbfp;}
715  return(stacknlist(ctx,i));}
716 
718 register context *ctx;
719 int n;
720 pointer *argv;
721 { struct specialbindframe *sbfp=ctx->sbindfp;
722  int i=0;
723  while (sbfp) {
724  vpush(cons(ctx,sbfp->sym,sbfp->oldval));
725  i++;
726  sbfp=sbfp->sblink;}
727  return(stacknlist(ctx,i));}
728 
730 register context *ctx;
731 int n;
732 pointer argv[];
733 { for (n=nextcix; n>0; ) ckpush(classtab[--n].def);
734  return(stacknlist(ctx,nextcix));}
735 
736 pointer EXPORTALL(ctx,n,argv)
737 register context *ctx;
738 int n;
739 pointer argv[];
740 { ckarg(1);
741  export_all = (argv[0]!=NIL);
742  return(export_all?T:NIL);}
743 
745 context *ctx;
746 int n;
747 pointer argv[];
748 { int x;
749  x=special_index(); /*generate a new special value index*/
750  return(makeint(x));}
751 
753 context *ctx;
754 int n;
755 pointer argv[];
756 { int x;
757  context *con;
758  pointer p;
759 
760  if (n==0) con=ctx;
761  else {
762  x=ckintval(argv[0]);
763  if (x<0 || x>MAXTHREAD) error(E_USER,(pointer)"no such thread");
764  if (x==0) con=ctx;
765  else con=euscontexts[x];}
766  p=con->specials;
767  if (p==NULL) return(NIL);
768  if (n>1) {
769  x=ckintval(argv[1]);
770  return(p->c.vec.v[x]); }
771  else return(p);}
772 
773 
774 void sysfunc(ctx,mod)
775 register context *ctx;
776 pointer mod;
777 { pointer pkgname,pkgnick,p=Spevalof(PACKAGE);
778 
779  pointer_update(Spevalof(PACKAGE),syspkg);
780 
781  defun(ctx,"SBCOUNT",mod,SBCOUNT,NULL);
782  defun(ctx,"GC",mod,GEESEE,NULL);
783  defun(ctx,"GCTIME",mod,GCTIME,NULL);
784  defun(ctx,"ALLOC",mod,ALLOC,NULL);
785  defun(ctx,"NEWSTACK",mod,NEWSTACK,NULL);
786  defun(ctx,"RECLAIM",mod,RECLAIM,NULL);
787  defun(ctx,"RECLAIM-TREE",mod,RECLTREE,NULL);
788  defun(ctx,"OBJECT-SIZE",mod,OBJSIZE,NULL);
789  defun(ctx,"BKTRACE",mod,BKTRACE,NULL);
790  defun(ctx,"MEMORY-REPORT",mod,MEMORY_REPORT,NULL);
791  defun(ctx,"CLEAR-MEMORY-REPORT",mod,CLEAR_ALLOCCOUNT,NULL);
792  defun(ctx,"ROOM",mod,ROOM,NULL);
793  defun(ctx,"FREE-COUNT",mod,FREE_COUNTS,NULL);
794  defun(ctx,"LIST-ALL-CHUNKS",mod,LIST_ALL_CHUNKS,NULL);
795  defun(ctx,"LIST-ALL-INSTANCES",mod,INSTANCELIST,NULL);
796  defun(ctx,"ADDRESS",mod,ADDRESS,NULL);
797  defun(ctx,"PEEK",mod,PEEK,NULL);
798  defun(ctx,"POKE",mod,POKE,NULL);
799 /* defun(ctx,"MALLOC_DEBUG",mod,MALLOC_DEBUG,NULL);
800 /* defun(ctx,"MALLOC_VERIFY",mod,MALLOC_VERIFY,NULL); */
801  defun(ctx,"LIST-ALL-REFERENCES",mod,LISTALLREFERENCES,NULL);
802  defun(ctx,"LIST-ALL-CATCHERS",mod,LISTALLCATCHERS,NULL);
803  defun(ctx,"LIST-ALL-BINDINGS",mod,LISTBINDINGS,NULL);
804  defun(ctx,"LIST-ALL-SPECIAL-BINDINGS",mod,LISTSPECIALBINDINGS,NULL);
805  defun(ctx,"LIST-ALL-CLASSES",mod,LISTALLCLASSES,NULL);
806  defun(ctx,"EXPORT-ALL-SYMBOLS", mod, EXPORTALL,NULL);
807  defun(ctx,"NEXT-SPECIAL-INDEX", mod, NEXT_SPECIAL_INDEX,NULL);
808  defun(ctx,"THREAD-SPECIALS", mod, THREAD_SPECIALS,NULL);
809  defun(ctx,"DISPOSE-HOOK", mod, DISPOSE_HOOK,NULL);
810 
811 /* restore package*/ pointer_update(Spevalof(PACKAGE),p);
812 }
context * euscontexts[MAXTHREAD]
Definition: eus.c:105
static char buf[CHAR_SIZE]
eusinteger_t iv[1]
Definition: eus.h:303
pointer PEEK(context *ctx, int n, argv)
Definition: sysfunc.c:592
d
pointer POKE(context *ctx, int n, argv)
Definition: sysfunc.c:639
f
int nextcix
Definition: eus.c:139
unsigned elmtype
Definition: eus.h:180
pointer cix
Definition: eus.h:325
long freeheap
Definition: memory.c:56
static int bp
struct vector vec
Definition: eus.h:412
pointer getoutstream(context *, int, pointer)
Definition: lispio.c:49
pointer NEWSTACK(context *ctx, int n, argv)
Definition: sysfunc.c:67
struct _class cls
Definition: eus.h:416
rwlock_t gc_lock
Definition: mthread.c:18
#define makeint(v)
Definition: sfttest.c:2
struct cell * pointer
Definition: eus.h:163
pointer LIST_ALL_CHUNKS(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:472
Definition: eus.h:522
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
long marktime
Definition: memory.c:59
unsigned nodispose
Definition: eus.h:388
struct chunk * chunklist
Definition: memory.c:57
pointer LISTALLREFERENCES(context *ctx, int n, argv)
Definition: sysfunc.c:528
struct string str
Definition: eus.h:400
void allocate_stack(context *, int)
Definition: makes.c:822
byte chars[1]
Definition: eus.h:210
pointer SBCOUNT(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:29
pointer val
Definition: eus.h:480
pointer T
Definition: eus.c:110
struct bcell * bpointer
Definition: eus.h:443
pointer K_SHORT
Definition: eus.c:132
void gc(void)
Definition: memory.c:778
pointer LISTALLCLASSES(context *ctx, int n, argv)
Definition: sysfunc.c:729
GLfloat n[6][3]
Definition: cube.c:15
void markall(void)
Definition: memory.c:517
pointer K_CHAR
Definition: eus.c:132
bpointer bp
Definition: eus.h:563
pointer name
Definition: eus.h:323
int special_index(void)
Definition: makes.c:673
pointer K_BYTE
Definition: eus.c:132
#define intval(p)
Definition: sfttest.c:1
int xcollect(context *ctx, pointer p)
Definition: sysfunc.c:146
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
int xmark(context *ctx, pointer p)
Definition: sysfunc.c:105
eusinteger_t edata()
pointer CLEAR_ALLOCCOUNT(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:381
pointer ROOM(context *ctx, int n, argv)
Definition: sysfunc.c:392
Definition: eus.h:1002
Definition: eus.h:445
pointer NEXT_SPECIAL_INDEX(context *ctx, int n, argv)
Definition: sysfunc.c:744
struct symbol sym
Definition: eus.h:399
ckarg(2)
float ckfltval()
pointer oldval
Definition: eus.h:485
struct intvector ivec
Definition: eus.h:414
void objsize2(pointer x)
Definition: sysfunc.c:272
Definition: eus.h:958
mutex_t mark_lock
Definition: mthread.c:25
static int cell_size
Definition: sysfunc.c:247
union cell::cellunion c
pointer LISTBINDINGS(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:703
pointer out
Definition: eus.h:289
pointer DISPOSE_HOOK(context *ctx, int n, argv)
Definition: sysfunc.c:80
int writestr(pointer, byte *, int)
Definition: eusstream.c:218
pointer label
Definition: eus.h:495
Definition: eus.h:472
Definition: eus.h:477
pointer BKTRACE(context *ctx, int n, argv)
Definition: sysfunc.c:311
Definition: eus.h:426
pointer RECLTREE(context *ctx, int n, argv)
Definition: sysfunc.c:210
char * mark_locking
Definition: mthread.c:26
pointer sym
Definition: eus.h:479
static int count_symbol
Definition: sysfunc.c:247
long l
Definition: structsize.c:3
pointer INSTANCELIST(context *ctx, int n, argv)
Definition: sysfunc.c:485
long sweeptime
Definition: memory.c:59
struct callframe * vlink
Definition: eus.h:473
Definition: eus.h:379
pointer FREE_COUNTS(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:455
struct cellheader h
Definition: eus.h:438
int rw_wrlock(rwlock_t *)
Definition: pthreads.c:188
int chunkbix
Definition: eus.h:447
pointer form
Definition: eus.h:474
long buddysize[MAXBUDDY+1]
Definition: eus.c:103
struct bindframe * lexblink
Definition: eus.h:478
short s
Definition: structsize.c:2
struct bcell * nextbcell
Definition: eus.h:440
pointer sym
Definition: eus.h:484
static int object_size
Definition: sysfunc.c:247
pointer K_DOUBLE
Definition: eus.c:133
struct bindframe * dynblink
Definition: eus.h:478
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
long eusinteger_t
Definition: eus.h:19
struct catchframe * nextcatch
Definition: eus.h:494
int export_all
Definition: intern.c:11
union bcell::@12 b
struct bcell rootcell
Definition: eus.h:448
pointer PACKAGE
Definition: eus.c:110
int alloc_small_count
Definition: eus.h:540
struct buddyfree buddy[MAXBUDDY+1]
Definition: eus.c:46
static char * rcsid
Definition: sysfunc.c:6
pointer GCTIME(context *ctx, int n, argv)
Definition: sysfunc.c:35
pointer specials
Definition: eus.h:543
pointer LISTSPECIALBINDINGS(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:717
long alloccount[MAXBUDDY]
Definition: memory.c:60
tail(char *cp)
Definition: eustags.c:1156
unsigned bix
Definition: eus.h:183
#define unlock_collector
Definition: collector.h:252
int count
Definition: thrtest.c:11
int rw_unlock(rwlock_t *)
Definition: pthreads.c:197
short cix
Definition: eus.h:188
#define TAGMASK
Definition: collector.h:168
struct specialbindframe * sblink
Definition: eus.h:483
pointer stacknlist()
int alloc_big_count
Definition: eus.h:539
pointer GEESEE(context *ctx, int n, argv)
Definition: sysfunc.c:21
#define NULL
Definition: transargv.c:8
struct iostream iostream
Definition: eus.h:405
pointer MEMORY_REPORT(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:326
pointer pname
Definition: eus.h:201
long totalheap
Definition: memory.c:56
pointer K_FLOAT
Definition: eus.c:133
pointer OBJSIZE(context *ctx, int n, argv)
Definition: sysfunc.c:290
pointer RECLAIM(context *ctx, int n, argv)
Definition: sysfunc.c:186
int newchunk(int)
Definition: memory.c:67
Definition: eus.h:437
pointer K_POINTER
Definition: eus.c:132
pointer K_INTEGER
Definition: eus.c:132
unsigned char byte
Definition: eus.h:161
pointer objsize1(pointer x)
Definition: sysfunc.c:249
pointer QTERMIO
Definition: eus.c:172
#define DPRINT1
Definition: rgc_utils.h:19
int reclaim(bpointer p)
Definition: collector.c:315
pointer THREAD_SPECIALS(context *ctx, int n, argv)
Definition: sysfunc.c:752
pointer EXPORTALL(context *ctx, int n, argv)
Definition: sysfunc.c:736
_end()
struct chunk * nextchunk
Definition: eus.h:446
void sweepall(void)
Definition: memory.c:719
long gccount
Definition: memory.c:59
pointer K_LONG
Definition: eus.c:132
pointer def
Definition: eus.h:568
struct class_desc classtab[MAXCLASS]
Definition: eus.c:138
double eusfloat_t
Definition: eus.h:20
struct cell * c[2]
Definition: eus.h:441
pointer NIL
Definition: eus.c:110
pointer syspkg
Definition: eus.c:109
pointer ALLOC(context *ctx, int n, argv)
Definition: sysfunc.c:43
pointer v[1]
Definition: eus.h:299
mutex_t alloc_lock
Definition: memory.mutex.c:42
void sysfunc(context *ctx, pointer mod)
Definition: sysfunc.c:774
pointer stacklist()
char a[26]
Definition: freq.c:4
#define lock_collector
Definition: collector.h:251
jmp_buf topjbuf
Definition: eus.c:185
static int cell_count
Definition: sysfunc.c:247
pointer makeflt()
pointer ADDRESS(context *ctx, int n, argv)
Definition: sysfunc.c:583
pointer LISTALLCATCHERS(context *ctx, int n, pointer *argv)
Definition: sysfunc.c:690


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 20:00:44