home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xsprint.c < prev    next >
Text File  |  1991-05-14  |  7KB  |  324 lines
  1. /* xsprint.c - xscheme print routine */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* global variables */
  9. int prbreadth = -1;
  10. int prdepth = -1;
  11.  
  12. /* local variables */
  13. static char buf[200];
  14.  
  15. /* external variables */
  16. extern LVAL true,s_printcase,k_downcase;
  17. extern LVAL s_fixfmt,s_flofmt,s_unbound;
  18.  
  19. #ifdef __STDC__
  20. static void print(LVAL fptr,LVAL vptr,int escflag,int depth);
  21. static void putatm(LVAL fptr,char *tag,LVAL val);
  22. static void putstring(LVAL fptr,char *str);
  23. static void putsym(LVAL fptr,char *str,int escflag);
  24. static void putsubr(LVAL fptr,char *tag,LVAL val);
  25. static void putclosure(LVAL fptr,char *tag,LVAL val);
  26. static void putcode(LVAL fptr,char *tag,LVAL val);
  27. static void putnumber(LVAL fptr,FIXTYPE n);
  28. static void putoct(LVAL fptr,int n);
  29. static void putflonum(LVAL fptr,FLOTYPE n);
  30. static void putcharacter(LVAL fptr,int ch);
  31. #endif
  32.  
  33. /* xlprin1 - print an expression with quoting */
  34. void xlprin1(expr,file)
  35.   LVAL expr,file;
  36. {
  37.     print(file,expr,TRUE,0);
  38. }
  39.  
  40. /* xlprinc - print an expression without quoting */
  41. void xlprinc(expr,file)
  42.   LVAL expr,file;
  43. {
  44.     print(file,expr,FALSE,0);
  45. }
  46.  
  47. /* xlterpri - terminate the current print line */
  48. void xlterpri(fptr)
  49.   LVAL fptr;
  50. {
  51.     xlputc(fptr,'\n');
  52. }
  53.  
  54. /* xlputstr - output a string */
  55. void xlputstr(fptr,str)
  56.   LVAL fptr; char *str;
  57. {
  58.     while (*str)
  59.     xlputc(fptr,*str++);
  60. }
  61.  
  62. /* print - internal print routine */
  63. static void print(fptr,vptr,escflag,depth)
  64.   LVAL fptr,vptr; int escflag,depth;
  65. {
  66.     int breadth,size,i;
  67.     LVAL nptr,next;
  68.  
  69.     /* print nil */
  70.     if (vptr == NIL) {
  71.     xlputstr(fptr,"()");
  72.     return;
  73.     }
  74.  
  75.     /* check value type */
  76.     switch (ntype(vptr)) {
  77.     case SUBR:
  78.     case XSUBR:
  79.         putsubr(fptr,"Subr",vptr);
  80.         break;
  81.     case CSUBR:
  82.         putsubr(fptr,"CSubr",vptr);
  83.         break;
  84.     case CONS:
  85.         if (prdepth >= 0 && depth >= prdepth) {
  86.         xlputstr(fptr,"(...)");
  87.         break;
  88.         }
  89.         xlputc(fptr,'(');
  90.         breadth = 0;
  91.         for (nptr = vptr; nptr != NIL; ) {
  92.         if (prbreadth >= 0 && breadth++ >= prbreadth) {
  93.             xlputstr(fptr,"...");
  94.             break;
  95.         }
  96.             print(fptr,car(nptr),escflag,depth+1);
  97.         if ((next = cdr(nptr)) != NIL)
  98.             if (consp(next))
  99.             xlputc(fptr,' ');
  100.             else {
  101.             xlputstr(fptr," . ");
  102.             print(fptr,next,escflag,depth+1);
  103.             break;
  104.             }
  105.         nptr = next;
  106.         }
  107.         xlputc(fptr,')');
  108.         break;
  109.     case VECTOR:
  110.         xlputstr(fptr,"#(");
  111.         for (i = 0, size = getsize(vptr); i < size; ++i) {
  112.         if (i != 0) xlputc(fptr,' ');
  113.         print(fptr,getelement(vptr,i),escflag,depth+1);
  114.         }
  115.         xlputc(fptr,')');
  116.         break;
  117.     case OBJECT:
  118.         putatm(fptr,"Object",vptr);
  119.         break;
  120.     case SYMBOL:
  121.         putsym(fptr,getstring(getpname(vptr)),escflag);
  122.         break;
  123.     case PROMISE:
  124.         if (getpproc(vptr) != NIL)
  125.         putatm(fptr,"Promise",vptr);
  126.         else
  127.         putatm(fptr,"Forced-promise",vptr);
  128.         break;
  129.     case CLOSURE:
  130.         putclosure(fptr,"Procedure",vptr);
  131.         break;
  132.     case METHOD:
  133.         putclosure(fptr,"Method",vptr);
  134.         break;
  135.     case FIXNUM:
  136.         putnumber(fptr,getfixnum(vptr));
  137.         break;
  138.     case FLONUM:
  139.         putflonum(fptr,getflonum(vptr));
  140.         break;
  141.     case CHAR:
  142.         if (escflag)
  143.         putcharacter(fptr,getchcode(vptr));
  144.         else
  145.         xlputc(fptr,getchcode(vptr));
  146.         break;
  147.     case STRING:
  148.         if (escflag)
  149.             putstring(fptr,getstring(vptr));
  150.         else
  151.             xlputstr(fptr,getstring(vptr));
  152.         break;
  153.     case PORT:
  154.         putatm(fptr,"Port",vptr);
  155.         break;
  156.     case CODE:
  157.         putcode(fptr,"Code",vptr);
  158.         break;
  159.     case CONTINUATION:
  160.         putatm(fptr,"Escape-procedure",vptr);
  161.         break;
  162.     case ENV:
  163.         putatm(fptr,"Environment",vptr);
  164.         break;
  165.     case FREE:
  166.         putatm(fptr,"Free",vptr);
  167.         break;
  168.     default:
  169.         putatm(fptr,"Foo",vptr);
  170.         break;
  171.     }
  172. }
  173.  
  174. /* putatm - output an atom */
  175. static void putatm(fptr,tag,val)
  176.   LVAL fptr; char *tag; LVAL val;
  177. {
  178.     sprintf(buf,"#<%s #",tag); xlputstr(fptr,buf);
  179.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  180.     xlputc(fptr,'>');
  181. }
  182.  
  183. /* putstring - output a string */
  184. static void putstring(fptr,str)
  185.   LVAL fptr; char *str;
  186. {
  187.     int ch;
  188.  
  189.     /* output the initial quote */
  190.     xlputc(fptr,'"');
  191.  
  192.     /* output each character in the string */
  193.     while ((ch = *str++) != '\0')
  194.  
  195.     /* check for a control character */
  196.     if (ch < 040 || ch == '\\' || ch == '"') {
  197.         xlputc(fptr,'\\');
  198.         switch (ch) {
  199.         case '\033':
  200.             xlputc(fptr,'e');
  201.             break;
  202.         case '\n':
  203.             xlputc(fptr,'n');
  204.             break;
  205.         case '\r':
  206.             xlputc(fptr,'r');
  207.             break;
  208.         case '\t':
  209.             xlputc(fptr,'t');
  210.             break;
  211.         case '\\':
  212.         case '"':
  213.             xlputc(fptr,ch);
  214.             break;
  215.         default:
  216.             putoct(fptr,ch);
  217.             break;
  218.         }
  219.     }
  220.  
  221.     /* output a normal character */
  222.     else
  223.         xlputc(fptr,ch);
  224.  
  225.     /* output the terminating quote */
  226.     xlputc(fptr,'"');
  227. }
  228.  
  229. /* putsym - output a symbol */
  230. static void putsym(fptr,str,escflag)
  231.   LVAL fptr; char *str; int escflag;
  232. {
  233.     int ch;
  234.  
  235.     /* check for printing without escapes */
  236.     if (!escflag) {
  237.     xlputstr(fptr,str);
  238.     return;
  239.     }
  240.  
  241.     /* output each character */
  242.     if (getvalue(s_printcase) == k_downcase) {
  243.     while ((ch = *str++) != '\0')
  244.         xlputc(fptr,isupper(ch) ? tolower(ch) : ch);
  245.     }
  246.     else {
  247.     while ((ch = *str++) != '\0')
  248.         xlputc(fptr,islower(ch) ? toupper(ch) : ch);
  249.     }
  250. }
  251.  
  252. /* putsubr - output a subr/fsubr */
  253. static void putsubr(fptr,tag,val)
  254.   LVAL fptr; char *tag; LVAL val;
  255. {
  256.     extern FUNDEF funtab[];
  257.     sprintf(buf,"#<%s %s>",tag,funtab[getoffset(val)].fd_name);
  258.     xlputstr(fptr,buf);
  259. }
  260.  
  261. /* putclosure - output a closure */
  262. static void putclosure(fptr,tag,val)
  263.   LVAL fptr; char *tag; LVAL val;
  264. {
  265.     putcode(fptr,tag,getcode(val));
  266. }
  267.  
  268. /* putcode - output a code object */
  269. static void putcode(fptr,tag,val)
  270.   LVAL fptr; char *tag; LVAL val;
  271. {
  272.     LVAL name;
  273.     if ((name = getelement(val,1)) == NIL)
  274.     putatm(fptr,tag,val);
  275.     else {
  276.     sprintf(buf,"#<%s %s>",tag,getstring(getpname(name)));
  277.     xlputstr(fptr,buf);
  278.     }
  279. }
  280.  
  281. /* putnumber - output a number */
  282. static void putnumber(fptr,n)
  283.   LVAL fptr; FIXTYPE n;
  284. {
  285.     LVAL fmt = getvalue(s_fixfmt);
  286.     sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : IFMT),n);
  287.     xlputstr(fptr,buf);
  288. }
  289.  
  290. /* putoct - output an octal byte value */
  291. static void putoct(fptr,n)
  292.   LVAL fptr; int n;
  293. {
  294.     sprintf(buf,"%03o",n);
  295.     xlputstr(fptr,buf);
  296. }
  297.  
  298. /* putflonum - output a flonum */
  299. static void putflonum(fptr,n)
  300.   LVAL fptr; FLOTYPE n;
  301. {
  302.     LVAL fmt = getvalue(s_flofmt);
  303.     sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : FFMT),n);
  304.     xlputstr(fptr,buf);
  305. }
  306.  
  307. /* putcharacter - output a character value */
  308. static void putcharacter(fptr,ch)
  309.   LVAL fptr; int ch;
  310. {
  311.     switch (ch) {
  312.     case '\n':
  313.     xlputstr(fptr,"#\\Newline");
  314.     break;
  315.     case ' ':
  316.     xlputstr(fptr,"#\\Space");
  317.     break;
  318.     default:
  319.     sprintf(buf,"#\\%c",ch);
  320.     xlputstr(fptr,buf);
  321.     break;
  322.     }
  323. }
  324.