00001
00002
00003
00004
00005
00006 static char *rcsid="@(#)$Id$";
00007
00008 #include <ctype.h>
00009 #include "eus.h"
00010
00011 #define g_marked(p) (bpointerof(p)->h.mark)
00012 #define s_marked(p) (bpointerof(p)->h.smark)
00013 #define p_marked(p) (bpointerof(p)->h.pmark)
00014 #define g_mark_on(p) (bpointerof(p)->h.mark=1)
00015 #define s_mark_on(p) (bpointerof(p)->h.smark=1)
00016 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
00017 #define g_mark_off(p) (bpointerof(p)->h.mark=0)
00018 #define s_mark_off(p) (bpointerof(p)->h.smark=0)
00019 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
00020 #define to_upper(c) (islower(c) ? ((c)-'a'+'A') : (c))
00021 #define to_lower(c) (isupper(c) ? ((c)-'A'+'a') : (c))
00022
00023 extern pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL,PRINTBASE;
00024 extern pointer QREADTABLE;
00025 extern pointer K_PRIN1;
00026 static void prin1(context *, pointer, pointer, int);
00027
00028 static pointer *ixvec;
00029 static int ix;
00030 static char ixbuf[16];
00031 extern enum ch_type chartype[256];
00032 extern enum ch_attr charattr[256];
00033
00034 static print_symbol_prefix(ctx,f,pkg,colon)
00035 context *ctx;
00036 register pointer f,pkg;
00037 char *colon;
00038 { register pointer pkgname;
00039 register int l;
00040 byte *s, c;
00041 pkgname=ccar(pkg->c.pkg.names);
00042 l=strlength(pkgname);
00043 s=pkgname->c.str.chars;
00044 if (Spevalof(PRCASE)==K_DOWNCASE)
00045 while (l-->0) { c= *s++; writech(f,to_lower(c));}
00046 else while (l-->0) { writech(f,*s++);}
00047 writestr(f,(byte *)colon,strlen(colon));}
00048
00049
00050 static pointer symprefix(sym,f)
00051 register pointer sym,f;
00052 { register int l,c;
00053 register byte *s;
00054 register pointer pkg,pkgname,pkgs,pnam;
00055 register pointer cursym;
00056 int hash;
00057 context *ctx=euscontexts[thr_self()];
00058 pointer curpkg;
00059
00060 curpkg=Spevalof(PACKAGE);
00061 pkg=sym->c.sym.homepkg;
00062 pnam=sym->c.sym.pname;
00063 if (pkg==curpkg) return;
00064 if (pkg==NIL) { writestr(f,(byte *)"#:",2); return;}
00065 if (pkg==keywordpkg) { writech(f,':'); return; }
00066 else if ((cursym=findsymbol(pnam->c.str.chars, strlength(pnam),
00067 curpkg->c.pkg.intsymvector, &hash))==NULL) {
00068 pkgs=curpkg->c.pkg.use;
00069 while (islist(pkgs))
00070 if (pkg==ccar(pkgs))
00071 if (sym==findsymbol(pnam->c.str.chars, strlength(pnam),
00072 ccar(pkgs)->c.pkg.symvector, &hash))
00073 return;
00074 else { print_symbol_prefix(ctx,f,ccar(pkgs),"::"); return;}
00075 else pkgs=ccdr(pkgs); }
00076 else if (sym==cursym) return;
00077
00078 if (findsymbol(pnam->c.str.chars, strlength(pnam), pkg->c.pkg.symvector, &hash))
00079
00080 print_symbol_prefix(ctx,f,pkg,":");
00081 else print_symbol_prefix(ctx,f,pkg,"::"); }
00082
00083 static pointer printsym(ctx,sym,f)
00084 context *ctx;
00085 register pointer sym;
00086 register pointer f;
00087 { register unsigned char *s;
00088 pointer pnm;
00089 register int i,l,c,down,escape=0,alldigits=1;
00090 int base=intval(Spevalof(PRINTBASE));
00091 byte b[256];
00092
00093 symprefix(sym,f);
00094 pnm=sym->c.sym.pname;
00095 if (!isstring(pnm)) {
00096 printf("printsym: illegal pname %p\n",pnm);
00097 return(sym);}
00098 l=vecsize(pnm);
00099 s=pnm->c.str.chars;
00100 down=(Spevalof(PRCASE)==K_DOWNCASE);
00101 if (!ctx->slashflag) {
00102 for (i=0; i<l; i++) {
00103 c=s[i];
00104 if (chartype[c]!=ch_constituent || islower(c)) { escape=1; break;}
00105 else if (charattr[c]==package_marker || c=='`') {escape=1; break;}
00106 else if (Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[c] != NIL)
00107 {escape=1; break;};
00108 if (!is_digit(c,base)) alldigits=0;}
00109 if ((escape=(escape | alldigits))) writech(f,'|');}
00110 while (l>0) {
00111 i=0;
00112 if (!ctx->slashflag) {
00113 while (i<l && i<256) {
00114 c= *s++;
00115 if (chartype[c]==ch_multiescape) b[i++]='\\';
00116 b[i++]=((!escape && down)?to_lower(c):c);
00117 l--;}
00118 writestr(f,b,i);}
00119 else
00120 if (down) {
00121 while (i<l && i<256) { c= *s++; b[i++]=to_lower(c);}
00122 writestr(f,b,i);
00123 l-=i;}
00124 else { writestr(f,s,l); l=0;}
00125 }
00126 if (escape) writech(f,'|');
00127 return(sym);}
00128
00129 static void printstr(ctx,leng,str,f)
00130 context *ctx;
00131 register int leng;
00132 register byte *str;
00133 register pointer f;
00134 { if (!ctx->slashflag) {
00135 writech(f,'"');
00136 while (leng-->0) {
00137 if (*str=='"' || *str=='\\') writech(f,'\\');
00138 writech(f,*str++);}
00139 writech(f,'"');}
00140 else writestr(f,str,leng);}
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150 void printint(ctx,num,f,base, field1, field2)
00151 context *ctx;
00152 register eusinteger_t num;
00153 register pointer f;
00154 int base, field1, field2;
00155 { char work[65];
00156 register int i=65,digit,sign,j;
00157 int downcase;
00158
00159 downcase= (Spevalof(PRCASE)==K_DOWNCASE);
00160 if (num<0) { sign= -1; num= -num;} else sign=0;
00161 do {
00162 #if (WORD_SIZE == 64)
00163 digit= (unsigned long)num % base;
00164 num=(unsigned long)num / base;
00165 #else
00166 digit= (unsigned)num % base;
00167 num=(unsigned)num / base;
00168 #endif
00169 if (base<=10 || digit<10) work[--i]='0'+digit;
00170 else if (downcase) work[--i]='a'+digit-10;
00171 else work[--i]='A'+digit-10;}
00172 while (num);
00173 if (sign) {
00174 if (field2> 65-i+1) j=field1-field2; else j=field1-(65-i+1);}
00175 else {
00176 if (field2> 65-i) j=field1-field2; else j=field1-(65-i);}
00177 while (j-- >0) writech(f,' ');
00178 if (sign) writech(f, '-');
00179 j=field2-(65-i);
00180 if (sign) j--;
00181 while (j-- >0) writech(f,'0');
00182 writestr(f,(byte *)&work[i],65-i);
00183 }
00184
00185 static pointer printflt(num,f)
00186 double num;
00187 pointer f;
00188 { char work[20];
00189 double absnum,fraction;
00190 register int i,len,intpart;
00191 extern double fabs();
00192
00193 if (num==0.0) writestr(f,(byte *)"0.0",3);
00194 else {
00195 absnum=fabs(num);
00196 if ((absnum<0.0001) || (absnum>1.0e+05)) {
00197 sprintf(work,"%1.6e",num); len=strlen(work);}
00198 else {
00199 intpart=absnum;
00200 fraction=absnum-intpart;
00201 if (intpart<1) i=6;
00202 else if (intpart<10) i=5;
00203 else if (intpart<100) i=4;
00204 else if (intpart<1000) i=3;
00205 else if (intpart<10000) i=2;
00206 else i=1;
00207 sprintf(work,"%1.*f",i,num);
00208 len=strlen(work);
00209 while (len>2 && work[len-1]=='0' && work[len-2]!='.') len--;}
00210 writestr(f,(byte *)work,len); }}
00211
00212 static printhex(val,f)
00213 int val;
00214 pointer f;
00215 { char work[20];
00216 sprintf(work,"#x%x",val);
00217 writestr(f,(byte *)work,strlen(work));}
00218
00219 static printratio(ctx,rat,f, base)
00220 context *ctx;
00221 pointer rat,f;
00222 int base;
00223 { printnum(ctx,rat->c.ratio.numerator,f,base,0,0);
00224 writech(f,'/');
00225 printnum(ctx,rat->c.ratio.denominator,f,base,0,0);
00226 }
00227
00228 extern pointer big_minus(), copy_big();
00229
00230 static printbig(ctx, big, f, base, field1,field2)
00231 context *ctx;
00232 pointer big,f;
00233 int base, field1,field2;
00234 { pointer bv,p;
00235 eusinteger_t *b, d, sign; long digits=0;
00236 int i, x;
00237 int downcase;
00238 extern eusinteger_t big_sign(), div_int_big();
00239
00240 downcase=(Spevalof(PRCASE)==K_DOWNCASE);
00241 sign=big_sign(big);
00242 if (sign<0) big=big_minus(big);
00243 else big=copy_big(big);
00244 vpush(big);
00245
00246 bv=big->c.bgnm.bv;
00247 b=bv->c.ivec.iv;
00248
00249 while (!big_zerop(big)) {
00250 d=div_int_big(base,big);
00251 p=makeint(d);
00252 ckpush(p);
00253 digits++;}
00254
00255 if (field2<digits) i=field1-digits; else i=field1-field2;
00256 if (sign<0) i--;
00257 while (i-- > 0) writech(f, ' ');
00258 if (sign<0) writech(f, '-');
00259 i=field2-digits;
00260 if (sign<0) i--;
00261 while (i-- > 0) writech(f,'0');
00262
00263 while (digits-- > 0) {
00264 p=vpop();
00265 x=intval(p);
00266 if (x>=10) {
00267 if (downcase) x=x+'a'-10;
00268 else x=x+'A'-10;}
00269 else x=x+'0';
00270 writech(f,x);}
00271 vpop();
00272 }
00273
00274 void printnum(ctx, nump, strm, base, field1, field2)
00275 context *ctx;
00276 pointer nump, strm;
00277 int base;
00278 int field1, field2;
00279 { numunion nu;
00280
00281 if (isint(nump)) printint(ctx,intval(nump), strm, base, field1, field2);
00282 else if (isflt(nump)) printflt(fltval(nump),strm);
00283 else if (pisbignum(nump)) printbig(ctx,nump, strm, base, field1, field2);
00284 else if (pisratio(nump)) printratio(ctx, nump, strm, base);
00285 else error(E_NONUMBER);}
00286
00287
00288
00289
00290
00291 static void printobj(ctx,obj,f)
00292 register pointer obj,f;
00293 context *ctx;
00294 { pointer class;
00295 class=classtab[obj->cix].def;
00296 writestr(f,(byte *)"#<",2);
00297 printsym(ctx,class->c.cls.name,f);
00298 writech(f,' ');
00299 printhex(obj,f);
00300 writech(f,'>');}
00301
00302 static void printpkg(p,f)
00303 register pointer p,f;
00304 { pointer nm;
00305 writestr(f,(byte *)"#<package ",10);
00306 nm=ccar(p->c.pkg.names);
00307 writestr(f,nm->c.str.chars,vecsize(nm));
00308 writech(f,'>');}
00309
00310 static void printmark(ctx,p)
00311 register context *ctx;
00312 register pointer p;
00313 { register int i,s;
00314
00315 if (isnum(p) || pissymbol(p)) return;
00316 if (!p_marked(p)) {
00317 p_mark_on(p);
00318 if (pisvector(p)) {
00319 if (elmtypeof(p)<ELM_POINTER) return;
00320 s=vecsize(p);
00321 for (i=0; i<s; i++) printmark(ctx,p->c.vec.v[i]); }
00322 else {
00323 s=objsize(p);
00324 for (i=0; i<s; i++) printmark(ctx,p->c.obj.iv[i]);}
00325 }
00326 else if (s_marked(p)) return;
00327 else {
00328 s_mark_on(p);
00329 ckpush(p->c.obj.iv[0]);
00330 pointer_update(p->c.obj.iv[0],makeint(++ix));
00331 } }
00332
00333 static int getprlength(ctx)
00334 context *ctx;
00335 { register pointer x;
00336 x=Spevalof(PRLENGTH);
00337 if (isint(x)) return(intval(x));
00338 else return(65536);}
00339
00340 static pointer printvector(ctx,vec,f,leng,prlevel)
00341 register context *ctx;
00342 register pointer vec,f,leng;
00343 int prlevel;
00344 { register eusinteger_t n,i=0,eltype,x,prlength=getprlength(ctx);
00345 pointer sizesave;
00346
00347 eltype=elmtypeof(vec);
00348 n=intval(leng);
00349 switch(eltype) {
00350 case ELM_BIT:
00351 writestr(f,(byte *)"#*",2);
00352 x=1;
00353 while (i<n) {
00354 writech(f,(vec->c.ivec.iv[i/WORD_SIZE] & x)?'1':'0');
00355 i++;
00356 x= x<<1;
00357 if (i % WORD_SIZE==0) x=1;}
00358 break;
00359 case ELM_BYTE:
00360 writestr(f,(byte *)"#<bytecode ",11);
00361 printhex(vec,f);
00362 writech(f,'>');
00363 break;
00364 case ELM_CHAR:
00365 printstr(ctx,n,vec->c.str.chars,f); break;
00366 case ELM_INT:
00367 writestr(f,(byte *)"#i(",3);
00368 while (i<n && prlength>0) {
00369 printint(ctx,vec->c.ivec.iv[i++],f,intval(Spevalof(PRINTBASE)),
00370 0,0);
00371 if(i<n) writech(f,' ');
00372 prlength--; }
00373 if (i<n) writestr(f,(byte *)"... ",4);
00374 writech(f,')');
00375 break;
00376 case ELM_FLOAT:
00377 writestr(f,(byte *)"#f(",3);
00378 while (i<n && prlength>0) {
00379 printflt(vec->c.fvec.fv[i++],f);
00380 if(i<n) writech(f,' ');
00381 prlength--; }
00382 if (i<n) writestr(f,(byte *)"... ",4);
00383 writech(f,')');
00384 break;
00385 case ELM_FOREIGN:
00386 writestr(f,(byte *)"#u",2);
00387 printstr(ctx,vecsize(vec),vec->c.ivec.iv[0],f);
00388 break;
00389 default:
00390 if (classof(vec)==C_VECTOR) writestr(f,(byte *)"#(",2);
00391 else {
00392 writestr(f,(byte *)"#v(",3);
00393 printsym(ctx,classof(vec)->c.cls.name,f);
00394 writech(f,' ');
00395 printint(ctx,(eusinteger_t)vec->c.vec.size,f,intval(Spevalof(PRINTBASE)),0,0);
00396 writech(f,' ');}
00397 while (i<n && prlength>0) {
00398 prin1(ctx,vec->c.vec.v[i++],f,prlevel);
00399 if (i<n) writech(f,' '); }
00400 if (i<n) writestr(f,(byte *)"... ",4);
00401 writech(f,')');}
00402 return(vec);}
00403
00404 static void prinelm(ctx,f,prlevel,vec,index)
00405 register context *ctx;
00406 register pointer f,vec;
00407 int prlevel,index;
00408 { switch(elmtypeof(vec)) {
00409 case ELM_BIT:
00410 { eusinteger_t bitmask;
00411 #if (WORD_SIZE == 64)
00412 bitmask=1L << (index % 64);
00413 writech(f,(vec->c.ivec.iv[index/64] & bitmask)?'1':'0');
00414 #else
00415 bitmask=1 << (index % 32);
00416 writech(f,(vec->c.str.chars[index/32] & bitmask)?'1':'0');
00417 #endif
00418 }
00419 break;
00420 case ELM_BYTE: case ELM_CHAR:
00421 printint(ctx,vec->c.str.chars[index],f,intval(Spevalof(PRINTBASE)),
00422 0,0);
00423 break;
00424 case ELM_INT:
00425 printint(ctx,vec->c.ivec.iv[index],f,intval(Spevalof(PRINTBASE)),
00426 0,0);
00427 break;
00428 case ELM_FLOAT:
00429 printflt(vec->c.fvec.fv[index],f); break;
00430 default:
00431 prin1(ctx,vec->c.vec.v[index],f,prlevel);
00432 }}
00433
00434 static int prinary(ctx,f,prlevel,a,rank,axis,index)
00435 register context *ctx;
00436 register pointer f;
00437 register pointer a;
00438 int prlevel,rank,axis,index;
00439 { register int i,n,next;
00440 n=intval(a->c.ary.dim[axis]);
00441 writech(f,'(');
00442 if (axis<rank-1) {
00443 for (i=0; i<n; i++) {
00444 next=prinary(ctx,f,prlevel,a,rank,axis+1,index);
00445 if (i<n-1) writech(f,' ');
00446 index+=next;}
00447 n=next*n;}
00448 else {
00449 if (rank==1 && isint(a->c.ary.fillpointer)) n=intval(a->c.ary.fillpointer);
00450 for (i=0; i<n; i++) {
00451 prinelm(ctx,f,prlevel-1,a->c.ary.entity,index+i);
00452 if (i<n-1) writech(f,' ');} }
00453 writech(f,')');
00454 return(n);}
00455
00456 static printarray(ctx,a,f,prlevel)
00457 register context *ctx;
00458 register pointer a,f;
00459 { char buf[16];
00460 register int i,j,rank,etype,size=1,index;
00461 register pointer p,v;
00462 rank=intval(a->c.ary.rank);
00463 etype=elmtypeof(a->c.ary.entity);
00464 sprintf(buf,"#%d%c",rank,(etype==ELM_FLOAT)?'f':
00465 (etype==ELM_INT)?'i':'a');
00466 writestr(f,(byte *)buf,strlen(buf));
00467 if (isint(a->c.ary.offset)) index=intval(a->c.ary.offset); else index=0;
00468 prinary(ctx,f,prlevel,a,rank,0,index);
00469 }
00470
00471 static void printlist(ctx,x,f,fobj,prlevel)
00472 register context *ctx;
00473 register pointer x,f;
00474 register pointer fobj;
00475 register int prlevel;
00476 { register pointer rest=ccdr(x);
00477 register int prlength=getprlength(ctx),shareix;
00478
00479 if (fobj==QUOTE && islist(rest) && ccdr(rest)==NIL) {
00480 writech(f,'\'');
00481 prin1(ctx,ccar(rest),f,prlevel-1);
00482 return;}
00483 else if (fobj==FUNCTION && islist(rest) && ccdr(rest)==NIL) {
00484 writestr(f,(byte *)"#\'",2);
00485 prin1(ctx,ccar(rest),f,prlevel-1);
00486 return;}
00487 writech(f,'(');
00488 prin1(ctx,fobj,f,prlevel);
00489 x=rest;
00490 while (islist(x) && !s_marked(x)) {
00491 if (--prlength<=0) {
00492 writestr(f,(byte *)" ...",4);
00493 x=NIL; break;}
00494 else {
00495 writech(f,' ');
00496 prin1(ctx,ccar(x),f,prlevel);
00497 x=ccdr(x);} }
00498 if (x!=NIL) { writestr(f,(byte *)" . ",3); prin1(ctx,x,f,prlevel);}
00499 writech(f,')'); }
00500
00501 static void printstructure(ctx,x,f,fobj,prlevel)
00502 register context *ctx;
00503 register pointer x,f;
00504 register pointer fobj;
00505 int prlevel;
00506 { pointer klass, *varvec;
00507 register int i=0,s;
00508 int prlength=getprlength(ctx);
00509
00510 writestr(f,(byte *)"#s(",3);
00511 klass=classof(x);
00512 printsym(ctx,klass->c.cls.name,f);
00513 s=objsize(x); varvec=klass->c.cls.vars->c.vec.v;
00514 prlength--;
00515 while (i<s && prlength>0) {
00516 writech(f,' ');
00517 printsym(ctx,varvec[i],f);
00518 writech(f,' ');
00519 if (i==0) prin1(ctx,fobj,f,prlevel);
00520 else prin1(ctx,x->c.obj.iv[i],f,prlevel);
00521 i++; prlength-=2;}
00522 if (i<s) writestr(f,(byte *)" ...",4);
00523 writech(f,')');
00524 }
00525
00526 static void prinxobj(ctx,x,f,fobj,prlevel)
00527 register context *ctx;
00528 register pointer x,f;
00529 pointer fobj;
00530 int prlevel;
00531 { pointer klass;
00532 register int i=0,s;
00533 int prlength=getprlength(ctx);
00534 writestr(f,(byte *)"#J(",3);
00535 klass=classof(x);
00536 printsym(ctx,klass->c.cls.name,f);
00537 s=objsize(x);
00538 while (i<s && prlength-->0) {
00539 writech(f,' ');
00540 if (i==0) prin1(ctx,fobj,f,prlevel);
00541 else prin1(ctx,x->c.obj.iv[i],f,prlevel);
00542 i++;}
00543 writech(f,')');
00544 }
00545
00546 static void prin1(ctx,x,f,prlevel)
00547 register context *ctx;
00548 register pointer x;
00549 register pointer f;
00550 register int prlevel;
00551 { register pointer fobj;
00552 register int shareix=0;
00553 numunion nu;
00554
00555 if (prlevel<=0) { writech(f,'#'); return;}
00556 if (isnum(x)) { printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
00557 else if (x==UNBOUND) { writestr(f,(byte *)"***UNBOUND***",13); return;}
00558
00559 #if vax || sun4 || news || mips || i386 || alpha || x86_64 || ARM
00560 if ((x<(pointer)(ctx->stack)) && ((pointer)(ctx->stacklimit)<x)){
00561 printint(ctx,(eusinteger_t)x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
00562 #endif
00563 if (pissymbol(x)) { printsym(ctx,x,f); return;}
00564 else if (pisratio(x)) {
00565 printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
00566 else if (pisbignum(x)) {
00567 printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0);
00568 return;}
00569 else {
00570 if (s_marked(x))
00571 if (p_marked (x)) {
00572 p_mark_off(x);
00573 shareix=intval(x->c.obj.iv[0]);
00574 sprintf(ixbuf,"#%d=",shareix);
00575 writestr(f,(byte *)ixbuf,strlen(ixbuf));
00576 fobj=ixvec[shareix]; }
00577 else {
00578 sprintf(ixbuf,"#%ld#",intval(x->c.obj.iv[0]));
00579 writestr(f,(byte *)ixbuf,strlen(ixbuf));
00580 return; }
00581 else fobj=x->c.obj.iv[0];
00582 if (classof(x)==C_CONS) printlist(ctx,x,f,fobj,prlevel-1);
00583 else if (pisvector(x)) printvector(ctx,x,f,fobj,prlevel-1);
00584 else if (Spevalof(PROBJECT)!=NIL) prinxobj(ctx,x,f,fobj,prlevel-1);
00585 else if (pisarray(x) && (classof(x)==C_ARRAY)) printarray(ctx,x,f,prlevel-1);
00586 else if (Spevalof(PRSTRUCTURE)!=NIL) printstructure(ctx,x,f,fobj,prlevel-1);
00587 else csend(ctx,x,K_PRIN1,1,f);
00588 } }
00589
00590 static void printunmark(p)
00591 register pointer p;
00592 { register int i,s;
00593 if (isnum(p)) return;
00594 if (!s_marked(p) && !p_marked(p)) return;
00595 if (s_marked(p))
00596 if (p_marked(p)) fprintf(stderr,"smarked?\n");
00597 else pointer_update(p->c.obj.iv[0],ixvec[intval(p->c.obj.iv[0])]);
00598 s_mark_off(p); p_mark_off(p);
00599 if (pissymbol(p)) return;
00600 else if (pisvector(p)) {
00601 if (elmtypeof(p)<ELM_POINTER) return;
00602 s=vecsize(p);
00603 for (i=0; i<s; i++) printunmark(p->c.vec.v[i]); }
00604 else {
00605 s=objsize(p);
00606 for (i=0; i<s; i++) printunmark(p->c.obj.iv[i]); }
00607 }
00608
00609 pointer prinx(ctx,obj,stream)
00610 register context *ctx;
00611 register pointer obj,stream;
00612 { pointer *spsave=ctx->vsp;
00613 pointer prlevel;
00614 int iprlevel;
00615
00616 prlevel=Spevalof(PRLEVEL);
00617 if (isint(prlevel)) iprlevel=intval(prlevel); else iprlevel=65536;
00618 if (Spevalof(PRCIRCLE)!=NIL) {
00619 ixvec=ctx->vsp; ix=0; vpush(0);
00620 #if THREADED
00621 mutex_lock(&mark_lock);
00622 mark_locking="prinx";
00623 #endif
00624 printmark(ctx,obj);
00625 prin1(ctx,obj,stream,iprlevel);
00626 printunmark(obj);
00627 #if THREADED
00628 mutex_unlock(&mark_lock);
00629 #endif
00630 }
00631 else prin1(ctx,obj,stream,iprlevel);
00632 ctx->vsp=spsave;
00633 return(obj);}
00634
00635 void terpri(f)
00636 register pointer f;
00637 { writech(f,'\n'); flushstream(f); }
00638