home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlfio.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  29.1 KB  |  1,097 lines
  1. /* xlfio.c - xlisp file i/o */
  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. #include <math.h>
  8.  
  9.  
  10. #ifdef FILETABLE
  11. #include <errno.h>
  12. #endif
  13.  
  14. /* external variables */
  15. extern LVAL k_direction,k_input,k_output;
  16. extern LVAL s_stdin,s_stdout,true;
  17. extern LVAL k_io, k_elementtype;
  18. extern LVAL a_fixnum, a_char;
  19. extern LVAL k_exist, k_nexist, k_error, k_rename, k_newversion;
  20. extern LVAL k_overwrite, k_append, k_supersede, k_rendel, k_probe, k_create;
  21. extern LVAL k_start, k_end;
  22. extern int xlfsize;
  23.  
  24.  
  25. /* forward declarations */
  26. #ifdef ANSI
  27. #ifdef SERVER
  28. LVAL getstroutput(LVAL stream);
  29. #else
  30. LVAL XNEAR getstroutput(LVAL stream);
  31. #endif
  32. LVAL XNEAR printit(int pflag, int tflag);
  33. LVAL XNEAR flatsize(int pflag);
  34. #else
  35. FORWARD LVAL getstroutput();
  36. FORWARD LVAL printit();
  37. FORWARD LVAL flatsize();
  38. #endif
  39.  
  40. /* xread - read an expression */
  41. LVAL xread()
  42. {
  43.     LVAL fptr,eof,val;
  44.  
  45.     /* get file pointer and eof value */
  46.     fptr = (moreargs() ? xlgetfile(FALSE) : getvalue(s_stdin));
  47.     eof = (moreargs() ? xlgetarg() : NIL);
  48.     if (xlargc > 1) xltoomany();    /* toss out now unused arg */
  49.  
  50.     /* read an expression */
  51.     if (!xlread(fptr,&val))
  52.         val = eof;
  53.  
  54.     /* return the expression */
  55.     return (val);
  56. }
  57.  
  58. /* xprint - built-in function 'print' */
  59. LVAL xprint()
  60. {
  61.     return (printit(TRUE,TRUE));
  62. }
  63.  
  64. /* xprin1 - built-in function 'prin1' */
  65. LVAL xprin1()
  66. {
  67.     return (printit(TRUE,FALSE));
  68. }
  69.  
  70. /* xprinc - built-in function princ */
  71. LVAL xprinc()
  72. {
  73.     return (printit(FALSE,FALSE));
  74. }
  75.  
  76. /* xfreshline - start a new line if not at begining of line */
  77. LVAL xfreshline()
  78. {
  79.     LVAL fptr;
  80.  
  81.     /* get file pointer */
  82.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  83.     xllastarg();
  84.  
  85.     /* optionally terminate the print line and return action */
  86.     return (xlfreshline(fptr)? true : NIL);
  87. }
  88.  
  89.  
  90. /* xterpri - terminate the current print line */
  91. LVAL xterpri()
  92. {
  93.     LVAL fptr;
  94.  
  95.     /* get file pointer */
  96.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  97.     xllastarg();
  98.  
  99.     /* terminate the print line and return nil */
  100.     xlterpri(fptr);
  101.     return (NIL);
  102. }
  103.  
  104. /* printit - common print function */
  105. LOCAL LVAL XNEAR printit(pflag,tflag)
  106.   int pflag,tflag;
  107. {
  108.     LVAL fptr,val;
  109.  
  110.     /* get expression to print and file pointer */
  111.     val = xlgetarg();
  112.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  113.     xllastarg();
  114.  
  115.     /* print the value */
  116.     xlprint(fptr,val,pflag);
  117.  
  118.     /* terminate the print line if necessary */
  119.     if (tflag)
  120.         xlterpri(fptr);
  121.  
  122.     /* return the result */
  123.     return (val);
  124. }
  125.  
  126. /* xflatsize - compute the size of a printed representation using prin1 */
  127. LVAL xflatsize()
  128. {
  129.     return (flatsize(TRUE));
  130. }
  131.  
  132. /* xflatc - compute the size of a printed representation using princ */
  133. LVAL xflatc()
  134. {
  135.     return (flatsize(FALSE));
  136. }
  137.  
  138. /* flatsize - compute the size of a printed expression */
  139. LOCAL LVAL XNEAR flatsize(pflag)
  140.   int pflag;
  141. {
  142.     LVAL val;
  143.  
  144.     /* get the expression */
  145.     val = xlgetarg();
  146.     xllastarg();
  147.  
  148.     /* print the value to compute its size */
  149.     xlfsize = 0;
  150.     xlprint(NIL,val,pflag);
  151.  
  152.     /* return the length of the expression */
  153.     return (cvfixnum((FIXTYPE)xlfsize));
  154. }
  155.  
  156.  
  157. enum ACTIONS {A_NIL, A_ERR, A_REN, A_OVER, A_APP, A_SUPER, A_CREATE};
  158.  
  159. /* xopen - open a file */
  160. LVAL xopen()
  161. {
  162. #ifdef MEDMEM
  163.     char name[STRMAX];
  164. #else
  165.     char *name;         /* file name strings */
  166. #endif
  167.     FILEP fp;           /* opened file pointer */
  168.     LVAL fname;         /* file name string LVAL */
  169.     LVAL temp;          /* key arguments */
  170.     int iomode;         /* file mode, as stored in node */
  171. #ifdef ANSI
  172. /* There doesn't seem to be any consistancy here in the handling of
  173.    "CDECL" when dealing with pointers to procedures  TAA */
  174. #ifdef FILETABLE
  175.     FILEP (*opencmd)(const char *, MODETYPE);
  176. #else
  177. #ifdef __TURBOC__
  178.     FILEP CDECL (*opencmd)(const char *, MODETYPE);
  179.                             /* file type, TRUE if binary */
  180. #else
  181.     FILEP (* CDECL opencmd)(const char *, MODETYPE);
  182. #endif
  183. #endif
  184. #else /* not ANSI */
  185.     FILEP (*opencmd)();     /* file type, TRUE if binary */
  186. #endif
  187.     enum ACTIONS exist; /* exist action */
  188.     enum ACTIONS nexist;/* non-exist action */
  189.  
  190.     /* get file name */
  191. #ifdef MEDMEM
  192.     MEMCPY(name, getstring(fname = xlgetfname()), STRMAX);
  193.     name[STRMAX-1] = 0;
  194. #else
  195.     name = getstring(fname = xlgetfname());
  196. #endif
  197.  
  198.     /* get direction */
  199.     if (xlgetkeyarg(k_direction,&temp) && temp != k_input) {
  200.         if (temp == k_output) iomode = S_FORWRITING;
  201.         else if (temp == k_io) iomode = S_FORREADING|S_FORWRITING;
  202.         else if (temp == k_probe) iomode = 0;
  203.         else goto argerror;
  204.     }
  205.     else iomode = S_FORREADING;
  206.  
  207.     /* get type */
  208.  
  209.     if (xlgetkeyarg(k_elementtype,&temp) && temp != a_char ) {
  210.         if (temp == a_fixnum ) {
  211.             if (iomode) iomode |= S_BINARY; /* mark as binary file type */
  212. #if defined(MSC) & !defined(FILETABLE)
  213.             opencmd = (FILEP (* CDECL)(const char *, MODETYPE)) OSBOPEN;
  214. #else
  215.             opencmd = OSBOPEN;
  216. #endif
  217.         }
  218.         else goto argerror;
  219.     }
  220.     else
  221. #if defined(MSC) & !defined(FILETABLE)
  222.         opencmd = (FILEP (* CDECL)(const char *, MODETYPE)) OSAOPEN;
  223. #else
  224.         opencmd = OSAOPEN;
  225. #endif
  226.  
  227.     /* get exists action */
  228.  
  229.     if (xlgetkeyarg(k_exist, &temp) &&
  230.         (iomode & S_FORWRITING) &&  /* ignore value if :input or :probe */
  231.         temp != k_rename && temp != k_newversion) {
  232.         if (null(temp)) exist = A_NIL;
  233.         else if (temp == k_error) exist = A_ERR;
  234.         else if (temp == k_overwrite) exist = A_OVER;
  235.         else if (temp == k_append) exist = A_APP;
  236.         else if (temp == k_supersede || temp == k_rendel)
  237.             exist = A_SUPER;
  238.         else goto argerror;
  239.     }
  240.     else exist = A_REN;
  241.  
  242.     /* get non-exist action */
  243.  
  244.     if (xlgetkeyarg(k_nexist, &temp)) {
  245.         if (null(temp)) nexist = A_NIL;
  246.         else if (temp == k_error) nexist = A_ERR;
  247.         else if (temp == k_create) nexist = A_CREATE;
  248.         else goto argerror;
  249.     }
  250.     else {  /* handle confusing mess of defaults */
  251.         if (iomode == S_FORREADING || exist == A_OVER || exist == A_APP)
  252.             nexist = A_ERR;
  253.         else if (iomode & S_FORWRITING) nexist = A_CREATE;
  254.         else nexist = A_NIL;
  255.     }
  256.  
  257.     xllastarg();
  258.  
  259.     /* attempt to open the file */
  260.  
  261.     if ((fp = (*opencmd)(name, (iomode & S_FORWRITING) ? OPEN_UPDATE : OPEN_RO))!=CLOSED) {
  262.         /* success! */
  263.         if (iomode & S_FORWRITING) switch (exist) { /* do exist action */
  264.             case A_ERR: /* give error */
  265.                 OSCLOSE(fp);
  266.                 xlerror("file exists", fname);
  267.                 break;
  268.             case A_REN: /* create new version */
  269.                 OSCLOSE(fp);
  270.                 fp = CLOSED;
  271.                 if (!renamebackup(name))
  272.                     xlerror("couldn't create backup file", fname);
  273.                 break;
  274.             case A_APP: /* position to end of file */
  275.                 OSSEEKEND(fp);
  276.                 break;
  277.             case A_SUPER:   /* supersede file */
  278.                 OSCLOSE(fp);
  279.                 fp = CLOSED;
  280.                 break;
  281.             case A_NIL:     /* return NIL */
  282.                 OSCLOSE(fp);
  283.                 return NIL;
  284.             /*case A_OVER:*/    /* overwrite -- does nothing special */
  285.             default: ;
  286.         }
  287.     }
  288.     else {  /* file does not exist */
  289.         switch (nexist) {
  290.             case A_ERR: /* give error */
  291.                 xlerror("file does not exist", fname);
  292.                 break;
  293.             case A_NIL:     /* return NIL */
  294.                 return NIL;
  295.             /*case A_CREATE:*/  /* create a new file */
  296.             default: ;
  297.         }
  298.     }
  299.  
  300.     /* we now create the file if it is not already open */
  301.     if (fp == CLOSED)
  302.         if ((fp = (*opencmd)(name, (iomode&S_FORREADING)? CREATE_UPDATE: CREATE_WR)) == CLOSED)
  303.             xlerror("couldn't create file", fname);
  304.  
  305.     /* take concluding actions */
  306.     if (iomode == 0) { /* probe */
  307.         OSCLOSE(fp);
  308.         fp = CLOSED;
  309.     }
  310.  
  311.     return cvfile(fp,iomode);
  312.  
  313.     argerror: xlerror("invalid argument", temp);
  314.     return NIL;
  315. }
  316.  
  317.  
  318. /* xfileposition - get position of file stream */
  319. LVAL xfileposition()
  320. {
  321.     long i,j,fsize;
  322.     int t;
  323.     LVAL pos, fptr;
  324.     FILEP fp;
  325.     /* get file pointer */
  326.     fp = getfile(fptr = xlgastream());
  327.  
  328.     /* make sure the file exists */
  329.     if (fp == CLOSED)
  330.         xlfail("file not open");
  331.  
  332.     /* get current position, adjusting for posible "unget" */
  333.     j = OSTELL(fp) + (getsavech(fptr) ? -1L : 0L);
  334.  
  335.     if (moreargs()) { /* must be set position */
  336.         pos = xlgetarg();
  337.         xllastarg();
  338.         if (pos == k_end) t=OSSEEKEND(fp);
  339.         else if (pos == k_start) t=OSSEEK(fp,0L);
  340.         else if (fixp(pos)) {   /* check for in range, then position */
  341.             /* STDIO allows positioning beyond end of file, so we must check
  342.                 the file size (boo his!) */
  343.             i = getfixnum(pos);
  344.             t = OSSEEKEND(fp);
  345.             fsize = OSTELL(fp);
  346.             if (t == 0 && fp != CONSOLE && (i < 0 || i > fsize)) {
  347.                 OSSEEK(fp,j);
  348.                 xlerror("position outside of file", pos);
  349.             }
  350.             t = OSSEEK(fp, i);
  351.         }
  352.         else xlbadtype(pos);
  353.  
  354.         setsavech(fptr,'\0');   /* toss unget character, if any */
  355.         fptr->n_sflags &= ~(S_READING|S_WRITING);
  356.                                 /* neither reading or writing currently */
  357.         /* t is non-zero if couldn't do seek */
  358.         return (t != 0 || fp == CONSOLE ? NIL : true);
  359.     }
  360.  
  361.     return ((j == -1L || fp == CONSOLE) ? NIL : cvfixnum(j));
  362. }
  363.  
  364. /* xfilelength - returns length of file */
  365. LVAL xfilelength()
  366. {
  367.     FILEP fp;
  368.     long i,j;
  369.  
  370.     /* get file pointer */
  371.     fp = getfile(xlgastream());
  372.     xllastarg();
  373.  
  374.     /* make sure the file exists */
  375.     if (fp == CLOSED)
  376.         xlfail("file not open");
  377.  
  378.     /* not all stdio packages will catch the following gaffe */
  379.     if (fp == CONSOLE) return NIL;
  380.  
  381.     if ((i=OSTELL(fp)) == -1L ||
  382.         OSSEEKEND(fp) ||
  383.         (j = OSTELL(fp)) == -1L ||
  384.         OSSEEK(fp,i)) {
  385.         return NIL;
  386.     }
  387.  
  388.     return cvfixnum(j);
  389. }
  390.  
  391.  
  392. #ifdef FILETABLE
  393. LVAL xtruename()
  394. {
  395.     LVAL f = xlgetfname();
  396.     char namebuf[FNAMEMAX+1];
  397.  
  398.     xllastarg();
  399.  
  400.  
  401.     STRCPY(buf, getstring(f));
  402.  
  403.     if (!truename(buf, namebuf)) xlerror("strange file name", f);
  404.  
  405.     return cvstring(namebuf);
  406. }
  407.  
  408. LVAL xdeletefile()
  409. {
  410.     LVAL arg;
  411.     FILEP fp;
  412.  
  413.     /* get the argument */
  414.  
  415.     arg = xlgetarg();
  416.     xllastarg();
  417.  
  418.     if (streamp(arg) && getfile(arg) > CONSOLE) {
  419.         /* close file first */
  420.         fp = getfile(arg);
  421.         STRCPY(buf, filetab[fp].tname);
  422.         OSCLOSE(fp);
  423.         setsavech(arg, '\0');
  424.         setfile(arg,CLOSED);
  425.     }
  426.     else {
  427.         if (symbolp(arg)) arg = getpname(arg);
  428.         else if (!stringp(arg)) xlbadtype(arg);
  429.  
  430.         if (getslength(arg) >= FNAMEMAX)
  431.             xlerror("file name too long", arg);
  432.  
  433.         STRCPY(buf,getstring(arg));
  434.     }
  435.     if (remove(buf) != 0 && errno == EACCES)
  436.         xlerror("cannot delete file", arg);
  437.  
  438.     return true;
  439. }
  440.  
  441. #endif
  442.  
  443. /* xclose - close a file */
  444. LVAL xclose()
  445. {
  446.     LVAL fptr;
  447.     FILEP fp;   /* TAA MOD to allow closing closed files,
  448.                     prohibit closing the console, return the correct
  449.                     values (true on success), and close string streams */
  450.  
  451.  
  452.     /* get file pointer */
  453.     fptr = xlgetarg();
  454.     xllastarg();
  455.  
  456.     /* handle string stream case by converting to a closed file! */
  457.     if (ustreamp(fptr)) {
  458.         fptr->n_type = STREAM;
  459.         setfile(fptr, CLOSED);
  460.         setsavech(fptr, '\0');
  461.         return (true);
  462.     }
  463.  
  464.     /* give error of not file stream */
  465.     if (!streamp(fptr)) xlbadtype(fptr);
  466.  
  467.  
  468.     /* make sure the file exists */
  469.  
  470.     if ((fp = getfile(fptr)) == CLOSED || fp == CONSOLE)
  471.         return (NIL);
  472.  
  473.     /* close the file */
  474.     OSCLOSE(fp);
  475.     setsavech(fptr, '\0');
  476.     setfile(fptr,CLOSED);
  477.  
  478.     /* return true */
  479.     return (true);
  480. }
  481.  
  482. /* xrdchar - read a character from a file */
  483. LVAL xrdchar()
  484. {
  485.     LVAL fptr;
  486.     int ch;
  487.  
  488.     /* get file pointer */
  489.     fptr = (moreargs() ? xlgetfile(FALSE) : getvalue(s_stdin));
  490.     xllastarg();
  491.  
  492.     /* get character and check for eof */
  493.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
  494. }
  495.  
  496. /* xrdbyte - read a byte from a file */
  497. LVAL xrdbyte()
  498. {
  499.     LVAL fptr;
  500.     int ch;
  501.  
  502.     /* get file pointer */
  503.     fptr = (moreargs() ? xlgetfile(FALSE) : getvalue(s_stdin));
  504.     xllastarg();
  505.  
  506.     /* get character and check for eof */
  507.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
  508. }
  509.  
  510. /* xpkchar - peek at a character from a file */
  511. LVAL xpkchar()
  512. {
  513.     LVAL flag,fptr;
  514.     int ch;
  515.  
  516.     /* peek flag and get file pointer */
  517.     flag = (moreargs() ? xlgetarg() : NIL);
  518.     fptr = (moreargs() ? xlgetfile(FALSE) : getvalue(s_stdin));
  519.     xllastarg();
  520.  
  521.     /* skip leading white space and get a character */
  522.     if (!null(flag))
  523.         while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  524.             xlgetc(fptr);
  525.     else
  526.         ch = xlpeek(fptr);
  527.  
  528.     /* return the character */
  529.     return (ch == EOF ? NIL : cvchar(ch));
  530. }
  531.  
  532. /* xwrchar - write a character to a file */
  533. LVAL xwrchar()
  534. {
  535.     LVAL fptr,chr;
  536.  
  537.     /* get the character and file pointer */
  538.     chr = xlgachar();
  539.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  540.     xllastarg();
  541.  
  542.     /* put character to the file */
  543.     xlputc(fptr,getchcode(chr));
  544.  
  545.     /* return the character */
  546.     return (chr);
  547. }
  548.  
  549. /* xwrbyte - write a byte to a file */
  550. LVAL xwrbyte()
  551. {
  552.     LVAL fptr,chr;
  553.  
  554.     /* get the byte and file pointer */
  555.     chr = xlgafixnum();
  556.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  557.     xllastarg();
  558.  
  559.     /* put byte to the file */
  560.     xlputc(fptr,(int)getfixnum(chr));
  561.  
  562.     /* return the character */
  563.     return (chr);
  564. }
  565.  
  566. /* xreadline - read a line from a file */
  567. LVAL xreadline()
  568. {
  569.     char *p, XFAR *sptr;
  570.     LVAL fptr,str,newstr;
  571.     int len,blen,ch;
  572.  
  573.     /* protect some pointers */
  574.     xlsave1(str);
  575.  
  576.     /* get file pointer */
  577.     fptr = (moreargs() ? xlgetfile(FALSE) : getvalue(s_stdin));
  578.     xllastarg();
  579.  
  580.     /* get character and check for eof */
  581.     len = blen = 0; p = buf;
  582.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  583.  
  584.         /* check for buffer overflow TAA MOD to use memcpy instead of strcat*/
  585.         if (blen >= STRMAX) {
  586.             newstr = newstring(len + STRMAX);
  587.             sptr = getstring(newstr);
  588.             if (str != NIL) MEMCPY(sptr, getstring(str), len);
  589.             MEMCPY(sptr+len, buf, blen);
  590.             p = buf; blen = 0;
  591.             len += STRMAX;
  592.             str = newstr;
  593.         }
  594.  
  595.         /* store the character */
  596.         *p++ = ch; ++blen;
  597.     }
  598.  
  599.     /* check for end of file */
  600.     if (len == 0 && p == buf && ch == EOF) {
  601.         xlpop();
  602.         return (NIL);
  603.     }
  604.  
  605.     /* append the last substring */
  606.     /* conditional removed because code always executes! */
  607.     newstr = newstring(len + blen);
  608.     sptr = getstring(newstr);
  609.     if (str != NIL) MEMCPY(sptr, getstring(str), len);
  610.     MEMCPY(sptr+len, buf, blen);
  611.     sptr[len+blen] = '\0';
  612.     str = newstr;
  613.  
  614.     /* restore the stack */
  615.     xlpop();
  616.  
  617.     /* return the string */
  618.     return (str);
  619. }
  620.  
  621.  
  622. /* xmkstrinput - make a string input stream */
  623. /* TAA MOD - reworked for unsigned lengths */
  624.  
  625. LVAL xmkstrinput()
  626. {
  627.     unsigned start,end,len,i;
  628.     FIXTYPE temp;
  629.     char XFAR *str;
  630.     LVAL string,val;
  631.  
  632.     /* protect the return value */
  633.     xlsave1(val);
  634.  
  635.     /* get the string and length */
  636.     string = xlgastring();
  637.     str = getstring(string);
  638.     len = getslength(string);
  639.  
  640.     /* get the starting offset */
  641.     if (moreargs()) {
  642.         val = xlgafixnum();
  643.         temp = getfixnum(val);
  644.         if (temp < 0 || temp > len)
  645.             xlerror("string index out of bounds",val);
  646.         start = (unsigned) temp;
  647.     }
  648.     else start = 0;
  649.  
  650.     /* get the ending offset */
  651.     if (moreargs()) {       /* TAA mod to allow NIL for end offset */
  652.         val = nextarg();
  653.         if (null(val)) end = len;
  654.         else if (fixp(val)) {
  655.             temp = getfixnum(val);
  656.             if (temp < start || temp > len)
  657.                 xlerror("string index out of bounds",val);
  658.             end = (unsigned) temp;
  659.         }
  660.         else xlbadtype(val);
  661.  
  662.         xllastarg();
  663.     }
  664.     else end = len;
  665.  
  666.     /* make the stream */
  667.     val = newustream();
  668.  
  669.     /* copy the substring into the stream */
  670.     for (i = start; i < end; ++i)
  671.         xlputc(val,str[i]);
  672.  
  673.     /* restore the stack */
  674.     xlpop();
  675.  
  676.     /* return the new stream */
  677.     return (val);
  678. }
  679.  
  680. /* xmkstroutput - make a string output stream */
  681. LVAL xmkstroutput()
  682. {
  683.     return (newustream());
  684. }
  685.  
  686. /* xgetstroutput - get output stream string */
  687. LVAL xgetstroutput()
  688. {
  689.     LVAL stream;
  690.     stream = xlgaustream();
  691.     xllastarg();
  692.     return (getstroutput(stream));
  693. }
  694.  
  695. /* xgetlstoutput - get output stream list */
  696. LVAL xgetlstoutput()
  697. {
  698.     LVAL stream,val;
  699.  
  700.     /* get the stream */
  701.     stream = xlgaustream();
  702.     xllastarg();
  703.  
  704.     /* get the output character list */
  705.     val = gethead(stream);
  706.  
  707.     /* empty the character list */
  708.     sethead(stream,NIL);
  709.     settail(stream,NIL);
  710.  
  711.     /* return the list */
  712.     return (val);
  713. }
  714.  
  715.  
  716. #define FMTMAX 256
  717. #ifdef ANSI
  718. static void toomanyopt(LVAL fmt)
  719. #else
  720. static VOID toomanyopt(fmt)
  721. LVAL fmt;
  722. #endif
  723. {
  724.     xlerror("too many prefix parameters in format",fmt);
  725. }
  726.  
  727. /* decode prefix parameters and modifiers for a format directive */
  728. /* TAA MOD Entirely rewritten -- return value -1 for unassigned since
  729.    negative numbers are inappropriate for all arguments we are concerned
  730.    with. Also clips args to reasonable values, allows both : and @ modifiers
  731.    at once. */
  732. #ifdef ANSI
  733. static char XFAR * XNEAR decode_pp(char XFAR *fmt, FIXTYPE *pp, int maxnpp,
  734.                        int *npp, int *colon, int *atsign, LVAL lfmt)
  735. #else
  736. LOCAL char *decode_pp( fmt, pp, maxnpp, npp, colon, atsign, lfmt)
  737. char    *fmt;
  738. FIXTYPE pp[];           /* prefix parameters */
  739. int     maxnpp;         /* maximum number of them */
  740. int     *npp;           /* actual number of them */
  741. int     *colon;         /* colon modifier given? */
  742. int     *atsign;        /* atsign modifier given? */
  743. LVAL    lfmt;           /* format string in case of failure */
  744. #endif
  745. {
  746.     int i;
  747.     int gotone = 0;
  748.     FIXTYPE accum;
  749.  
  750.     for (i = 0; i < maxnpp; i++) pp[i] = -1;    /* initially all undefined */
  751.     *npp = 0;
  752.     *colon = 0;
  753.     *atsign = 0;
  754.     do {
  755.         if (*fmt == '\'') { /* character code */
  756.             pp[*npp] = *(++fmt);
  757.             gotone = 1;
  758.             fmt++;
  759.         }
  760.         else if (*fmt == 'v' || *fmt == 'V') { /* lisp arg is value */
  761.             accum = getfixnum(xlgafixnum());
  762.             if (accum < 0) accum = 0;   /* clip at reasonable values */
  763.             else if (accum>FMTMAX) accum = FMTMAX;
  764.             pp[*npp] = accum;
  765.             gotone = 1;
  766.             fmt++;
  767.         }
  768.         else if (isdigit(*fmt)) { /* integer literal */
  769.             accum = 0;
  770.             do {
  771.                 accum = accum*10 + (int)(*fmt++ - '0');
  772.                 if (accum > FMTMAX)
  773.                     accum = FMTMAX; /* Clip at reasonable value */
  774.             } while (isdigit(*fmt));
  775.             gotone = 1;
  776.             pp[*npp] = accum;
  777.         }
  778.         else if (*fmt == ',') {     /* empty field */
  779.             gotone = 1;
  780.         }
  781.         else  break;                /* nothing to process */
  782.  
  783.         if (*fmt != ',') break;         /* no comma -- done */
  784.         *npp += 1;                  /* got an argument */
  785.         fmt++;                          /* toss comma */
  786.         if( *npp >= maxnpp ) toomanyopt(lfmt);
  787.     } while (TRUE);
  788.     *npp += gotone;
  789.  
  790.     do {    /* pick up any colon or atsign modifier */
  791.         if (*fmt == ':') *colon = 1;
  792.         else if (*fmt == '@') *atsign = 1;
  793.         else break;
  794.         fmt++;
  795.     } while (TRUE);
  796.     return fmt;
  797. }
  798.  
  799. #define mincol  pp[0]
  800. #define colinc  pp[1]
  801. #define minpad  pp[2]
  802. #define padchar pp[3]
  803.  
  804.  
  805. /* opt_print - print a value using prefix parameter options */
  806. #ifdef ANSI
  807. static VOID XNEAR opt_print(LVAL stream, LVAL val, int pflag, FIXTYPE *pp,
  808.                     int colon, int atsign)
  809. #else
  810. LOCAL VOID opt_print(stream,val,pflag,pp,colon,atsign)
  811. LVAL    stream;
  812. LVAL    val;
  813. int     pflag;          /* quoting or not */
  814. FIXTYPE pp[];           /* prefix parameters */
  815. int     colon;          /* colon modifier given? */
  816. int     atsign;         /* at-sign modifier given? */
  817. #endif
  818. {
  819.     int flatsize;
  820.     int i;
  821.  
  822.     if (mincol < 0) mincol = 0; /* handle default values */
  823.     if (colinc < 1) colinc = 1;    /* also arg of 0 for colinc */
  824.     if (minpad < 0) minpad = 0;
  825.     if (padchar < 0) padchar = ' ';
  826.  
  827.     if( mincol < minpad )
  828.             mincol = minpad;
  829.  
  830.     if( mincol > 0 && atsign ) {        /* padding may be required on left */
  831.         if (colon && null(val))         /* flat size is 2 */
  832.             flatsize = 2;
  833.         else {
  834.             xlfsize = 0;
  835.             xlprint(NIL,val,pflag);     /* print to get the flat size */
  836.             flatsize = xlfsize;
  837.         }
  838.         for( i = 0; i < minpad; flatsize++, i++ )
  839.             xlputc(stream,(int)padchar);
  840.         while( flatsize < mincol ) {
  841.             for( i = 0; i < colinc; i++ )
  842.                 xlputc(stream,(int)padchar);
  843.             flatsize += (int)colinc;
  844.         }
  845.     }
  846.  
  847.     /* print the value */
  848.     if( colon && null(val)) {
  849.         xlputstr(stream,"()");
  850.         flatsize = 2;
  851.     }
  852.     else {
  853.         xlfsize = 0;
  854.         xlprint(stream,val,pflag);
  855.         flatsize = xlfsize;
  856.     }
  857.  
  858.     if( mincol > 0 && !atsign ) {       /* padding required on right */
  859.         for( i = 0; i < minpad; flatsize++, i++ )
  860.             xlputc(stream,(int)padchar);
  861.         while( flatsize < mincol ) {
  862.             for( i = 0; i < colinc; i++ )
  863.                 xlputc(stream,(int)padchar);
  864.             flatsize += (int)colinc;
  865.         }
  866.     }
  867. }
  868.  
  869. #define round pp[1]
  870. #ifdef ANSI
  871. static VOID XNEAR num_print(LVAL stream,LVAL val,int pflag,FIXTYPE *pp,int atsign)
  872. #else
  873. LOCAL VOID num_print(stream,val,pflag,pp,atsign)
  874. LVAL    stream;
  875. LVAL    val;
  876. int     pflag;          /* quoting or not */
  877. FIXTYPE pp[];           /* prefix parameters */
  878. int     atsign;         /* at-sign modifier given? */
  879. #endif
  880. {
  881.     char cmd[50];
  882.     int fillchar, i;
  883.  
  884.     fillchar = (int)pp[(pflag=='D'? 1 : 2)];
  885.  
  886.     if (fillchar < 0) fillchar = ' ';
  887.  
  888.     if (pflag == 'D' && fixp(val)) { /* ~d and fixnum */
  889.         sprintf(buf, (atsign?"%+ld":"%ld"), (long) getfixnum(val));
  890.     }
  891.     else if (pflag == 'D' || !numberp(val)) {   /* not a number */
  892.         padchar = colinc = minpad = -1; /* zap arg if provided */
  893.         opt_print(stream,val,FALSE,pp,0,0);
  894.         return;
  895.     }
  896.     else {  /* one of the floating point formats, and a number */
  897. #ifdef RATIOS
  898.         FLOTYPE num;
  899.         if (fixp(val)) num = (FLOTYPE)getfixnum(val);
  900.         else if (ratiop(val)) num = getnumer(val) / (FLOTYPE) getdenom(val);
  901.         else num = getflonum(val);
  902. #else
  903.         FLOTYPE num = fixp(val) ? (FLOTYPE)getfixnum(val) : getflonum(val);
  904. #endif
  905.         if (pflag == 'F' && fabs(num) > 1e100)
  906.             pflag = 'E';    /* don't generate extra big number */
  907.         strcpy(cmd,"%");
  908.         if (atsign) strcat(cmd,"+");
  909.         if (round >= 0) {
  910.             sprintf(buf, ".%d", (int) round);
  911.             strcat(cmd, buf);
  912.         }
  913.         buf[0] = tolower(pflag);
  914.         buf[1] = '\0';
  915.         strcat(cmd,buf);
  916.         sprintf(buf, cmd, (double)num);
  917.     }
  918.     if (mincol > 0) {   /* need to fill */
  919.         for (i = (int)mincol-strlen(buf); i-- > 0;)
  920.             xlputc(stream,fillchar);
  921.     }
  922.     xlputstr(stream,buf);
  923. }
  924.  
  925. #undef colinc
  926. /* tabulate */
  927. #ifdef ANSI
  928. static void XNEAR tab_print(LVAL stream, FIXTYPE *pp, int atsign)
  929. #else
  930. LOCAL VOID tab_print(stream, pp, atsign)
  931. LVAL stream;
  932. FIXTYPE pp[];
  933. int atsign;
  934. #endif
  935. {
  936.     int pos = xlgetcolumn(stream);  /* where are we now??? */
  937.     int count;                      /* number of spaces to insert */
  938.     int column = (int)pp[0];        /* desired column */
  939.     int colinc = (int)pp[1];        /* desired column increment */
  940.  
  941.     if (column < 0) column = 1; /* handle defaults */
  942.     if (colinc < 0) colinc = 1;
  943.  
  944.     if (atsign) { /* relative */
  945.         if (colinc == 0) colinc = 1;
  946.         count = column + (colinc - (pos + column) % colinc) % colinc;
  947.     }
  948.     else { /* absolute */
  949.         if (pos >= column) {
  950.             if (colinc > 0) {
  951.                 int k = (pos+ (colinc-1) - column)/colinc;
  952.                 count = column-pos + k*colinc;
  953.                 if (count==0) count = colinc;
  954.             }
  955.             else count = 0;
  956.         }
  957.         else count = column - pos;
  958.     }
  959.     while (count-- > 0)
  960.         xlputc(stream, ' ');
  961. }
  962.  
  963. #define MAXNPP  4
  964.  
  965.  
  966. /* xformat - formatted output function */
  967. LVAL xformat()
  968. {
  969.     char XFAR *fmt;
  970.     LVAL stream,val;
  971.     int ch;
  972.     LVAL lfmt;
  973.     int npp;            /* number of prefix parameters */
  974.     FIXTYPE pp[MAXNPP];     /* list of prefix parameters */
  975.     int colon, atsign;  /* : and @ modifiers given? */
  976.  
  977.     xlsave1(val);                       /* TAA fix */
  978.  
  979.     /* get the stream and format string */
  980.     stream = xlgetarg();
  981.     if (null(stream)) {
  982.         val = stream = newustream();
  983.     }
  984.     else {
  985.         if (stream == true)
  986.             stream = getvalue(s_stdout);
  987.                                         /* fix from xlispbug.417 */
  988.         else if (streamp(stream)) {     /* copied from xlgetfile() */
  989.                 if (getfile(stream) == CLOSED)
  990.                         xlfail("file not open");
  991.         }
  992.         else if (!ustreamp(stream))
  993.                 xlbadtype(stream);
  994.         val = NIL;
  995.     }
  996.     fmt = getstring(lfmt=xlgastring());
  997.  
  998.     /* process the format string */
  999.     while ((ch = *fmt++) != 0)
  1000.         if (ch == '~') {
  1001.             fmt = decode_pp( fmt, pp, MAXNPP, &npp, &colon, &atsign, lfmt);
  1002.             ch = *fmt++;
  1003.             if (islower(ch)) ch = toupper(ch);
  1004.             switch (ch) {
  1005.             case '\0':
  1006.                 xlerror("expecting a format directive",cvstring(fmt-1));
  1007.             case 'A':
  1008.                 opt_print(stream,xlgetarg(),FALSE,pp,colon,atsign);
  1009.                 break;
  1010.             case 'S':
  1011.                 opt_print(stream,xlgetarg(),TRUE,pp,colon,atsign);
  1012.                 break;
  1013.             case 'D':
  1014.                 if (npp > 2) toomanyopt(lfmt);
  1015.             case 'E': case 'F': case 'G':
  1016.                 if (npp > 3) toomanyopt(lfmt);
  1017.                 num_print(stream,xlgetarg(),ch,pp,atsign);
  1018.                 break;
  1019.             case '&':
  1020.                 if ( pp[0] < 0 ) pp[0] = 1;
  1021.                 if ((pp[0])-- > 0)
  1022.                     xlfreshline(stream);
  1023.                 while( (pp[0])-- > 0 )
  1024.                     xlterpri(stream);
  1025.                 break;
  1026.             case 'T':
  1027.                 tab_print(stream,pp,atsign);
  1028.                 break;
  1029.             case '%':
  1030.                 if( pp[0] < 0 ) pp[0] = 1;
  1031.                 while( (pp[0])-- > 0 )
  1032.                     xlterpri(stream);
  1033.                 break;
  1034.             case '~':
  1035.                 if( pp[0] <= 0 ) pp[0] = 1;
  1036.                 while( (pp[0])-- > 0 )
  1037.                     xlputc(stream,'~');
  1038.                 break;
  1039.             case '\n':
  1040.                 if( colon )
  1041.                     break;
  1042.                 if( atsign )
  1043.                      xlterpri(stream);
  1044.                 while (*fmt && *fmt != '\n' && isspace(*fmt))
  1045.                     ++fmt;
  1046.                 break;
  1047.             default:
  1048.                 xlerror("unknown format directive",cvstring(fmt-1));
  1049.             }
  1050.         }
  1051.         else
  1052.             xlputc(stream,ch);
  1053.  
  1054.     /* get string if output to string */
  1055.     if (!null(val)) val = getstroutput(val);
  1056.  
  1057.     /* unprotect */
  1058.     xlpop();
  1059.  
  1060.     /* return the value */
  1061.     return val;
  1062. }
  1063.  
  1064.  
  1065. /* getstroutput - get the output stream string (internal) */
  1066. #ifdef SERVER
  1067. LVAL getstroutput(stream)
  1068.   LVAL stream;
  1069. #else
  1070. LOCAL LVAL XNEAR getstroutput(stream)
  1071.   LVAL stream;
  1072. #endif
  1073. {
  1074.     char XFAR *str;
  1075.     LVAL next,val;
  1076.     unsigned len;           /* TAA MOD */
  1077.     int ch;
  1078.  
  1079.     /* compute the length of the stream */
  1080.     for (len = 0, next = gethead(stream); !null(next); next = cdr(next)) {
  1081.         if (++len > MAXSLEN) xltoolong();   /* TAA MOD addition for overflow detect */
  1082.     }
  1083.  
  1084.     /* create a new string */
  1085.     val = newstring(len);
  1086.  
  1087.     /* copy the characters into the new string */
  1088.     str = getstring(val);
  1089.     while ((ch = xlgetc(stream)) != EOF)
  1090.         *str++ = ch;
  1091.     *str = '\0';
  1092.  
  1093.     /* return the string */
  1094.     return (val);
  1095. }
  1096.  
  1097.