home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / src / XLPRIN.C < prev    next >
C/C++ Source or Header  |  1989-05-09  |  7KB  |  320 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); n-- > 0; ) {
  81.         xlprint(fptr,getelement(vptr,i++),flag);
  82.         if (n) xlputc(fptr,' ');
  83.         }
  84.         xlputc(fptr,')');
  85.         break;
  86.     case CLOSURE:
  87.         putclosure(fptr,vptr);
  88.         break;
  89.     case FREE:
  90.         putatm(fptr,"Free",vptr);
  91.         break;
  92.     default:
  93.         putatm(fptr,"Foo",vptr);
  94.         break;
  95.     }
  96. }
  97.  
  98. /* xlterpri - terminate the current print line */
  99. xlterpri(fptr)
  100.   LVAL fptr;
  101. {
  102.     xlputc(fptr,'\n');
  103. }
  104.  
  105. /* xlputstr - output a string */
  106. xlputstr(fptr,str)
  107.   LVAL fptr; char *str;
  108. {
  109.     while (*str)
  110.     xlputc(fptr,*str++);
  111. }
  112.  
  113. /* putsymbol - output a symbol */
  114. LOCAL putsymbol(fptr,str,escflag)
  115.   LVAL fptr; char *str; int escflag;
  116. {
  117.     int downcase;
  118.     LVAL type;
  119.     char *p;
  120.  
  121.     /* check for printing without escapes */
  122.     if (!escflag) {
  123.     xlputstr(fptr,str);
  124.     return;
  125.     }
  126.  
  127.     /* check to see if symbol needs escape characters */
  128.     if (tentry(*str) == k_const) {
  129.     for (p = str; *p; ++p)
  130.         if (islower(*p)
  131.         ||  ((type = tentry(*p)) != k_const
  132.           && (!consp(type) || car(type) != k_nmacro))) {
  133.         xlputc(fptr,'|');
  134.         while (*str) {
  135.             if (*str == '\\' || *str == '|')
  136.             xlputc(fptr,'\\');
  137.             xlputc(fptr,*str++);
  138.         }
  139.         xlputc(fptr,'|');
  140.         return;
  141.         }
  142.     }
  143.  
  144.     /* get the case translation flag */
  145.     downcase = (getvalue(s_printcase) == k_downcase);
  146.  
  147.     /* check for the first character being '#' */
  148.     if (*str == '#' || *str == '.' || isnumber(str,NULL))
  149.     xlputc(fptr,'\\');
  150.  
  151.     /* output each character */
  152.     while (*str) {
  153.     /* don't escape colon until we add support for packages */
  154.     if (*str == '\\' || *str == '|' /* || *str == ':' */)
  155.         xlputc(fptr,'\\');
  156.     xlputc(fptr,(downcase && isupper(*str) ? tolower(*str++) : *str++));
  157.     }
  158. }
  159.  
  160. /* putstring - output a string */
  161. LOCAL putstring(fptr,str)
  162.   LVAL fptr,str;
  163. {
  164.     unsigned char *p;
  165.     int ch;
  166.  
  167.     /* output each character */
  168.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  169.     xlputc(fptr,ch);
  170. }
  171.  
  172. /* putqstring - output a quoted string */
  173. LOCAL putqstring(fptr,str)
  174.   LVAL fptr,str;
  175. {
  176.     unsigned char *p;
  177.     int ch;
  178.  
  179.     /* get the string pointer */
  180.     p = getstring(str);
  181.  
  182.     /* output the initial quote */
  183.     xlputc(fptr,'"');
  184.  
  185.     /* output each character in the string */
  186.     for (p = getstring(str); (ch = *p) != '\0'; ++p)
  187.  
  188.     /* check for a control character */
  189.     if (ch < 040 || ch == '\\' || ch > 0176) {
  190.         xlputc(fptr,'\\');
  191.         switch (ch) {
  192.         case '\011':
  193.             xlputc(fptr,'t');
  194.             break;
  195.         case '\012':
  196.             xlputc(fptr,'n');
  197.             break;
  198.         case '\014':
  199.             xlputc(fptr,'f');
  200.             break;
  201.         case '\015':
  202.             xlputc(fptr,'r');
  203.             break;
  204.         case '\\':
  205.             xlputc(fptr,'\\');
  206.             break;
  207.         default:
  208.             putoct(fptr,ch);
  209.             break;
  210.         }
  211.     }
  212.  
  213.     /* output a normal character */
  214.     else
  215.         xlputc(fptr,ch);
  216.  
  217.     /* output the terminating quote */
  218.     xlputc(fptr,'"');
  219. }
  220.  
  221. /* putatm - output an atom */
  222. LOCAL putatm(fptr,tag,val)
  223.   LVAL fptr; char *tag; LVAL val;
  224. {
  225.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  226.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  227.     xlputc(fptr,'>');
  228. }
  229.  
  230. /* putsubr - output a subr/fsubr */
  231. LOCAL putsubr(fptr,tag,val)
  232.   LVAL fptr; char *tag; LVAL val;
  233. {
  234.     sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
  235.     xlputstr(fptr,buf);
  236.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  237.     xlputc(fptr,'>');
  238. }
  239.  
  240. /* putclosure - output a closure */
  241. LOCAL putclosure(fptr,val)
  242.   LVAL fptr,val;
  243. {
  244.     LVAL name;
  245.     if (name = getname(val))
  246.     sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
  247.     else
  248.     strcpy(buf,"#<Closure: #");
  249.     xlputstr(fptr,buf);
  250.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  251.     xlputc(fptr,'>');
  252. /*
  253.     xlputstr(fptr,"\nName:   "); xlprint(fptr,getname(val),TRUE);
  254.     xlputstr(fptr,"\nType:   "); xlprint(fptr,gettype(val),TRUE);
  255.     xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
  256.     xlputstr(fptr,"\nArgs:   "); xlprint(fptr,getargs(val),TRUE);
  257.     xlputstr(fptr,"\nOargs:  "); xlprint(fptr,getoargs(val),TRUE);
  258.     xlputstr(fptr,"\nRest:   "); xlprint(fptr,getrest(val),TRUE);
  259.     xlputstr(fptr,"\nKargs:  "); xlprint(fptr,getkargs(val),TRUE);
  260.     xlputstr(fptr,"\nAargs:  "); xlprint(fptr,getaargs(val),TRUE);
  261.     xlputstr(fptr,"\nBody:   "); xlprint(fptr,getbody(val),TRUE);
  262.     xlputstr(fptr,"\nEnv:    "); xlprint(fptr,getenv(val),TRUE);
  263.     xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
  264. */
  265. }
  266.  
  267. /* putfixnum - output a fixnum */
  268. LOCAL putfixnum(fptr,n)
  269.   LVAL fptr; FIXTYPE n;
  270. {
  271.     unsigned char *fmt;
  272.     LVAL val;
  273.     fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
  274.                             : (unsigned char *)IFMT);
  275.     sprintf(buf,fmt,n);
  276.     xlputstr(fptr,buf);
  277. }
  278.  
  279. /* putflonum - output a flonum */
  280. LOCAL putflonum(fptr,n)
  281.   LVAL fptr; FLOTYPE n;
  282. {
  283.     unsigned char *fmt;
  284.     LVAL val;
  285.     fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
  286.                             : (unsigned char *)"%g");
  287.     sprintf(buf,fmt,n);
  288.     xlputstr(fptr,buf);
  289. }
  290.  
  291. /* putchcode - output a character */
  292. LOCAL putchcode(fptr,ch,escflag)
  293.   LVAL fptr; int ch,escflag;
  294. {
  295.     if (escflag) {
  296.     switch (ch) {
  297.     case '\n':
  298.         xlputstr(fptr,"#\\Newline");
  299.         break;
  300.     case ' ':
  301.         xlputstr(fptr,"#\\Space");
  302.         break;
  303.     default:
  304.         sprintf(buf,"#\\%c",ch);
  305.         xlputstr(fptr,buf);
  306.         break;
  307.     }
  308.     }
  309.     else
  310.     xlputc(fptr,ch);
  311. }
  312.  
  313. /* putoct - output an octal byte value */
  314. LOCAL putoct(fptr,n)
  315.   LVAL fptr; int n;
  316. {
  317.     sprintf(buf,"%03o",n);
  318.     xlputstr(fptr,buf);
  319. }
  320.