printer.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* printer.c --- euslisp printer
3 /* Copyright(c) 1986, Toshihiro MATSUI, Electrotechnical Laboratory
4 /*
5 /****************************************************************/
6 static char *rcsid="@(#)$Id$";
7 
8 #include <ctype.h>
9 #include "eus.h"
10 
11 #define g_marked(p) (bpointerof(p)->h.mark)
12 #define s_marked(p) (bpointerof(p)->h.smark)
13 #define p_marked(p) (bpointerof(p)->h.pmark)
14 #define g_mark_on(p) (bpointerof(p)->h.mark=1)
15 #define s_mark_on(p) (bpointerof(p)->h.smark=1)
16 #define p_mark_on(p) (bpointerof(p)->h.pmark=1)
17 #define g_mark_off(p) (bpointerof(p)->h.mark=0)
18 #define s_mark_off(p) (bpointerof(p)->h.smark=0)
19 #define p_mark_off(p) (bpointerof(p)->h.pmark=0)
20 #define to_upper(c) (islower(c) ? ((c)-'a'+'A') : (c))
21 #define to_lower(c) (isupper(c) ? ((c)-'A'+'a') : (c))
22 
23 extern pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL,PRINTBASE;
24 extern pointer QREADTABLE;
25 extern pointer K_PRIN1;
26 static void prin1(context *, pointer, pointer, int);
27 
28 static pointer *ixvec;
29 static int ix;
30 static char ixbuf[16];
31 extern enum ch_type chartype[256];
32 extern enum ch_attr charattr[256];
33 
34 static void print_symbol_prefix(ctx,f,pkg,colon)
35 context *ctx;
36 register pointer f,pkg;
37 char *colon;
38 { register pointer pkgname;
39  register int l;
40  byte *s, c;
41  pkgname=ccar(pkg->c.pkg.names);
42  l=strlength(pkgname);
43  s=pkgname->c.str.chars;
44  if (Spevalof(PRCASE)==K_DOWNCASE)
45  while (l-->0) { c= *s++; writech(f,to_lower(c));}
46  else while (l-->0) { writech(f,*s++);}
47  writestr(f,(byte *)colon,strlen(colon));}
48 
49 
50 static void symprefix(sym,f)
51 register pointer sym,f;
52 { register int l,c;
53  register byte *s;
54  register pointer pkg,pkgname,pkgs,pnam;
55  register pointer cursym;
56  int hash;
57  context *ctx=euscontexts[thr_self()];
58  pointer curpkg;
59 
60  curpkg=Spevalof(PACKAGE);
61  pkg=sym->c.sym.homepkg;
62  pnam=sym->c.sym.pname;
63  if (pkg==curpkg) return;
64  if (pkg==NIL) { writestr(f,(byte *)"#:",2); return;}
65  if (pkg==keywordpkg) { writech(f,':'); return; }
66  else if ((cursym=findsymbol(pnam->c.str.chars, strlength(pnam),
67  curpkg->c.pkg.intsymvector, &hash))==NULL) {
68  pkgs=curpkg->c.pkg.use;
69  while (islist(pkgs))
70  if (pkg==ccar(pkgs)) /*the home pkg is in use-list*/
71  if (sym==findsymbol(pnam->c.str.chars, strlength(pnam),
72  ccar(pkgs)->c.pkg.symvector, &hash))
73  return; /*found in external symbols*/
74  else { print_symbol_prefix(ctx,f,ccar(pkgs),"::"); return;}
75  else pkgs=ccdr(pkgs); }
76  else if (sym==cursym) return;
77  /* the home package is not used by the current *PACKAGE* */
78  if (findsymbol(pnam->c.str.chars, strlength(pnam), pkg->c.pkg.symvector, &hash))
79  /* external symbol in the home package?*/
80  print_symbol_prefix(ctx,f,pkg,":");
81  else print_symbol_prefix(ctx,f,pkg,"::"); }
82 
83 static pointer printsym(ctx,sym,f)
84 context *ctx;
85 register pointer sym;
86 register pointer f;
87 { register unsigned char *s;
88  pointer pnm;
89  register int i,l,c,down,escape=0,alldigits=1;
90  int base=intval(Spevalof(PRINTBASE));
91  byte b[256];
92 
93  symprefix(sym,f);
94  pnm=sym->c.sym.pname;
95  if (!isstring(pnm)) {
96  printf("printsym: illegal pname %p\n",pnm);
97  return(sym);}
98  l=vecsize(pnm);
99  s=pnm->c.str.chars;
100  down=(Spevalof(PRCASE)==K_DOWNCASE);
101  if (!ctx->slashflag) {
102  for (i=0; i<l; i++) {
103  c=s[i];
104  if (chartype[c]!=ch_constituent || islower(c)) { escape=1; break;}
105  else if (charattr[c]==package_marker || c=='`') {escape=1; break;}
106  else if (Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[c] != NIL)
107  {escape=1; break;};
108  if (!is_digit(c,base)) alldigits=0;}
109  if ((escape=(escape | alldigits))) writech(f,'|');}
110  while (l>0) {
111  i=0;
112  if (!ctx->slashflag) {
113  while (i<l && i<256) {
114  c= *s++;
115  if (chartype[c]==ch_multiescape) b[i++]='\\';
116  b[i++]=((!escape && down)?to_lower(c):c);
117  l--;}
118  writestr(f,b,i);}
119  else
120  if (down) { /*convert to lower*/
121  while (i<l && i<256) { c= *s++; b[i++]=to_lower(c);}
122  writestr(f,b,i);
123  l-=i;}
124  else { writestr(f,s,l); l=0;}
125  }
126  if (escape) writech(f,'|');
127  return(sym);}
128 
129 static void printstr(ctx,leng,str,f)
130 context *ctx;
131 register int leng;
132 register byte *str;
133 register pointer f;
134 { if (!ctx->slashflag) {
135  writech(f,'"');
136  while (leng-->0) {
137  if (*str=='"' || *str=='\\') writech(f,'\\'); /*escape char*/
138  writech(f,*str++);}
139  writech(f,'"');}
140  else writestr(f,str,leng);}
141 
142 /****************************************************************
143 /* printing numbers
144 /* num ----+--> fixnum
145 /* +--> float
146 /* +--> big
147 /* +--> ratio
148 /****************************************************************/
149 
150 void printint(ctx,num,f,base, field1, field2) /*print fixnum*/
151 context *ctx;
152 register eusinteger_t num;
153 register pointer f;
154 int base, field1, field2;
155 { char work[65]; /*enough for 64 binary digits + sign*/
156  register int i=65,digit,sign,j;
157  int downcase;
158 
159  downcase= (Spevalof(PRCASE)==K_DOWNCASE);
160  if (num<0) { sign= -1; num= -num;} else sign=0;
161  do {
162 #if (WORD_SIZE == 64)
163  digit= (unsigned long)num % base;
164  num=(unsigned long)num / base;
165 #else
166  digit= (unsigned)num % base;
167  num=(unsigned)num / base;
168 #endif
169  if (base<=10 || digit<10) work[--i]='0'+digit;
170  else if (downcase) work[--i]='a'+digit-10;
171  else work[--i]='A'+digit-10;}
172  while (num);
173  if (sign) {
174  if (field2> 65-i+1) j=field1-field2; else j=field1-(65-i+1);}
175  else {
176  if (field2> 65-i) j=field1-field2; else j=field1-(65-i);}
177  while (j-- >0) writech(f,' ');
178  if (sign) writech(f, '-');
179  j=field2-(65-i);
180  if (sign) j--;
181  while (j-- >0) writech(f,'0');
182  writestr(f,(byte *)&work[i],65-i);
183  }
184 
185 static pointer printflt(num,f)
186 double num;
187 pointer f;
188 { char work[20];
189  double absnum,fraction;
190  register int i,len,intpart;
191  extern double fabs();
192 
193  if (num==0.0) writestr(f,(byte *)"0.0",3);
194  else {
195  absnum=fabs(num);
196  if ((absnum<0.0001) || (absnum>1.0e+05)) {
197  sprintf(work,"%1.6e",num); len=strlen(work);}
198  else {
199  intpart=absnum; /*truncate*/
200  fraction=absnum-intpart;
201  if (intpart<1) i=6;
202  else if (intpart<10) i=5;
203  else if (intpart<100) i=4;
204  else if (intpart<1000) i=3;
205  else if (intpart<10000) i=2;
206  else i=1;
207  sprintf(work,"%1.*f",i,num);
208  len=strlen(work);
209  while (len>2 && work[len-1]=='0' && work[len-2]!='.') len--;}
210  writestr(f,(byte *)work,len); }}
211 
212 static void printhex(val,f)
213 int val;
214 pointer f;
215 { char work[20];
216  sprintf(work,"#x%x",val);
217  writestr(f,(byte *)work,strlen(work));}
218 
219 static void printratio(ctx,rat,f, base)
220 context *ctx;
221 pointer rat,f;
222 int base;
223 { printnum(ctx,rat->c.ratio.numerator,f,base,0,0);
224  writech(f,'/');
225  printnum(ctx,rat->c.ratio.denominator,f,base,0,0);
226  }
227 
228 extern pointer big_minus(), copy_big();
229 
230 static void printbig(ctx, big, f, base, field1,field2)
231 context *ctx;
232 pointer big,f;
233 int base, field1,field2;
234 { pointer bv,p;
235  eusinteger_t *b, d, sign; long digits=0;
236  int i, x;
237  int downcase;
238  extern eusinteger_t big_sign(), div_int_big();
239 
240  downcase=(Spevalof(PRCASE)==K_DOWNCASE);
241  sign=big_sign(big);
242  if (sign<0) big=big_minus(big);
243  else big=copy_big(big);
244  vpush(big);
245 
246  bv=big->c.bgnm.bv;
247  b=bv->c.ivec.iv;
248 
249  while (!big_zerop(big)) {
250  d=div_int_big(base,big);
251  p=makeint(d);
252  ckpush(p);
253  digits++;}
254 
255  if (field2<digits) i=field1-digits; else i=field1-field2;
256  if (sign<0) i--;
257  while (i-- > 0) writech(f, ' ');
258  if (sign<0) writech(f, '-');
259  i=field2-digits;
260  if (sign<0) i--;
261  while (i-- > 0) writech(f,'0');
262 
263  while (digits-- > 0) {
264  p=vpop();
265  x=intval(p);
266  if (x>=10) {
267  if (downcase) x=x+'a'-10;
268  else x=x+'A'-10;}
269  else x=x+'0';
270  writech(f,x);}
271  vpop();
272  }
273 
274 void printnum(ctx, nump, strm, base, field1, field2)
275 context *ctx;
276 pointer nump, strm;
277 int base;
278 int field1, field2;
279 { numunion nu;
280 
281  if (isint(nump)) printint(ctx,intval(nump), strm, base, field1, field2);
282  else if (isflt(nump)) printflt(fltval(nump),strm);
283  else if (pisbignum(nump)) printbig(ctx,nump, strm, base, field1, field2);
284  else if (pisratio(nump)) printratio(ctx, nump, strm, base);
285  else error(E_NONUMBER);}
286 
287 /****************************************************************/
288 /* print object
289 /****************************************************************/
290 
291 static void printobj(ctx,obj,f)
292 register pointer obj,f;
293 context *ctx;
294 { pointer class;
295  class=classtab[obj->cix].def;
296  writestr(f,(byte *)"#<",2);
297  printsym(ctx,class->c.cls.name,f);
298  writech(f,' ');
299  printhex(obj,f);
300  writech(f,'>');}
301 
302 static void printpkg(p,f)
303 register pointer p,f;
304 { pointer nm;
305  writestr(f,(byte *)"#<package ",10);
306  nm=ccar(p->c.pkg.names);
307  writestr(f,nm->c.str.chars,vecsize(nm));
308  writech(f,'>');}
309 
310 static void printmark(ctx,p)
311 register context *ctx;
312 register pointer p;
313 { register int i,s;
314 
315  if (isnum(p) || (pissymbol(p) && p->c.sym.homepkg != NIL) ) return;
316  if (!p_marked(p)) {
317  p_mark_on(p);
318  if (pissymbol(p)) return;
319  if (pisvector(p)) {
320  if (elmtypeof(p)<ELM_POINTER) return;
321  s=vecsize(p);
322  for (i=0; i<s; i++) printmark(ctx,p->c.vec.v[i]); }
323  else {
324  s=objsize(p);
325  for (i=0; i<s; i++) printmark(ctx,p->c.obj.iv[i]);}
326  }
327  else if (s_marked(p)) return;
328  else { /*already p_marked ->shared object*/
329  s_mark_on(p);
330  ckpush(p->c.obj.iv[0]); /*save first element*/
331  pointer_update(p->c.obj.iv[0],makeint(++ix));
332  } }
333 
334 static int getprlength(ctx)
335 context *ctx;
336 { register pointer x;
337  x=Spevalof(PRLENGTH);
338  if (isint(x)) return(intval(x));
339  else return(65536);}
340 
341 static pointer printvector(ctx,vec,f,leng,prlevel)
342 register context *ctx;
343 register pointer vec,f,leng;
344 int prlevel;
345 { register eusinteger_t n,i=0,eltype,x,prlength=getprlength(ctx);
346  pointer sizesave;
347 
348  eltype=elmtypeof(vec);
349  n=intval(leng);
350  switch(eltype) {
351  case ELM_BIT:
352  writestr(f,(byte *)"#*",2);
353  x=1;
354  while (i<n) {
355  writech(f,(vec->c.ivec.iv[i/WORD_SIZE] & x)?'1':'0');
356  i++;
357  x= x<<1;
358  if (i % WORD_SIZE==0) x=1;}
359  break;
360  case ELM_BYTE:
361  writestr(f,(byte *)"#<bytecode ",11);
362  printhex(vec,f);
363  writech(f,'>');
364  break;
365  case ELM_CHAR:
366  printstr(ctx,n,vec->c.str.chars,f); break;
367  case ELM_INT:
368  writestr(f,(byte *)"#i(",3);
369  while (i<n && prlength>0) {
370  printint(ctx,vec->c.ivec.iv[i++],f,intval(Spevalof(PRINTBASE)),
371  0,0);
372  if(i<n) writech(f,' ');
373  prlength--; }
374  if (i<n) writestr(f,(byte *)"... ",4);
375  writech(f,')');
376  break;
377  case ELM_FLOAT:
378  writestr(f,(byte *)"#f(",3);
379  while (i<n && prlength>0) {
380  printflt(vec->c.fvec.fv[i++],f);
381  if(i<n) writech(f,' ');
382  prlength--; }
383  if (i<n) writestr(f,(byte *)"... ",4);
384  writech(f,')');
385  break;
386  case ELM_FOREIGN:
387  writestr(f,(byte *)"#u",2);
388  printstr(ctx,vecsize(vec),vec->c.ivec.iv[0],f);
389  break;
390  default:
391  if (classof(vec)==C_VECTOR) writestr(f,(byte *)"#(",2);
392  else {
393  writestr(f,(byte *)"#v(",3);
394  printsym(ctx,classof(vec)->c.cls.name,f);
395  writech(f,' ');
396  printint(ctx,(eusinteger_t)vec->c.vec.size,f,intval(Spevalof(PRINTBASE)),0,0);
397  writech(f,' ');}
398  while (i<n && prlength>0) {
399  prin1(ctx,vec->c.vec.v[i++],f,prlevel);
400  if (i<n) writech(f,' '); }
401  if (i<n) writestr(f,(byte *)"... ",4);
402  writech(f,')');}
403  return(vec);}
404 
405 static void prinelm(ctx,f,prlevel,vec,index)
406 register context *ctx;
407 register pointer f,vec;
408 int prlevel,index;
409 { switch(elmtypeof(vec)) {
410  case ELM_BIT:
411  { eusinteger_t bitmask;
412 #if (WORD_SIZE == 64)
413  bitmask=1L << (index % 64);
414  writech(f,(vec->c.ivec.iv[index/64] & bitmask)?'1':'0');
415 #else
416  bitmask=1 << (index % 32);
417  writech(f,(vec->c.str.chars[index/32] & bitmask)?'1':'0');
418 #endif
419  }
420  break;
421  case ELM_BYTE: case ELM_CHAR:
422  printint(ctx,vec->c.str.chars[index],f,intval(Spevalof(PRINTBASE)),
423  0,0);
424  break;
425  case ELM_INT:
426  printint(ctx,vec->c.ivec.iv[index],f,intval(Spevalof(PRINTBASE)),
427  0,0);
428  break;
429  case ELM_FLOAT:
430  printflt(vec->c.fvec.fv[index],f); break;
431  default:
432  prin1(ctx,vec->c.vec.v[index],f,prlevel);
433  }}
434 
435 static int prinary(ctx,f,prlevel,a,rank,axis,index)
436 register context *ctx;
437 register pointer f; /*stream*/
438 register pointer a; /*array object*/
439 int prlevel,rank,axis,index;
440 { register int i,n,next;
441  n=intval(a->c.ary.dim[axis]);
442  writech(f,'(');
443  if (axis<rank-1) {
444  for (i=0; i<n; i++) {
445  next=prinary(ctx,f,prlevel,a,rank,axis+1,index);
446  if (i<n-1) writech(f,' ');
447  index+=next;}
448  n=next*n;}
449  else {
450  if (rank==1 && isint(a->c.ary.fillpointer)) n=intval(a->c.ary.fillpointer);
451  for (i=0; i<n; i++) {
452  prinelm(ctx,f,prlevel-1,a->c.ary.entity,index+i);
453  if (i<n-1) writech(f,' ');} }
454  writech(f,')');
455  return(n);}
456 
457 static void printarray(ctx,a,f,prlevel)
458 register context *ctx;
459 register pointer a,f;
460 register int prlevel;
461 { char buf[16];
462  register int i,j,rank,etype,size=1,index;
463  register pointer p,v;
464  rank=intval(a->c.ary.rank);
465  etype=elmtypeof(a->c.ary.entity);
466  sprintf(buf,"#%d%c",rank,(etype==ELM_FLOAT)?'f':
467  (etype==ELM_INT)?'i':'a');
468  writestr(f,(byte *)buf,strlen(buf));
469  if (isint(a->c.ary.offset)) index=intval(a->c.ary.offset); else index=0;
470  prinary(ctx,f,prlevel,a,rank,0,index);
471  }
472 
473 static void printlist(ctx,x,f,fobj,prlevel)
474 register context *ctx;
475 register pointer x,f;
476 register pointer fobj;
477 register int prlevel;
478 { register pointer rest=ccdr(x);
479  register int prlength=getprlength(ctx),shareix;
480 
481  if (fobj==QUOTE && islist(rest) && ccdr(rest)==NIL) {
482  writech(f,'\'');
483  prin1(ctx,ccar(rest),f,prlevel-1);
484  return;}
485  else if (fobj==FUNCTION && islist(rest) && ccdr(rest)==NIL) {
486  writestr(f,(byte *)"#\'",2);
487  prin1(ctx,ccar(rest),f,prlevel-1);
488  return;}
489  writech(f,'(');
490  prin1(ctx,fobj,f,prlevel);
491  x=rest;
492  while (islist(x) && !s_marked(x)) {
493  if (--prlength<=0) {
494  writestr(f,(byte *)" ...",4);
495  x=NIL; break;}
496  else {
497  writech(f,' ');
498  prin1(ctx,ccar(x),f,prlevel);
499  x=ccdr(x);} }
500  if (x!=NIL) { writestr(f,(byte *)" . ",3); prin1(ctx,x,f,prlevel);}
501  writech(f,')'); }
502 
503 static void printstructure(ctx,x,f,fobj,prlevel)
504 register context *ctx;
505 register pointer x,f;
506 register pointer fobj;
507 int prlevel;
508 { pointer klass, *varvec;
509  register int i=0,s;
510  int prlength=getprlength(ctx);
511 
512  writestr(f,(byte *)"#s(",3);
513  klass=classof(x);
514  printsym(ctx,klass->c.cls.name,f);
515  s=objsize(x); varvec=klass->c.cls.vars->c.vec.v;
516  prlength--;
517  while (i<s && prlength>0) {
518  writech(f,' ');
519  printsym(ctx,varvec[i],f);
520  writech(f,' ');
521  if (i==0) prin1(ctx,fobj,f,prlevel);
522  else prin1(ctx,x->c.obj.iv[i],f,prlevel);
523  i++; prlength-=2;}
524  if (i<s) writestr(f,(byte *)" ...",4);
525  writech(f,')');
526  }
527 
528 static void prinxobj(ctx,x,f,fobj,prlevel)
529 register context *ctx;
530 register pointer x,f;
531 pointer fobj;
532 int prlevel;
533 { pointer klass;
534  register int i=0,s;
535  int prlength=getprlength(ctx);
536  writestr(f,(byte *)"#J(",3);
537  klass=classof(x);
538  printsym(ctx,klass->c.cls.name,f);
539  s=objsize(x);
540  while (i<s && prlength-->0) {
541  writech(f,' ');
542  if (i==0) prin1(ctx,fobj,f,prlevel);
543  else prin1(ctx,x->c.obj.iv[i],f,prlevel);
544  i++;}
545  writech(f,')');
546  }
547 
548 static void prin1(ctx,x,f,prlevel)
549 register context *ctx;
550 register pointer x;
551 register pointer f;
552 register int prlevel;
553 { register pointer fobj;
554  register int shareix=0;
555  numunion nu;
556 
557  if (prlevel<=0) { writech(f,'#'); return;}
558  if (isnum(x)) { printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
559  else if (x==UNBOUND) { writestr(f,(byte *)"***UNBOUND***",13); return;}
560  /*pointed object*/
561 #if vax || sun4 || news || mips || alpha || Linux
562  if ((x<(pointer)(ctx->stack)) && ((pointer)(ctx->stacklimit)<x)){
563  printint(ctx,(eusinteger_t)x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
564 #endif
565  if (pisratio(x)) {
566  printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0); return;}
567  else if (pisbignum(x)) {
568  printnum(ctx,x,f,intval(Spevalof(PRINTBASE)),0,0);
569  return;}
570  else { /*use #n= and #n# for shared objects*/
571  if (s_marked(x))
572  if (p_marked (x)) { /*first seen this shared obj. --> #n= */
573  p_mark_off(x);
574  shareix=intval(x->c.obj.iv[0]);
575  sprintf(ixbuf,"#%d=",shareix);
576  writestr(f,(byte *)ixbuf,strlen(ixbuf));
577  fobj=ixvec[shareix]; }
578  else { /*use #n# expression for labeled obj*/
579  sprintf(ixbuf,"#%ld#",intval(x->c.obj.iv[0]));
580  writestr(f,(byte *)ixbuf,strlen(ixbuf));
581  return; }
582  else fobj=x->c.obj.iv[0];
583  if (classof(x)==C_CONS) printlist(ctx,x,f,fobj,prlevel-1);
584  else if (pissymbol(x)) { printsym(ctx,x,f); return;}
585  else if (pisvector(x)) printvector(ctx,x,f,fobj,prlevel-1);
586  else if (Spevalof(PROBJECT)!=NIL) prinxobj(ctx,x,f,fobj,prlevel-1);
587  else if (pisarray(x) && (classof(x)==C_ARRAY)) printarray(ctx,x,f,prlevel-1);
588  else if (Spevalof(PRSTRUCTURE)!=NIL) printstructure(ctx,x,f,fobj,prlevel-1);
589  else csend(ctx,x,K_PRIN1,1,f);
590  } }
591 
592 static void printunmark(p)
593 register pointer p;
594 { register int i,s;
595  if (isnum(p)) return;
596  if (!s_marked(p) && !p_marked(p)) return;
597  if (s_marked(p))
598  if (p_marked(p)) fprintf(stderr,"smarked?\n");
599  else pointer_update(p->c.obj.iv[0],ixvec[intval(p->c.obj.iv[0])]);
600  s_mark_off(p); p_mark_off(p);
601  if (pissymbol(p)) return;
602  else if (pisvector(p)) {
603  if (elmtypeof(p)<ELM_POINTER) return;
604  s=vecsize(p);
605  for (i=0; i<s; i++) printunmark(p->c.vec.v[i]); }
606  else {
607  s=objsize(p);
608  for (i=0; i<s; i++) printunmark(p->c.obj.iv[i]); }
609  }
610 
611 pointer prinx(ctx,obj,stream)
612 register context *ctx;
613 register pointer obj,stream;
614 { pointer *spsave=ctx->vsp;
615  pointer prlevel;
616  int iprlevel;
617 
618  prlevel=Spevalof(PRLEVEL);
619  if (isint(prlevel)) iprlevel=intval(prlevel); else iprlevel=65536;
620  if (Spevalof(PRCIRCLE)!=NIL) {
621  ixvec=ctx->vsp; ix=0; vpush(0);
622 #if THREADED
623  mutex_lock(&mark_lock);
624  mark_locking="prinx";
625 #endif
626  printmark(ctx,obj);
627  prin1(ctx,obj,stream,iprlevel);
628  printunmark(obj);
629 #if THREADED
630  mutex_unlock(&mark_lock);
631 #endif
632  }
633  else prin1(ctx,obj,stream,iprlevel);
634  ctx->vsp=spsave;
635  return(obj);}
636 
637 void terpri(f)
638 register pointer f;
639 { writech(f,'\n'); flushstream(f); }
640 
print_symbol_prefix
static void print_symbol_prefix(context *ctx, pointer f, pointer pkg, char *colon)
Definition: printer.c:34
writestr
int writestr(pointer, byte *, int)
Definition: eusstream.c:218
big_minus
pointer big_minus()
rank
int rank(int n, int p, MATRIX s)
Definition: rank.c:3
numunion
Definition: eus.h:428
cell::cellunion::cls
struct _class cls
Definition: eus.h:418
PRCIRCLE
pointer PRCIRCLE
Definition: eus.c:171
PRLENGTH
pointer PRLENGTH
Definition: printer.c:23
big_sign
eusinteger_t big_sign(pointer)
Definition: big.c:423
prinelm
static void prinelm(context *ctx, pointer f, int prlevel, pointer vec, int index)
Definition: printer.c:405
buf
static char buf[CHAR_SIZE]
Definition: helpsub.c:23
NIL
pointer NIL
Definition: eus.c:110
l
long l
Definition: structsize.c:3
QUOTE
pointer QUOTE
Definition: eus.c:110
class::name
pointer name
Definition: eus.old.h:209
prinary
static int prinary(context *ctx, pointer f, int prlevel, pointer a, int rank, int axis, int index)
Definition: printer.c:435
makeint
#define makeint(v)
Definition: sfttest.c:2
context
Definition: eus.h:524
s
short s
Definition: structsize.c:2
printarray
static void printarray(context *ctx, pointer a, pointer f, int prlevel)
Definition: printer.c:457
ch_constituent
@ ch_constituent
Definition: eus.h:461
printsym
static pointer printsym(context *ctx, pointer sym, pointer f)
Definition: printer.c:83
PACKAGE
pointer PACKAGE
Definition: eus.c:110
printratio
static void printratio(context *ctx, pointer rat, pointer f, int base)
Definition: printer.c:219
floatvector::fv
eusfloat_t fv[1]
Definition: eus.h:309
ch_multiescape
@ ch_multiescape
Definition: eus.h:463
intval
#define intval(p)
Definition: sfttest.c:1
div_int_big
eusinteger_t div_int_big(eusinteger_t c, pointer x)
Definition: big.c:628
ixbuf
static char ixbuf[16]
Definition: printer.c:30
E_NONUMBER
@ E_NONUMBER
Definition: eus.h:960
ch_attr
ch_attr
Definition: eus.h:467
rcsid
static char * rcsid
Definition: printer.c:6
eus.h
cell::cellunion::sym
struct symbol sym
Definition: eus.h:401
mark_lock
mutex_t mark_lock
Definition: mthread.c:25
C_VECTOR
pointer C_VECTOR
Definition: eus.c:144
C_ARRAY
pointer C_ARRAY
Definition: eus.c:147
symbol::pname
pointer pname
Definition: eus.h:207
printmark
static void printmark(context *ctx, pointer p)
Definition: printer.c:310
stream
Definition: eus.h:273
cell::cellunion::bgnm
struct bignum bgnm
Definition: eus.h:424
_class::name
pointer name
Definition: eus.h:325
cell::cellunion::ivec
struct intvector ivec
Definition: eus.h:416
PROBJECT
pointer PROBJECT
Definition: printer.c:23
is_digit
int is_digit(int, int)
Definition: reader.c:770
printhex
static void printhex(int val, pointer f)
Definition: printer.c:212
string::chars
byte chars[1]
Definition: eus.h:212
prinxobj
static void prinxobj(context *ctx, pointer x, pointer f, pointer fobj, int prlevel)
Definition: printer.c:528
cell::c
union cell::cellunion c
printstr
static void printstr(context *ctx, int leng, byte *str, pointer f)
Definition: printer.c:129
class_desc::def
pointer def
Definition: eus.h:570
flushstream
int flushstream(pointer)
Definition: eusstream.c:159
K_PRIN1
pointer K_PRIN1
Definition: eus.c:174
getprlength
static int getprlength(context *ctx)
Definition: printer.c:334
PRCASE
pointer PRCASE
Definition: printer.c:23
big_zerop
eusinteger_t big_zerop(pointer x)
Definition: big.c:408
NULL
#define NULL
Definition: transargv.c:8
package_marker
@ package_marker
Definition: eus.h:468
fltval
float fltval()
cell::cellunion::ratio
struct ratio ratio
Definition: eus.h:422
vector::v
pointer v[1]
Definition: eus.h:301
printobj
static void printobj(context *ctx, pointer obj, pointer f)
Definition: printer.c:291
charattr
enum ch_attr charattr[256]
Definition: reader.c:115
euscontexts
context * euscontexts[MAXTHREAD]
Definition: eus.c:105
classtab
struct class_desc classtab[MAXCLASS]
Definition: eus.c:138
printvector
static pointer printvector(context *ctx, pointer vec, pointer f, pointer leng, int prlevel)
Definition: printer.c:341
findsymbol
int findsymbol(char *s)
Definition: contrib/vxworks/vxwserv.c:74
csend
pointer csend(context *,...)
K_DOWNCASE
pointer K_DOWNCASE
Definition: eus.c:134
object::iv
pointer iv[2]
Definition: eus.h:321
d
d
ratio::denominator
pointer denominator
Definition: eus.h:370
PRLEVEL
pointer PRLEVEL
Definition: printer.c:23
C_CONS
pointer C_CONS
Definition: eus.c:142
printstructure
static void printstructure(context *ctx, pointer x, pointer f, pointer fobj, int prlevel)
Definition: printer.c:503
symprefix
static void symprefix(pointer sym, pointer f)
Definition: printer.c:50
context::stack
pointer * stack
Definition: eus.h:525
prinx
pointer prinx(context *ctx, pointer obj, pointer stream)
Definition: printer.c:611
vector::size
pointer size
Definition: eus.h:300
printunmark
static void printunmark(pointer p)
Definition: printer.c:592
cell::cellunion::obj
struct object obj
Definition: eus.h:417
context::stacklimit
pointer * stacklimit
Definition: eus.h:525
bignum::bv
pointer bv
Definition: eus.h:378
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
package::symvector
pointer symvector
Definition: eus.h:222
printlist
static void printlist(context *ctx, pointer x, pointer f, pointer fobj, int prlevel)
Definition: printer.c:473
f
f
package::names
pointer names
Definition: eus.h:220
cell
Definition: eus.h:381
package::intsymvector
pointer intsymvector
Definition: eus.h:224
eusinteger_t
long eusinteger_t
Definition: eus.h:19
PRINTBASE
pointer PRINTBASE
Definition: printer.c:23
context::vsp
pointer * vsp
Definition: eus.h:525
prin1
static void prin1(context *, pointer, pointer, int)
Definition: printer.c:548
keywordpkg
pointer keywordpkg
Definition: eus.c:109
mark_locking
char * mark_locking
Definition: mthread.c:26
printint
void printint(context *ctx, eusinteger_t num, pointer f, int base, int field1, int field2)
Definition: printer.c:150
index
char * index(char *sp, char c)
Definition: eustags.c:1669
printnum
void printnum(context *ctx, pointer nump, pointer strm, int base, int field1, int field2)
Definition: printer.c:274
ratio::numerator
pointer numerator
Definition: eus.h:369
package::use
pointer use
Definition: eus.h:221
writech
int writech(pointer, int)
terpri
void terpri(pointer f)
Definition: printer.c:637
QREADTABLE
pointer QREADTABLE
Definition: eus.c:172
printbig
static void printbig(context *ctx, pointer big, pointer f, int base, int field1, int field2)
Definition: printer.c:230
copy_big
pointer copy_big()
printpkg
static void printpkg(pointer p, pointer f)
Definition: printer.c:302
intvector::iv
eusinteger_t iv[1]
Definition: eus.h:305
FUNCTION
pointer FUNCTION
Definition: eus.c:111
ixvec
static pointer * ixvec
Definition: printer.c:28
cell::cellunion::vec
struct vector vec
Definition: eus.h:414
a
char a[26]
Definition: freq.c:4
ix
static int ix
Definition: printer.c:29
class
Definition: eus.old.h:207
printflt
static pointer printflt(double num, pointer f)
Definition: printer.c:185
cell::cellunion::pkg
struct package pkg
Definition: eus.h:404
chartype
enum ch_type chartype[256]
Definition: reader.c:49
cell::cellunion::fvec
struct floatvector fvec
Definition: eus.h:415
n
GLfloat n[6][3]
Definition: cube.c:15
symbol::homepkg
pointer homepkg
Definition: eus.h:208
v
GLfloat v[8][3]
Definition: cube.c:21
_class::vars
pointer vars
Definition: eus.h:328
cell::cellunion::str
struct string str
Definition: eus.h:402
thr_self
unsigned int thr_self()
Definition: eus.c:25
ch_type
ch_type
Definition: eus.h:456
PRSTRUCTURE
pointer PRSTRUCTURE
Definition: printer.c:23

euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:43