home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / dirs / xlispstat_386.lzh / XLispStat / src1.lzh / XLisp / xlfio.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  11KB  |  506 lines
  1. /* xlfio.c - xlisp file i/o */
  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 "osproto.h"
  12. #else
  13. #include "xlfun.h"
  14. #include "osfun.h"
  15. #endif
  16. #include "xlvar.h"
  17.  
  18. /* forward declarations */
  19. #ifdef ANSI
  20. LVAL getstroutput(LVAL),printit(int,int),flatsize(int);
  21. #else
  22. LVAL getstroutput(),printit(),flatsize();
  23. #endif ANSI
  24.  
  25. /* xread - read an expression */
  26. /*** eof-error-p added - L. Tierney ***/
  27. LVAL xread()
  28. {
  29.     LVAL fptr,eof,rflag,val;
  30.     int eof_error_p;
  31.     
  32.     /* get file pointer and eof value */
  33.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  34.     eof_error_p = moreargs() ? ((xlgetarg() != NIL) ? TRUE : FALSE) : TRUE;
  35.     eof = (moreargs() ? xlgetarg() : NIL);
  36.     rflag = (moreargs() ? xlgetarg() : NIL);
  37.     xllastarg();
  38.  
  39.     /* read an expression */
  40.     if (!xlread(fptr,&val,rflag != NIL)) {
  41.         if (eof_error_p) xlfail("end of file on read");
  42.     else val = eof;
  43.     }
  44.     
  45.     /* return the expression */
  46.     return (val);
  47. }
  48.  
  49. /* xprint - built-in function 'print' */
  50. LVAL xprint()
  51. {
  52.     return (printit(TRUE,TRUE));
  53. }
  54.  
  55. /* xprin1 - built-in function 'prin1' */
  56. LVAL xprin1()
  57. {
  58.     return (printit(TRUE,FALSE));
  59. }
  60.  
  61. /* xprinc - built-in function princ */
  62. LVAL xprinc()
  63. {
  64.     return (printit(FALSE,FALSE));
  65. }
  66.  
  67. /* xterpri - terminate the current print line */
  68. LVAL xterpri()
  69. {
  70.     LVAL fptr;
  71.  
  72.     /* get file pointer */
  73.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  74.     xllastarg();
  75.  
  76.     /* terminate the print line and return nil */
  77.     xlterpri(fptr);
  78.     return (NIL);
  79. }
  80.  
  81. /* printit - common print function */
  82. LOCAL LVAL printit(pflag,tflag)
  83.   int pflag,tflag;
  84. {
  85.     LVAL fptr,val;
  86.  
  87.     /* get expression to print and file pointer */
  88.     val = xlgetarg();
  89.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  90.     xllastarg();
  91.  
  92. #ifndef OLDPRINT /* fixed to make PRINT correspond th CL specs - L. Tierney */
  93.     /* terminate the previous line if necessary */
  94.     if (tflag) xlterpri(fptr);
  95. #endif OLDPRINT
  96.     
  97.     /* print the value */
  98.     xlprint(fptr,val,pflag);
  99.  
  100. #ifndef OLDPRINT
  101.     /* print space if needed */
  102.     if (tflag) xlputc(fptr, ' ');
  103. #endif OLDPRINT
  104.  
  105. #ifdef OLDPRINT
  106.     /* terminate the print line if necessary */
  107.     if (tflag)
  108.     xlterpri(fptr);
  109. #endif OLDPRINT
  110.     /* return the result */
  111.     return (val);
  112. }
  113.  
  114. /* xflatsize - compute the size of a printed representation using prin1 */
  115. LVAL xflatsize()
  116. {
  117.     return (flatsize(TRUE));
  118. }
  119.  
  120. /* xflatc - compute the size of a printed representation using princ */
  121. LVAL xflatc()
  122. {
  123.     return (flatsize(FALSE));
  124. }
  125.  
  126. /* flatsize - compute the size of a printed expression */
  127. LOCAL LVAL flatsize(pflag)
  128.   int pflag;
  129. {
  130.     LVAL val;
  131.  
  132.     /* get the expression */
  133.     val = xlgetarg();
  134.     xllastarg();
  135.  
  136.     /* print the value to compute its size */
  137.     xlfsize = 0;
  138.     xlprint(NIL,val,pflag);
  139.  
  140.     /* return the length of the expression */
  141.     return (cvfixnum((FIXTYPE)xlfsize));
  142. }
  143.  
  144. /* xopen - open a file */
  145. LVAL xopen()
  146. {
  147.     char *name,*mode;
  148.     FILE *fp;
  149.     LVAL dir;
  150.  
  151.     /* get the file name and direction */
  152.     name = (char *)getstring(xlgetfname());
  153.     if (!xlgetkeyarg(k_direction,&dir))
  154.     dir = k_input;
  155.  
  156.     /* get the mode */
  157.     if (dir == k_input)
  158.     mode = "r";
  159.     else if (dir == k_output)
  160.     mode = "w";
  161.     else
  162.     xlerror("bad direction",dir);
  163.  
  164.     /* try to open the file */
  165.     return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL);
  166. }
  167.  
  168. /* xclose - close a file */
  169. LVAL xclose()
  170. {
  171.     LVAL fptr;
  172.  
  173.     /* get file pointer */
  174.     fptr = xlgastream();
  175.     xllastarg();
  176.  
  177.     /* make sure the file exists */
  178.     if (getfile(fptr) == NULL)
  179.     xlfail("file not open");
  180.  
  181.     /* close the file */
  182.     osclose(getfile(fptr));
  183.     setfile(fptr,NULL);
  184.  
  185.     /* return nil */
  186.     return (NIL);
  187. }
  188.  
  189. /* xrdchar - read a character from a file */
  190. LVAL xrdchar()
  191. {
  192.     LVAL fptr;
  193.     int ch;
  194.  
  195.     /* get file pointer */
  196.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  197.     xllastarg();
  198.  
  199.     /* get character and check for eof */
  200.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
  201. }
  202.  
  203. /* xrdbyte - read a byte from a file */
  204. LVAL xrdbyte()
  205. {
  206.     LVAL fptr;
  207.     int ch;
  208.  
  209.     /* get file pointer */
  210.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  211.     xllastarg();
  212.  
  213.     /* get character and check for eof */
  214.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
  215. }
  216.  
  217. /* xpkchar - peek at a character from a file */
  218. LVAL xpkchar()
  219. {
  220.     LVAL flag,fptr;
  221.     int ch;
  222.  
  223.     /* peek flag and get file pointer */
  224.     flag = (moreargs() ? xlgetarg() : NIL);
  225.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  226.     xllastarg();
  227.  
  228.     /* skip leading white space and get a character */
  229.     if (flag)
  230.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  231.         xlgetc(fptr);
  232.     else
  233.     ch = xlpeek(fptr);
  234.  
  235.     /* return the character */
  236.     return (ch == EOF ? NIL : cvchar(ch));
  237. }
  238.  
  239. /* xwrchar - write a character to a file */
  240. LVAL xwrchar()
  241. {
  242.     LVAL fptr,chr;
  243.  
  244.     /* get the character and file pointer */
  245.     chr = xlgachar();
  246.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  247.     xllastarg();
  248.  
  249.     /* put character to the file */
  250.     xlputc(fptr,getchcode(chr));
  251.  
  252.     /* return the character */
  253.     return (chr);
  254. }
  255.  
  256. /* xwrbyte - write a byte to a file */
  257. LVAL xwrbyte()
  258. {
  259.     LVAL fptr,chr;
  260.  
  261.     /* get the byte and file pointer */
  262.     chr = xlgafixnum();
  263.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  264.     xllastarg();
  265.  
  266.     /* put byte to the file */
  267.     xlputc(fptr,(int)getfixnum(chr));
  268.  
  269.     /* return the character */
  270.     return (chr);
  271. }
  272.  
  273. /* xreadline - read a line from a file */
  274. LVAL xreadline()
  275. {
  276.     unsigned char buf[STRMAX+1],*p,*sptr;
  277.     LVAL fptr,str,newstr;
  278.     int len,blen,ch;
  279.  
  280.     /* protect some pointers */
  281.     xlsave1(str);
  282.  
  283.     /* get file pointer */
  284.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  285.     xllastarg();
  286.  
  287.     /* get character and check for eof */
  288.     len = blen = 0; p = buf;
  289.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  290.  
  291.     /* check for buffer overflow */
  292.     if (blen >= STRMAX) {
  293.          newstr = newstring(len + STRMAX + 1);
  294.         sptr = getstring(newstr); *sptr = '\0';
  295.         if (str) strcat(sptr,getstring(str));
  296.         *p = '\0'; strcat(sptr,buf);
  297.         p = buf; blen = 0;
  298.         len += STRMAX;
  299.         str = newstr;
  300.     }
  301.  
  302.     /* store the character */
  303.     *p++ = ch; ++blen;
  304.     }
  305.  
  306.     /* check for end of file */
  307.     if (len == 0 && p == buf && ch == EOF) {
  308.     xlpop();
  309.     return (NIL);
  310.     }
  311.  
  312.     /* append the last substring */
  313.     if (str == NIL || blen) {
  314.     newstr = newstring(len + blen + 1);
  315.     sptr = getstring(newstr); *sptr = '\0';
  316.     if (str) strcat(sptr,getstring(str));
  317.     *p = '\0'; strcat(sptr,buf);
  318.     str = newstr;
  319.     }
  320.  
  321.     /* restore the stack */
  322.     xlpop();
  323.  
  324.     /* return the string */
  325.     return (str);
  326. }
  327.  
  328.  
  329. /* xmkstrinput - make a string input stream */
  330. LVAL xmkstrinput()
  331. {
  332.     int start,end,len,i;
  333.     unsigned char *str;
  334.     LVAL string,val;
  335.  
  336.     /* protect the return value */
  337.     xlsave1(val);
  338.     
  339.     /* get the string and length */
  340.     string = xlgastring();
  341.     str = getstring(string);
  342.     len = getslength(string) - 1;
  343.  
  344.     /* get the starting offset */
  345.     if (moreargs()) {
  346.     val = xlgafixnum();
  347.     start = (int)getfixnum(val);
  348.     }
  349.     else start = 0;
  350.  
  351.     /* get the ending offset */
  352.     if (moreargs()) {
  353.     val = xlgafixnum();
  354.     end = (int)getfixnum(val);
  355.     }
  356.     else end = len;
  357.     xllastarg();
  358.  
  359.     /* check the bounds */
  360.     if (start < 0 || start > len)
  361.     xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
  362.     if (end < 0 || end > len)
  363.     xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
  364.  
  365.     /* make the stream */
  366.     val = newustream();
  367.  
  368.     /* copy the substring into the stream */
  369.     for (i = start; i < end; ++i)
  370.     xlputc(val,str[i]);
  371.  
  372.     /* restore the stack */
  373.     xlpop();
  374.  
  375.     /* return the new stream */
  376.     return (val);
  377. }
  378.  
  379. /* xmkstroutput - make a string output stream */
  380. LVAL xmkstroutput()
  381. {
  382.     return (newustream());
  383. }
  384.  
  385. /* xgetstroutput - get output stream string */
  386. LVAL xgetstroutput()
  387. {
  388.     LVAL stream;
  389.     stream = xlgaustream();
  390.     xllastarg();
  391.     return (getstroutput(stream));
  392. }
  393.  
  394. /* xgetlstoutput - get output stream list */
  395. LVAL xgetlstoutput()
  396. {
  397.     LVAL stream,val;
  398.  
  399.     /* get the stream */
  400.     stream = xlgaustream();
  401.     xllastarg();
  402.  
  403.     /* get the output character list */
  404.     val = gethead(stream);
  405.  
  406.     /* empty the character list */
  407.     sethead(stream,NIL);
  408.     settail(stream,NIL);
  409.  
  410.     /* return the list */
  411.     return (val);
  412. }
  413.  
  414. #ifdef XLISP_ONLY /* commented out to save space - L. Tierney */
  415. /* xformat - formatted output function */
  416. LVAL xformat()
  417. {
  418.     LVAL fmtstring,stream,val;
  419.     unsigned char *fmt;
  420.     int ch;
  421.  
  422.     /* protect some pointers */
  423.     xlstkcheck(2);
  424.     xlsave(fmtstring);
  425.     xlsave(stream);
  426.  
  427.     /* get the stream and format string */
  428.     stream = xlgetarg();
  429.     if (stream == NIL)
  430.     val = stream = newustream();
  431.     else {
  432.     if (stream == true)
  433.         stream = getvalue(s_stdout);
  434.     else if (!streamp(stream) && !ustreamp(stream))
  435.         xlbadtype(stream);
  436.     val = NIL;
  437.     }
  438.     fmtstring = xlgastring();
  439.     fmt = getstring(fmtstring);
  440.  
  441.     /* process the format string */
  442.     while (ch = *fmt++)
  443.     if (ch == '~') {
  444.         switch (*fmt++) {
  445.         case '\0':
  446.         xlerror("expecting a format directive",cvstring(fmt-1));
  447.         case 'a': case 'A':
  448.         xlprint(stream,xlgetarg(),FALSE);
  449.         break;
  450.         case 's': case 'S':
  451.         xlprint(stream,xlgetarg(),TRUE);
  452.         break;
  453.         case '%':
  454.         xlterpri(stream);
  455.         break;
  456.         case '~':
  457.         xlputc(stream,'~');
  458.         break;
  459.         case '\n':
  460.         while (*fmt && *fmt != '\n' && isspace(*fmt))
  461.             ++fmt;
  462.         break;
  463.         default:
  464.         xlerror("unknown format directive",cvstring(fmt-1));
  465.         }
  466.     }
  467.     else
  468.         xlputc(stream,ch);
  469.     
  470.     /* get the output string for a stream argument of NIL */
  471.     if (val) val = getstroutput(val);
  472.     xlpopn(2);
  473.         
  474.     /* return the value */
  475.     return (val);
  476. }
  477. #else 
  478. LVAL xformat() { return(NIL); }
  479. #endif
  480.  
  481. /* getstroutput - get the output stream string (internal) */
  482. LOCAL LVAL getstroutput(stream)
  483.   LVAL stream;
  484. {
  485.     unsigned char *str;
  486.     LVAL next,val;
  487.     int len,ch;
  488.  
  489.     /* compute the length of the stream */
  490.     for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
  491.     ++len;
  492.  
  493.     /* create a new string */
  494.     val = newstring(len + 1);
  495.     
  496.     /* copy the characters into the new string */
  497.     str = getstring(val);
  498.     while ((ch = xlgetc(stream)) != EOF)
  499.     *str++ = ch;
  500.     *str = '\0';
  501.  
  502.     /* return the string */
  503.     return (val);
  504. }
  505.  
  506.