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