home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLPRIN.C < prev    next >
Text File  |  1988-11-22  |  8KB  |  323 lines
  1. /* xlprint - xlisp print routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL tentry();
  10. extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
  11. extern LVAL s_ifmt,s_ffmt;
  12. extern FUNDEF funtab[];
  13. extern char buf[];
  14.  
  15. /* xlprint - print an xlisp value */
  16. xlprint(fptr,vptr,flag)
  17.   LVAL fptr,vptr; int flag;
  18. {
  19.     LVAL nptr,next;
  20.     int n,i;
  21.  
  22.     /* print nil */
  23.     if (vptr == NIL) {
  24.     putsymbol(fptr,"NIL",flag);
  25.     return;
  26.     }
  27.  
  28.     /* check value type */
  29.     switch (ntype(vptr)) {
  30.     case SUBR:
  31.         putsubr(fptr,"Subr",vptr);
  32.         break;
  33.     case FSUBR:
  34.         putsubr(fptr,"FSubr",vptr);
  35.         break;
  36.     case CONS:
  37.         xlputc(fptr,'(');
  38.         for (nptr = vptr; nptr != NIL; nptr = next) {
  39.             xlprint(fptr,car(nptr),flag);
  40.         if (next = cdr(nptr))
  41.             if (consp(next))
  42.             xlputc(fptr,' ');
  43.             else {
  44.             xlputstr(fptr," . ");
  45.             xlprint(fptr,next,flag);
  46.             break;
  47.             }
  48.         }
  49.         xlputc(fptr,')');
  50.         break;
  51.     case SYMBOL:
  52.         putsymbol(fptr,getstring(getpname(vptr)),flag);
  53.         break;
  54.     case FIXNUM:
  55.         putfixnum(fptr,getfixnum(vptr));
  56.         break;
  57.     case FLONUM:
  58.         putflonum(fptr,getflonum(vptr));
  59.         break;
  60.     case CHAR:
  61.         putchcode(fptr,getchcode(vptr),flag);
  62.         break;
  63.     case STRING:
  64.         if (flag)
  65.         putqstring(fptr,vptr);
  66.         else
  67.         putstring(fptr,vptr);
  68.         break;
  69.     case STREAM:
  70.         putatm(fptr,"File-Stream",vptr);
  71.         break;
  72.     case USTREAM:
  73.         putatm(fptr,"Unnamed-Stream",vptr);
  74.         break;
  75.     case OBJECT:
  76.         putatm(fptr,"Object",vptr);
  77.         break;
  78.     case VECTOR:
  79.         xlputc(fptr,'#'); xlputc(fptr,'(');
  80.         for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
  81.         xlprint(fptr,getelement(vptr,i),flag);
  82.         if (i != n) xlputc(fptr,' ');
  83.         }
  84.         xlputc(fptr,')');
  85.         break;
  86.     case STRUCT:
  87.         xlprstruct(fptr,vptr,flag);
  88.         break;
  89.     case CLOSURE:
  90.         putclosure(fptr,vptr);
  91.         break;
  92.     case FREE:
  93.         putatm(fptr,"Free",vptr);
  94.         break;
  95.     default:
  96.         putatm(fptr,"Foo",vptr);
  97.         break;
  98.     }
  99. }
  100.  
  101. /* xlterpri - terminate the current print line */
  102. xlterpri(fptr)
  103.   LVAL fptr;
  104. {
  105.     xlputc(fptr,'\n');
  106. }
  107.  
  108. /* xlputstr - output a string */
  109. xlputstr(fptr,str)
  110.   LVAL fptr; char *str;
  111. {
  112.     while (*str)
  113.     xlputc(fptr,*str++);
  114. }
  115.  
  116. /* putsymbol - output a symbol */
  117. LOCAL putsymbol(fptr,str,escflag)
  118.   LVAL fptr; char *str; int escflag;
  119. {
  120.     int downcase,ch;
  121.     LVAL type;
  122.     char *p;
  123.  
  124.     /* check for printing without escapes */
  125.     if (!escflag) {
  126.     xlputstr(fptr,str);
  127.     return;
  128.     }
  129.  
  130.     /* check to see if symbol needs escape characters */
  131.     if (tentry(*str) == k_const) {
  132.     for (p = str; *p; ++p)
  133.         if (islower(*p)
  134.         ||  ((type = tentry(*p)) != k_const
  135.           && (!consp(type) || car(type) != k_nmacro))) {
  136.         xlputc(fptr,'|');
  137.         while (*str) {
  138.             if (*str == '\\' || *str == '|')
  139.             xlputc(fptr,'\\');
  140.             xlputc(fptr,*str++);
  141.         }
  142.         xlputc(fptr,'|');
  143.         return;
  144.         }
  145.     }
  146.  
  147.     /* get the case translation flag */
  148.     downcase = (getvalue(s_printcase) == k_downcase);
  149.  
  150.     /* check for the first character being '#' */
  151.     if (*str == '#' || *str == '.' || isnumber(str,NULL))
  152.     xlputc(fptr,'\\');
  153.  
  154.     /* output each character */
  155.     while ((ch = *str++) != '\0') {
  156.     /* don't escape colon until we add support for packages */
  157.     if (ch == '\\' || ch == '|' /* || ch == ':' */)
  158.         xlputc(fptr,'\\');
  159.     xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
  160.     }
  161. }
  162.  
  163. /* putstring - output a string */
  164. LOCAL putstring(fptr,str)
  165.   LVAL fptr,str;
  166. {
  167.     unsigned char *p;
  168.     int ch;
  169.  
  170.     /* output each character */
  171.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  172.     xlputc(fptr,ch);
  173. }
  174.  
  175. /* putqstring - output a quoted string */
  176. LOCAL putqstring(fptr,str)
  177.   LVAL fptr,str;
  178. {
  179.     unsigned char *p;
  180.     int ch;
  181.  
  182.     /* get the string pointer */
  183.     p = getstring(str);
  184.  
  185.     /* output the initial quote */
  186.     xlputc(fptr,'"');
  187.  
  188.     /* output each character in the string */
  189.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  190.  
  191.     /* check for a control character */
  192.     if (ch < 040 || ch == '\\' || ch > 0176) {
  193.         xlputc(fptr,'\\');
  194.         switch (ch) {
  195.         case '\011':
  196.             xlputc(fptr,'t');
  197.             break;
  198.         case '\012':
  199.             xlputc(fptr,'n');
  200.             break;
  201.         case '\014':
  202.             xlputc(fptr,'f');
  203.             break;
  204.         case '\015':
  205.             xlputc(fptr,'r');
  206.             break;
  207.         case '\\':
  208.             xlputc(fptr,'\\');
  209.             break;
  210.         default:
  211.             putoct(fptr,ch);
  212.             break;
  213.         }
  214.     }
  215.  
  216.     /* output a normal character */
  217.     else
  218.         xlputc(fptr,ch);
  219.  
  220.     /* output the terminating quote */
  221.     xlputc(fptr,'"');
  222. }
  223.  
  224. /* putatm - output an atom */
  225. LOCAL putatm(fptr,tag,val)
  226.   LVAL fptr; char *tag; LVAL val;
  227. {
  228.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  229.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  230.     xlputc(fptr,'>');
  231. }
  232.  
  233. /* putsubr - output a subr/fsubr */
  234. LOCAL putsubr(fptr,tag,val)
  235.   LVAL fptr; char *tag; LVAL val;
  236. {
  237.     sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
  238.     xlputstr(fptr,buf);
  239.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  240.     xlputc(fptr,'>');
  241. }
  242.  
  243. /* putclosure - output a closure */
  244. LOCAL putclosure(fptr,val)
  245.   LVAL fptr,val;
  246. {
  247.     LVAL name;
  248.     if (name = getname(val))
  249.     sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
  250.     else
  251.     strcpy(buf,"#<Closure: #");
  252.     xlputstr(fptr,buf);
  253.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  254.     xlputc(fptr,'>');
  255. /*
  256.     xlputstr(fptr,"\nName:   "); xlprint(fptr,getname(val),TRUE);
  257.     xlputstr(fptr,"\nType:   "); xlprint(fptr,gettype(val),TRUE);
  258.     xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
  259.     xlputstr(fptr,"\nArgs:   "); xlprint(fptr,getargs(val),TRUE);
  260.     xlputstr(fptr,"\nOargs:  "); xlprint(fptr,getoargs(val),TRUE);
  261.     xlputstr(fptr,"\nRest:   "); xlprint(fptr,getrest(val),TRUE);
  262.     xlputstr(fptr,"\nKargs:  "); xlprint(fptr,getkargs(val),TRUE);
  263.     xlputstr(fptr,"\nAargs:  "); xlprint(fptr,getaargs(val),TRUE);
  264.     xlputstr(fptr,"\nBody:   "); xlprint(fptr,getbody(val),TRUE);
  265.     xlputstr(fptr,"\nEnv:    "); xlprint(fptr,getenv(val),TRUE);
  266.     xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
  267. */
  268. }
  269.  
  270. /* putfixnum - output a fixnum */
  271. LOCAL putfixnum(fptr,n)
  272.   LVAL fptr; FIXTYPE n;
  273. {
  274.     unsigned char *fmt;
  275.     LVAL val;
  276.     fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
  277.                             : (unsigned char *)IFMT);
  278.     sprintf(buf,fmt,n);
  279.     xlputstr(fptr,buf);
  280. }
  281.  
  282. /* putflonum - output a flonum */
  283. LOCAL putflonum(fptr,n)
  284.   LVAL fptr; FLOTYPE n;
  285. {
  286.     unsigned char *fmt;
  287.     LVAL val;
  288.     fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
  289.                             : (unsigned char *)"%g");
  290.     sprintf(buf,fmt,n);
  291.     xlputstr(fptr,buf);
  292. }
  293.  
  294. /* putchcode - output a character */
  295. LOCAL putchcode(fptr,ch,escflag)
  296.   LVAL fptr; int ch,escflag;
  297. {
  298.     if (escflag) {
  299.     switch (ch) {
  300.     case '\n':
  301.         xlputstr(fptr,"#\\Newline");
  302.         break;
  303.     case ' ':
  304.         xlputstr(fptr,"#\\Space");
  305.         break;
  306.     default:
  307.         sprintf(buf,"#\\%c",ch);
  308.         xlputstr(fptr,buf);
  309.         break;
  310.     }
  311.     }
  312.     else
  313.     xlputc(fptr,ch);
  314. }
  315.  
  316. /* putoct - output an octal byte value */
  317. LOCAL putoct(fptr,n)
  318.   LVAL fptr; int n;
  319. {
  320.     sprintf(buf,"%03o",n);
  321.     xlputstr(fptr,buf);
  322. }
  323.