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