home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / sources / xlprin.c < prev    next >
C/C++ Source or Header  |  1992-02-03  |  18KB  |  658 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 s_printcase,k_downcase,k_const,k_nmacro;
  10. extern LVAL s_ifmt,s_ffmt;
  11. #ifdef RATIOS
  12. extern LVAL s_rfmt;
  13. #endif
  14. extern LVAL s_printlevel, s_printlength;        /* TAA mod */
  15. extern LVAL obarray;
  16. extern FUNDEF funtab[];
  17. #ifdef READTABLECASE
  18. extern LVAL s_rtcase,k_upcase,k_preserve,k_invert;
  19. #endif
  20.  
  21. #ifdef HASHFCNS
  22. extern LVAL a_hashtable;
  23. #endif
  24.  
  25. /* forward declarations */
  26. #ifdef ANSI
  27. void NEAR putsymbol(LVAL fptr, char FAR *str, int flag);
  28. void NEAR putstring(LVAL fptr, LVAL str);
  29. void NEAR putqstring(LVAL fptr, LVAL str);
  30. void NEAR putatm(LVAL fptr, char *tag, LVAL val);
  31. void NEAR putsubr(LVAL fptr, char *tag, LVAL val);
  32. void NEAR putclosure(LVAL fptr, LVAL val);
  33. void NEAR putfixnum(LVAL fptr, FIXTYPE n);
  34. #ifdef RATIOS
  35. void NEAR putratio(LVAL fptr, FIXTYPE n, FIXTYPE d);
  36. #endif
  37. void NEAR putflonum(LVAL fptr, FLOTYPE n);
  38. void NEAR putchcode(LVAL fptr, int ch, int escflag);
  39. void NEAR putoct(LVAL fptr, int n);
  40. #else
  41. FORWARD VOID putsymbol();
  42. FORWARD VOID putstring();
  43. FORWARD VOID putqstring();
  44. FORWARD VOID putatm();
  45. FORWARD VOID putsubr();
  46. FORWARD VOID putclosure();
  47. FORWARD VOID putfixnum();
  48. FORWARD VOID putflonum();
  49. #ifdef RATIOS
  50. FORWARD VOID putratio();
  51. #endif
  52. FORWARD VOID putchcode();
  53. FORWARD VOID putoct();
  54. #endif
  55.  
  56. #ifdef ANSI
  57. void xlprintl(LVAL fptr, LVAL vptr, int flag);
  58. #else
  59. FORWARD VOID xlprintl();
  60. #endif
  61.  
  62. int plevel,plength;
  63.  
  64. /* $putpatch.c$: "MODULE_XLPRIN_C_GLOBALS" */
  65.  
  66. /* xlprint - print an xlisp value */
  67. VOID xlprint(fptr,vptr,flag)
  68.   LVAL fptr,vptr; int flag;
  69. {
  70.     LVAL temp;
  71.     temp = getvalue(s_printlevel);
  72.     if (fixp(temp) && getfixnum(temp) <= 32767 && getfixnum(temp) >= 0) {
  73.         plevel = (int)getfixnum(temp);
  74.     }
  75.     else {
  76.         plevel = 32767;     /* clamp to "reasonable" level */
  77.     }
  78.     temp = getvalue(s_printlength);
  79.     if (fixp(temp) && getfixnum(temp) <= 32767 && getfixnum(temp) >= 0) {
  80.         plength = (int)getfixnum(temp);
  81.     }
  82.     else
  83.         plength = 32767;
  84.  
  85.     xlprintl(fptr,vptr,flag);
  86. }
  87.  
  88. VOID xlprintl(fptr,vptr,flag)
  89.   LVAL fptr,vptr; int flag;
  90. {
  91.     LVAL nptr,next;
  92.     int n,i;
  93.     int llength;
  94.  
  95.     /* check value type */
  96.     switch (ntype(vptr)) {
  97.     case SUBR:
  98.             putsubr(fptr,"Subr",vptr);
  99.             break;
  100.     case FSUBR:
  101.             putsubr(fptr,"FSubr",vptr);
  102.             break;
  103.     case CONS:
  104.             if (plevel-- == 0) {            /* depth limitation */
  105.                 xlputc(fptr,'#');
  106.                 plevel++;
  107.                 break;
  108.             }
  109.             xlputc(fptr,'(');
  110.             llength = plength;
  111.             for (nptr = vptr; nptr != NIL; nptr = next) {
  112.                 if (llength-- == 0) { /* length limitiation */
  113.                     xlputstr(fptr,"... ");
  114.                     break;
  115.                 }
  116.                 xlprintl(fptr,car(nptr),flag);
  117.                 if ((next = cdr(nptr)) != NIL)
  118.                     if (consp(next))
  119.                         xlputc(fptr,' ');
  120.                     else {
  121.                         xlputstr(fptr," . ");
  122.                         xlprintl(fptr,next,flag);
  123.                         break;
  124.                     }
  125.             }
  126.             xlputc(fptr,')');
  127.             plevel++;
  128.             break;
  129.     case SYMBOL:
  130.         /* check for uninterned symbol */
  131.         {
  132.             char FAR *str = getstring(getpname(vptr));
  133.             if (flag) {
  134.                 next = getelement(getvalue(obarray), hash(str, HSIZE));
  135.                 for (; !null(next); next = cdr(next))
  136.                     if (car(next) == vptr) goto doprintsym;
  137.                 xlputstr(fptr,"#:");
  138.                 doprintsym: ;
  139.             }
  140.             putsymbol(fptr, str, flag);
  141.             break;
  142.         }
  143.     case FIXNUM:
  144.             putfixnum(fptr,getfixnum(vptr));
  145.             break;
  146.     case FLONUM:
  147.             putflonum(fptr,getflonum(vptr));
  148.             break;
  149.     case CHAR:
  150.             putchcode(fptr,getchcode(vptr),flag);
  151.             break;
  152.     case STRING:
  153.             if (flag)
  154.                 putqstring(fptr,vptr);
  155.             else
  156.                 putstring(fptr,vptr);
  157.             break;
  158.     case STREAM:
  159. #ifdef FILETABLE
  160.         {
  161.             char *msg;
  162.             FILEP fp = getfile(vptr);
  163.             if (fp == CLOSED)   xlputstr(fptr, "#<Closed-Stream>");
  164.             else {
  165.                 switch (vptr->n_sflags & (S_FORREADING | S_FORWRITING)) {
  166.                     case S_FORREADING: msg = "Input-Stream"; break;
  167.                     case S_FORWRITING: msg = "Output-Stream"; break;
  168.                     default: msg = "IO-Stream"; break;
  169.                 }
  170.                 sprintf(buf,"#<%s %d:\"%s\">", msg, fp+1, filetab[fp].tname);
  171.                 xlputstr(fptr,buf);
  172.             }
  173.         }
  174. #else
  175.         {
  176.             char *msg;
  177.             FILEP fp = getfile(vptr);
  178.             if (fp == CLOSED)   msg = "Closed-Stream";
  179.             else if (fp == STDIN) msg = "Stdin-Stream";
  180.             else if (fp == STDOUT) msg = "Stdout-Stream";
  181.             else if (fp == CONSOLE) msg = "Terminal-Stream";
  182.             else switch (vptr->n_sflags & (S_FORREADING | S_FORWRITING)) {
  183.                 case S_FORREADING: msg = "Input-Stream"; break;
  184.                 case S_FORWRITING: msg = "Output-Stream"; break;
  185.                 default: msg = "IO-Stream"; break;
  186.             }
  187.             putatm(fptr,msg,vptr);
  188.         }
  189. #endif
  190.         break;
  191.     case USTREAM:
  192.             putatm(fptr,"Unnamed-Stream",vptr);
  193.             break;
  194.     case OBJECT:
  195.             /* putobj fakes a (send obj :prin1 file) call */
  196.             putobj(fptr,vptr);
  197.             break;
  198.     case VECTOR:
  199.             if (plevel-- == 0) {            /* depth limitation */
  200.                 xlputc(fptr,'#');
  201.                 plevel++;
  202.                 break;
  203.             }
  204.             xlputc(fptr,'#'); xlputc(fptr,'(');
  205.             llength = plength;
  206.             for (i = 0, n = getsize(vptr); n-- > 0; ) {
  207.                 if (llength-- == 0) { /* length limitiation */
  208.                     xlputstr(fptr,"... ");
  209.                     break;
  210.                 }
  211.                 xlprintl(fptr,getelement(vptr,i++),flag);
  212.                 if (n) xlputc(fptr,' ');
  213.             }
  214.             xlputc(fptr,')');
  215.             plevel++;
  216.             break;
  217.     case STRUCT:
  218. #ifdef HASHFCNS
  219.             if (getelement(vptr,0) == a_hashtable) {
  220.                 putatm(fptr,"Hash-table",vptr);
  221.                 break;
  222.             }
  223. #endif
  224.             xlprstruct(fptr,vptr,flag);
  225.             break;
  226.     case CLOSURE:
  227.             putclosure(fptr,vptr);
  228.             break;
  229. #ifdef RATIOS
  230.     case RATIO:
  231.             putratio(fptr, getnumer(vptr), getdenom(vptr));
  232.             break;
  233. #endif
  234. #ifdef COMPLX
  235.     case COMPLEX:
  236.         xlputstr(fptr, "#C(");
  237.         if (ntype(next = getelement(vptr,0)) == FIXNUM)
  238.             putfixnum(fptr, getfixnum(next));
  239.         else
  240.             putflonum(fptr, getflonum(next));
  241.         xlputc(fptr,' ');
  242.         if (ntype(next = getelement(vptr,1)) == FIXNUM)
  243.             putfixnum(fptr, getfixnum(next));
  244.         else
  245.             putflonum(fptr, getflonum(next));
  246.         xlputc(fptr, ')');
  247.         break;
  248. #endif
  249.     case FREE:
  250.             putatm(fptr,"Free",vptr);
  251.             break;
  252.  
  253.     /* $putpatch.c$: "MODULE_XLPRIN_C_XLPRINT" */
  254.  
  255.     default:
  256.             putatm(fptr,"Unknown",vptr);        /* was 'Foo`   TAA Mod */
  257.             break;
  258.     }
  259. }
  260.  
  261. /* xlterpri - terminate the current print line */
  262. VOID xlterpri(fptr)
  263.   LVAL fptr;
  264. {
  265.     xlputc(fptr,'\n');
  266. }
  267.  
  268. extern int lposition;   /* imported from the *stuff.c file */
  269. /* xlgetcolumn -- find the current file column */
  270.  
  271. int xlgetcolumn(fptr)
  272.   LVAL fptr;
  273. {
  274.     if (fptr == NIL) return 0;
  275.     else if (ntype(fptr) == USTREAM) { /* hard work ahead :-( */
  276.         LVAL ptr = gethead(fptr);
  277.         int count = 0;
  278.  
  279.         while (ptr != NIL) {
  280.             if (getchcode(ptr) == '\n') count = 0 ;
  281.             else count++;
  282.             ptr = cdr(ptr);
  283.         }
  284.         return count;
  285.     }
  286.     else if (getfile(fptr) == CONSOLE)
  287.         return lposition;
  288.     else
  289.         return ((fptr->n_sflags & S_WRITING)? fptr->n_cpos : 0);
  290. }
  291.  
  292.  
  293. /* xlfreshline -- start new line if not at beginning of line */
  294. int xlfreshline(fptr)
  295.   LVAL fptr;
  296. {
  297.     if (xlgetcolumn(fptr) != 0) {
  298.         xlterpri(fptr);
  299.         return TRUE;
  300.     }
  301.     return FALSE;
  302. }
  303.  
  304.  
  305. /* xlputstr - output a string */
  306. VOID xlputstr(fptr,str)
  307.   LVAL fptr; char *str;
  308. {
  309. /* solve reentrancy problems if gc prints messages and
  310.    xlputstr output is directed to a string stream */
  311.     if (ustreamp(fptr)) {
  312.         int oplevel=plevel, oplength=plength;   /* save these variables */
  313.         char nbuf[STRMAX+1];
  314.  
  315.         if (buf == str) {   /* copy to reentrant buffer if necessary */
  316.             str = strcpy(nbuf, buf);
  317.         }
  318.  
  319.         while (*str)        /* print string */
  320.             xlputc(fptr, *str++);
  321.  
  322.         plevel = oplevel;   /* restore level and length */
  323.         plength = oplength;
  324.     }
  325.     else
  326.         while (*str)
  327.             xlputc(fptr,*str++);
  328. }
  329.  
  330. #ifdef READTABLECASE
  331. #define RUP  0      /* values for upcase, downcase, preserve, and invert */
  332. #define RDWN 1
  333. #define RPRE 2
  334. #define RINV 3
  335. #endif
  336.  
  337. /* putsymbol - output a symbol */
  338. LOCAL VOID NEAR putsymbol(fptr, stri, flag)
  339.   LVAL fptr; char FAR *stri; int flag;
  340. {
  341. #ifdef READTABLECASE
  342.     LVAL rtcase = getvalue(s_rtcase);
  343.     int rcase,up,low;
  344.     int mixcase;
  345. #endif
  346.     int downcase;
  347.     LVAL type;
  348.     char *p,c;
  349. #ifdef MEDMEM
  350.     char *str = buf;
  351.  
  352.     STRCPY(buf, stri);
  353. #else
  354. #define str stri
  355. #endif
  356.  
  357. #ifdef READTABLECASE
  358.     /* check value of *readtable-case* */
  359.     if      (rtcase == k_upcase)   rcase = RUP;
  360.     else if (rtcase == k_invert)   rcase = RINV;
  361.     else if (rtcase == k_downcase) rcase = RDWN;
  362.     else if (rtcase == k_preserve) rcase = RPRE;
  363.     else rcase = RUP;                           /* default is upcase */
  364. #endif
  365.  
  366.     /* handle escaping if flag is true */
  367.  
  368.     if (flag) {
  369.         /* check to see if symbol needs escape characters */
  370.         for (p = str; *p; ++p)
  371. #ifdef READTABLECASE
  372.             if    (rcase == RUP && islower(*p)
  373.                 || rcase == RDWN && isupper(*p)
  374.                 ||  ((type = tentry(*p)) != k_const
  375.                     && (!consp(type) || car(type) != k_nmacro)))
  376. #else
  377.             if (islower(*p)
  378.                 ||  ((type = tentry(*p)) != k_const
  379.                     && (!consp(type) || car(type) != k_nmacro)))
  380. #endif
  381.             {
  382.                 xlputc(fptr,'|');
  383.                 while (*str) {
  384.                     if (*str == '\\' || *str == '|')
  385.                         xlputc(fptr,'\\');
  386.                     xlputc(fptr,*str++);
  387.                 }
  388.                 xlputc(fptr,'|');
  389.                 return;
  390.             }
  391.         /* check for the first character being '#'
  392.             or string looking like a number */
  393.         if (*str == '#' || isnumber(str,NULL))
  394.             xlputc(fptr,'\\');
  395.     }
  396.  
  397.     /* get the case translation flag -- default upcase */
  398.     downcase = (getvalue(s_printcase) == k_downcase);
  399.  
  400. #ifdef READTABLECASE
  401.     /* we need to know if there is a mixed case symbol if reading :INVERT */
  402.     if (rcase == RINV)  {
  403.         up=FALSE;
  404.         low=FALSE;
  405.         mixcase = FALSE;
  406.         for (p=str ; *p && !mixcase ; ++p)  {
  407.             if (islower(*p))
  408.                 low = TRUE;
  409.             else if (isupper(*p))
  410.                 up = TRUE;
  411.             mixcase = up&low;
  412.         }
  413.         if (mixcase) rcase = RPRE;  /* preserve if cases mixed */
  414.     }
  415.     low = (rcase == RINV) || (rcase == RUP && downcase);
  416.     up  = (rcase == RINV) || (rcase == RDWN && !downcase);
  417.  
  418. #endif
  419.  
  420.     /* output each character */
  421.     while ((c = *str++) != 0) {
  422.         if (flag && (c == '\\' || c == '|'))
  423.             xlputc(fptr,'\\');
  424. #ifdef READTABLECASE
  425.         if      (isupper(c)) xlputc(fptr, low ? tolower(c) : c);
  426.         else if (islower(c)) xlputc(fptr, up  ? toupper(c) : c);
  427.         else xlputc(fptr,c);
  428. #else
  429.         xlputc(fptr,(downcase && isupper(c) ? tolower(c) : c));
  430. #endif
  431.     }
  432. }
  433. #ifndef MEDMEM
  434. #undef str
  435. #endif
  436.  
  437. /* putstring - output a string */
  438. /* rewritten to  print strings containing nulls TAA mod*/
  439. LOCAL VOID NEAR putstring(fptr,str)
  440.   LVAL fptr,str;
  441. {
  442.     char FAR *p = getstring(str);
  443.     unsigned len = getslength(str);
  444.  
  445.     /* output each character */
  446.     while (len-- > 0) xlputc(fptr,*p++);
  447. }
  448.  
  449. /* putqstring - output a quoted string */
  450. /* rewritten to  print strings containing nulls TAA mod*/
  451. LOCAL VOID NEAR putqstring(fptr,str)
  452.   LVAL fptr,str;
  453. {
  454.     char FAR *p = getstring(str);
  455.     unsigned len = getslength(str);
  456.     int ch;
  457.  
  458.     /* output the initial quote */
  459.     xlputc(fptr,'"');
  460.  
  461.     /* output each character in the string */
  462.     while (len-- > 0) {
  463.         ch = *(unsigned char FAR *)p++;
  464.  
  465.         /* check for a control character */
  466.         if (ch < 040 || ch == '\\' || ch == '"' || ch > 0176) { /* TAA MOD quote quote */
  467.             xlputc(fptr,'\\');
  468.             switch (ch) {
  469.                 case '\011':
  470.                     xlputc(fptr,'t');
  471.                     break;
  472.                 case '\012':
  473.                     xlputc(fptr,'n');
  474.                     break;
  475.                 case '\014':
  476.                     xlputc(fptr,'f');
  477.                     break;
  478.                 case '\015':
  479.                     xlputc(fptr,'r');
  480.                     break;
  481.                 case '\\':
  482.                 case '"':
  483.                     xlputc(fptr,ch);
  484.                     break;
  485.                 default:
  486.                     putoct(fptr,ch);
  487.                     break;
  488.             }
  489.         }
  490.  
  491.                 /* output a normal character */
  492.         else
  493.             xlputc(fptr,ch);
  494.     }
  495.  
  496.  
  497.     /* output the terminating quote */
  498.     xlputc(fptr,'"');
  499. }
  500.  
  501. /* putatm - output an atom */
  502. LOCAL VOID NEAR putatm(fptr,tag,val)
  503.   LVAL fptr; char *tag; LVAL val;
  504. {
  505.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  506.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  507.     xlputc(fptr,'>');
  508. }
  509.  
  510. /* putsubr - output a subr/fsubr */
  511. LOCAL VOID NEAR putsubr(fptr,tag,val)
  512.   LVAL fptr; char *tag; LVAL val;
  513. {
  514. /*    sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name); */
  515.     char *str;      /* TAA mod */
  516.     if ((str = funtab[getoffset(val)].fd_name) != NULL)
  517.         sprintf(buf,"#<%s-%s: #",tag,str);
  518.     else
  519.         sprintf(buf,"#<%s: #",tag);
  520.     xlputstr(fptr,buf);
  521.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  522.     xlputc(fptr,'>');
  523. }
  524.  
  525. /* putclosure - output a closure */
  526. LOCAL VOID NEAR putclosure(fptr,val)
  527.   LVAL fptr,val;
  528. {
  529.     LVAL name;
  530.     if ((name = getname(val)) != NIL)
  531.         sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
  532.     else
  533.         strcpy(buf,"#<Closure: #");
  534.     xlputstr(fptr,buf);
  535.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  536.     xlputc(fptr,'>');
  537. }
  538.  
  539. /* putfixnum - output a fixnum */
  540. LOCAL VOID NEAR putfixnum(fptr,n)
  541.   LVAL fptr; FIXTYPE n;
  542. {
  543.     LVAL val;
  544. #ifdef MEDMEM
  545.     char fmt[STRMAX];
  546.     val = getvalue(s_ifmt);
  547.     STRCPY(fmt, stringp(val) && getslength(val) < STRMAX ?
  548.         getstring(val) : (char FAR *)IFMT);
  549. #else
  550.     char *fmt;
  551.  
  552.     val = getvalue(s_ifmt);
  553.     fmt = (stringp(val) ? getstring(val) : IFMT);
  554. #endif
  555.     sprintf(buf,fmt,n);
  556.     xlputstr(fptr,buf);
  557. }
  558.  
  559. #ifdef RATIOS
  560. LOCAL VOID NEAR putratio(fptr,n,d)
  561.   LVAL fptr; FIXTYPE n,d;
  562. {
  563.     LVAL val;
  564. #ifdef MEDMEM
  565.     char fmt[STRMAX];
  566.  
  567.     val = getvalue(s_rfmt);
  568.     STRCPY(fmt, (stringp(val) && getslength(val) < STRMAX ?
  569.         getstring(val) : (char FAR *)RFMT));
  570. #else
  571.     char *fmt;
  572.  
  573.     val = getvalue(s_rfmt);
  574.     fmt = (stringp(val) ? getstring(val) : RFMT);
  575. #endif
  576.     sprintf(buf,fmt,n,d);
  577.     xlputstr(fptr,buf);
  578. }
  579. #endif
  580.  
  581. /* putflonum - output a flonum */
  582. LOCAL VOID NEAR putflonum(fptr,n)
  583.   LVAL fptr; FLOTYPE n;
  584. {
  585. #ifdef MEDMEM
  586.     char fmt[STRMAX];
  587. #else
  588.     char *fmt;
  589. #endif
  590.     LVAL val;
  591. #ifdef IEEEFP
  592.     union { FLOTYPE fpn; long intn[2]; } k/*ludge*/;
  593.  
  594.     k.fpn = n;
  595.     if ((k.intn[1] & 0x7fffffffL) == 0x7ff00000L && k.intn[0] == 0) {
  596.         xlputstr(fptr,k.intn[1]<0 ? "-INF" : "+INF");
  597.         return;
  598.     }
  599.     if ((k.intn[1]&0x7ff00000L) == 0x7ff00000L &&
  600.         ((k.intn[1]&0xfffffL) != 0 || k.intn[0] != 0)) {
  601.         xlputstr(fptr,"NaN");
  602.         return;
  603.     }
  604. #endif
  605.  
  606. #ifdef MEDMEM
  607.     val = getvalue(s_ffmt);
  608.     STRCPY(fmt, stringp(val) && getslength(val) < STRMAX ?
  609.         getstring(val) : (char FAR *)"%g");
  610. #else
  611.     val = getvalue(s_ffmt);
  612.     fmt = (stringp(val) ? getstring(val) : "%g");
  613. #endif
  614.     sprintf(buf,fmt,n);
  615.     xlputstr(fptr,buf);
  616. }
  617.  
  618. /* putchcode - output a character */
  619. /* modified to print control and meta characters TAA Mod */
  620. LOCAL VOID NEAR putchcode(fptr,ch,escflag)
  621.   LVAL fptr; int ch,escflag;
  622. {
  623.     if (escflag) {
  624.         xlputstr(fptr,"#\\");
  625.         if (ch > 127) {
  626.             ch -= 128;
  627.             xlputstr(fptr,"M-");
  628.         }
  629.         switch (ch) {
  630.             case '\n':
  631.                 xlputstr(fptr,"Newline");
  632.                 break;
  633.             case ' ':
  634.                 xlputstr(fptr,"Space");
  635.                 break;
  636.             case 127:
  637.                 xlputstr(fptr,"Rubout");
  638.                 break;
  639.             default:
  640.                 if (ch < 32) {
  641.                     ch += '@';
  642.                     xlputstr(fptr,"C-");
  643.                 }
  644.                 xlputc(fptr,ch);
  645.                 break;
  646.         }
  647.     }
  648.     else xlputc(fptr,ch);
  649. }
  650.  
  651. /* putoct - output an octal byte value */
  652. LOCAL VOID NEAR putoct(fptr,n)
  653.   LVAL fptr; int n;
  654. {
  655.     sprintf(buf,"%03o",n);
  656.     xlputstr(fptr,buf);
  657. }
  658.