home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispdos / source / xlprin.c < prev    next >
Encoding:
C/C++ Source or Header  |  1985-10-05  |  3.5 KB  |  181 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. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern char buf[];
  14.  
  15. /* xlprint - print an xlisp value */
  16. xlprint(fptr,vptr,flag)
  17.   NODE *fptr,*vptr; int flag;
  18. {
  19.     NODE *nptr,*next;
  20.     int n,i;
  21.  
  22.     /* print nil */
  23.     if (vptr == NIL) {
  24.     xlputstr(fptr,"NIL");
  25.     return;
  26.     }
  27.  
  28.     /* check value type */
  29.     switch (ntype(vptr)) {
  30.     case SUBR:
  31.         putatm(fptr,"Subr",vptr);
  32.         break;
  33.     case FSUBR:
  34.         putatm(fptr,"FSubr",vptr);
  35.         break;
  36.     case LIST:
  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 SYM:
  52.         xlputstr(fptr,getstring(getpname(vptr)));
  53.         break;
  54.     case INT:
  55.         putdec(fptr,getfixnum(vptr));
  56.         break;
  57.     case FLOAT:
  58.         putfloat(fptr,getflonum(vptr));
  59.         break;
  60.     case STR:
  61.         if (flag)
  62.         putstring(fptr,getstring(vptr));
  63.         else
  64.         xlputstr(fptr,getstring(vptr));
  65.         break;
  66.     case FPTR:
  67.         putatm(fptr,"File",vptr);
  68.         break;
  69.     case OBJ:
  70.         putatm(fptr,"Object",vptr);
  71.         break;
  72.     case VECT:
  73.         xlputc(fptr,'#'); xlputc(fptr,'(');
  74.         for (i = 0, n = getsize(vptr); n-- > 0; ) {
  75.         xlprint(fptr,getelement(vptr,i++),flag);
  76.         if (n) xlputc(fptr,' ');
  77.         }
  78.         xlputc(fptr,')');
  79.         break;
  80.     case FREE:
  81.         putatm(fptr,"Free",vptr);
  82.         break;
  83.     default:
  84.         putatm(fptr,"Foo",vptr);
  85.         break;
  86.     }
  87. }
  88.  
  89. /* xlterpri - terminate the current print line */
  90. xlterpri(fptr)
  91.   NODE *fptr;
  92. {
  93.     xlputc(fptr,'\n');
  94. }
  95.  
  96. /* xlputstr - output a string */
  97. xlputstr(fptr,str)
  98.   NODE *fptr; char *str;
  99. {
  100.     while (*str)
  101.     xlputc(fptr,*str++);
  102. }
  103.  
  104. /* putstring - output a string */
  105. LOCAL putstring(fptr,str)
  106.   NODE *fptr; char *str;
  107. {
  108.     int ch;
  109.  
  110.     /* output the initial quote */
  111.     xlputc(fptr,'"');
  112.  
  113.     /* output each character in the string */
  114.     while (ch = *str++)
  115.  
  116.     /* check for a control character */
  117.     if (ch < 040 || ch == '\\') {
  118.         xlputc(fptr,'\\');
  119.         switch (ch) {
  120.         case '\033':
  121.             xlputc(fptr,'e');
  122.             break;
  123.         case '\n':
  124.             xlputc(fptr,'n');
  125.             break;
  126.         case '\r':
  127.             xlputc(fptr,'r');
  128.             break;
  129.         case '\t':
  130.             xlputc(fptr,'t');
  131.             break;
  132.         case '\\':
  133.             xlputc(fptr,'\\');
  134.             break;
  135.         default:
  136.             putoct(fptr,ch);
  137.             break;
  138.         }
  139.     }
  140.  
  141.     /* output a normal character */
  142.     else
  143.         xlputc(fptr,ch);
  144.  
  145.     /* output the terminating quote */
  146.     xlputc(fptr,'"');
  147. }
  148.  
  149. /* putatm - output an atom */
  150. LOCAL putatm(fptr,tag,val)
  151.   NODE *fptr; char *tag; NODE *val;
  152. {
  153.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  154.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  155.     xlputc(fptr,'>');
  156. }
  157.  
  158. /* putdec - output a decimal number */
  159. LOCAL putdec(fptr,n)
  160.   NODE *fptr; FIXNUM n;
  161. {
  162.     sprintf(buf,IFMT,n);
  163.     xlputstr(fptr,buf);
  164. }
  165.  
  166. /* putfloat - output a floating point number */
  167. LOCAL putfloat(fptr,n)
  168.   NODE *fptr; FLONUM n;
  169. {
  170.     sprintf(buf,"%g",n);
  171.     xlputstr(fptr,buf);
  172. }
  173.  
  174. /* putoct - output an octal byte value */
  175. LOCAL putoct(fptr,n)
  176.   NODE *fptr; int n;
  177. {
  178.     sprintf(buf,"%03o",n);
  179.     xlputstr(fptr,buf);
  180. }
  181.