home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP12.ARK / XLPRIN.C < prev    next >
Text File  |  1985-02-19  |  3KB  |  167 lines
  1. /* xlprint - xlisp print routine */
  2.  
  3. #ifdef AZTEC
  4. #include "stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* external variables */
  12. extern struct node *xlstack;
  13.  
  14. /* local variables */
  15. static char buf[STRMAX+1];
  16.  
  17. /* xlprint - print an xlisp value */
  18. xlprint(fptr,vptr,flag)
  19.   struct node *fptr,*vptr; int flag;
  20. {
  21.     struct node *nptr,*next,*msg;
  22.  
  23.     /* print null as the empty list */
  24.     if (vptr == NULL) {
  25.     putstr(fptr,"nil");
  26.     return;
  27.     }
  28.  
  29.     /* check value type */
  30.     switch (vptr->n_type) {
  31.     case SUBR:
  32.         putatm(fptr,"Subr",vptr);
  33.         break;
  34.     case FSUBR:
  35.         putatm(fptr,"FSubr",vptr);
  36.         break;
  37.     case LIST:
  38.         xlputc(fptr,'(');
  39.         for (nptr = vptr; nptr != NULL; nptr = next) {
  40.             xlprint(fptr,nptr->n_listvalue,flag);
  41.         if ((next = nptr->n_listnext) != NULL)
  42.             if (next->n_type == LIST)
  43.             xlputc(fptr,' ');
  44.             else {
  45.             putstr(fptr," . ");
  46.             xlprint(fptr,next,flag);
  47.             break;
  48.             }
  49.         }
  50.         xlputc(fptr,')');
  51.         break;
  52.     case SYM:
  53.         putstr(fptr,xlsymname(vptr));
  54.         break;
  55.     case INT:
  56.         putdec(fptr,vptr->n_int);
  57.         break;
  58.     case STR:
  59.         if (flag)
  60.         putstring(fptr,vptr->n_str);
  61.         else
  62.         putstr(fptr,vptr->n_str);
  63.         break;
  64.     case FPTR:
  65.         putatm(fptr,"File",vptr);
  66.         break;
  67.     case OBJ:
  68.         putatm(fptr,"Object",vptr);
  69.         break;
  70.     default:
  71.         putatm(fptr,"Foo",vptr);
  72.         break;
  73.     }
  74. }
  75.  
  76. /* xlterpri - terminate the current print line */
  77. xlterpri(fptr)
  78.   struct node *fptr;
  79. {
  80.     xlputc(fptr,'\n');
  81. }
  82.  
  83. /* putstring - output a string */
  84. LOCAL putstring(fptr,str)
  85.   struct node *fptr; char *str;
  86. {
  87.     int ch;
  88.  
  89.     /* output the initial quote */
  90.     xlputc(fptr,'"');
  91.  
  92.     /* output each character in the string */
  93.     while (ch = *str++)
  94.  
  95.     /* check for a control character */
  96.     if (ch < 040 || ch == '\\') {
  97.         xlputc(fptr,'\\');
  98.         switch (ch) {
  99.         case '\033':
  100.             xlputc(fptr,'e');
  101.             break;
  102.         case '\n':
  103.             xlputc(fptr,'n');
  104.             break;
  105.         case '\r':
  106.             xlputc(fptr,'r');
  107.             break;
  108.         case '\t':
  109.             xlputc(fptr,'t');
  110.             break;
  111.         case '\\':
  112.             xlputc(fptr,'\\');
  113.             break;
  114.         default:
  115.             putoct(fptr,ch);
  116.             break;
  117.         }
  118.     }
  119.  
  120.     /* output a normal character */
  121.     else
  122.         xlputc(fptr,ch);
  123.  
  124.     /* output the terminating quote */
  125.     xlputc(fptr,'"');
  126. }
  127.  
  128. /* putatm - output an atom */
  129. LOCAL putatm(fptr,tag,val)
  130.   struct node *fptr; char *tag; int val;
  131. {
  132.     sprintf(buf,"<%s: #%x>",tag,val);
  133.     putstr(fptr,buf);
  134. }
  135.  
  136. /* putdec - output a decimal number */
  137. LOCAL putdec(fptr,n)
  138.   struct node *fptr; int n;
  139. {
  140.     sprintf(buf,"%d",n);
  141.     putstr(fptr,buf);
  142. }
  143.  
  144. /* puthex - output a hexadecimal number */
  145. LOCAL puthex(fptr,n)
  146.   struct node *fptr; unsigned int n;
  147. {
  148.     sprintf(buf,"%x",n);
  149.     putstr(fptr,buf);
  150. }
  151.  
  152. /* putoct - output an octal byte value */
  153. LOCAL putoct(fptr,n)
  154.   struct node *fptr; int n;
  155. {
  156.     sprintf(buf,"%03o",n);
  157.     putstr(fptr,buf);
  158. }
  159.  
  160. /* putstr - output a string */
  161. LOCAL putstr(fptr,str)
  162.   struct node *fptr; char *str;
  163. {
  164.     while (*str)
  165.     xlputc(fptr,*str++);
  166. }
  167.