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