home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xscheme / xsprint.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-01-29  |  6.3 KB  |  317 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. /* 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. /* putconstant - output a constant */
  169. LOCAL putconstant(fptr,tag,sym,escflag)
  170.   LVAL fptr; char *tag,*sym; int escflag;
  171. {
  172.     xlputstr(fptr,tag);
  173.     putsym(fptr,sym,escflag);
  174. }
  175.  
  176. /* putstring - output a string */
  177. LOCAL putstring(fptr,str)
  178.   LVAL fptr; char *str;
  179. {
  180.     int ch;
  181.  
  182.     /* output the initial quote */
  183.     xlputc(fptr,'"');
  184.  
  185.     /* output each character in the string */
  186.     while (ch = *str++)
  187.  
  188.     /* check for a control character */
  189.     if (ch < 040 || ch == '\\' || ch == '"') {
  190.         xlputc(fptr,'\\');
  191.         switch (ch) {
  192.         case '\033':
  193.             xlputc(fptr,'e');
  194.             break;
  195.         case '\n':
  196.             xlputc(fptr,'n');
  197.             break;
  198.         case '\r':
  199.             xlputc(fptr,'r');
  200.             break;
  201.         case '\t':
  202.             xlputc(fptr,'t');
  203.             break;
  204.         case '\\':
  205.         case '"':
  206.             xlputc(fptr,ch);
  207.             break;
  208.         default:
  209.             putoct(fptr,ch);
  210.             break;
  211.         }
  212.     }
  213.  
  214.     /* output a normal character */
  215.     else
  216.         xlputc(fptr,ch);
  217.  
  218.     /* output the terminating quote */
  219.     xlputc(fptr,'"');
  220. }
  221.  
  222. /* putsym - output a symbol */
  223. LOCAL putsym(fptr,str,escflag)
  224.   LVAL fptr; char *str; int escflag;
  225. {
  226.     int ch;
  227.  
  228.     /* check for printing without escapes */
  229.     if (!escflag) {
  230.     xlputstr(fptr,str);
  231.     return;
  232.     }
  233.  
  234.     /* output each character */
  235.     if (getvalue(s_printcase) == k_downcase) {
  236.     while ((ch = *str++) != '\0')
  237.         xlputc(fptr,isupper(ch) ? tolower(ch) : ch);
  238.     }
  239.     else {
  240.     while ((ch = *str++) != '\0')
  241.         xlputc(fptr,islower(ch) ? toupper(ch) : ch);
  242.     }
  243. }
  244.  
  245. /* putsubr - output a subr/fsubr */
  246. LOCAL putsubr(fptr,tag,val)
  247.   LVAL fptr; char *tag; LVAL val;
  248. {
  249.     extern FUNDEF funtab[];
  250.     sprintf(buf,"#<%s %s>",tag,funtab[getoffset(val)].fd_name);
  251.     xlputstr(fptr,buf);
  252. }
  253.  
  254. /* putclosure - output a closure */
  255. LOCAL putclosure(fptr,tag,val)
  256.   LVAL fptr; char *tag; LVAL val;
  257. {
  258.     putcode(fptr,tag,getcode(val));
  259. }
  260.  
  261. /* putcode - output a code object */
  262. LOCAL putcode(fptr,tag,val)
  263.   LVAL fptr; char *tag; LVAL val;
  264. {
  265.     LVAL name;
  266.     if (name = getelement(val,1)) {
  267.     sprintf(buf,"#<%s %s>",tag,getstring(getpname(name)));
  268.     xlputstr(fptr,buf);
  269.     }
  270.     else
  271.     putatm(fptr,tag,val);
  272. }
  273.  
  274. /* putnumber - output a number */
  275. LOCAL putnumber(fptr,n)
  276.   LVAL fptr; FIXTYPE n;
  277. {
  278.     LVAL fmt = getvalue(s_fixfmt);
  279.     sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : IFMT),n);
  280.     xlputstr(fptr,buf);
  281. }
  282.  
  283. /* putoct - output an octal byte value */
  284. LOCAL putoct(fptr,n)
  285.   LVAL fptr; int n;
  286. {
  287.     sprintf(buf,"%03o",n);
  288.     xlputstr(fptr,buf);
  289. }
  290.  
  291. /* putflonum - output a flonum */
  292. LOCAL putflonum(fptr,n)
  293.   LVAL fptr; FLOTYPE n;
  294. {
  295.     LVAL fmt = getvalue(s_flofmt);
  296.     sprintf(buf,(stringp(fmt) ? (char *)getstring(fmt) : FFMT),n);
  297.     xlputstr(fptr,buf);
  298. }
  299.  
  300. /* putcharacter - output a character value */
  301. LOCAL putcharacter(fptr,ch)
  302.   LVAL fptr; int ch;
  303. {
  304.     switch (ch) {
  305.     case '\n':
  306.     xlputstr(fptr,"#\\Newline");
  307.     break;
  308.     case ' ':
  309.     xlputstr(fptr,"#\\Space");
  310.     break;
  311.     default:
  312.     sprintf(buf,"#\\%c",ch);
  313.     xlputstr(fptr,buf);
  314.     break;
  315.     }
  316. }
  317.