printer.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* printer.c --- euslisp printer
00003 /* Copyright(c) 1986, Toshihiro MATSUI, Electrotechnical Laboratory
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))      /*the home pkg is in use-list*/
00071         if (sym==findsymbol(pnam->c.str.chars, strlength(pnam),
00072                         ccar(pkgs)->c.pkg.symvector, &hash))
00073           return; /*found in external symbols*/
00074         else { print_symbol_prefix(ctx,f,ccar(pkgs),"::"); return;}
00075       else pkgs=ccdr(pkgs); }
00076   else if (sym==cursym) return;
00077   /* the home package is not used by the current *PACKAGE* */
00078   if (findsymbol(pnam->c.str.chars, strlength(pnam), pkg->c.pkg.symvector, &hash)) 
00079         /* external symbol in the home package?*/
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) { /*convert to lower*/
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,'\\'); /*escape char*/
00138       writech(f,*str++);}
00139     writech(f,'"');}
00140   else writestr(f,str,leng);}
00141 
00142 /****************************************************************
00143 /* printing numbers
00144 /* num ----+-->  fixnum
00145 /*         +-->  float
00146 /*         +-->  big
00147 /*         +-->  ratio
00148 /****************************************************************/
00149 
00150 void printint(ctx,num,f,base, field1, field2)   /*print fixnum*/
00151 context *ctx;
00152 register eusinteger_t num;
00153 register pointer f;
00154 int base, field1, field2;
00155 { char work[65];        /*enough for 64 binary digits + sign*/
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;   /*truncate*/
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 /* print object
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 {        /*already p_marked ->shared object*/
00328     s_mark_on(p);
00329     ckpush(p->c.obj.iv[0]);     /*save first element*/
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;     /*stream*/
00437 register pointer a;     /*array object*/
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   /*pointed object*/
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 {        /*use #n= and #n# for shared objects*/
00570     if (s_marked(x))
00571       if (p_marked (x)) {       /*first seen this shared obj. --> #n= */
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 {                    /*use #n# expression for labeled obj*/
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 


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