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