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