home *** CD-ROM | disk | FTP | other *** search
/ Carousel Volume 2 #1 / carousel.iso / mactosh / lang / xlisp.sha / xlfio.c < prev    next >
Encoding:
C/C++ Source or Header  |  1985-02-17  |  8.8 KB  |  446 lines
  1. /* xlfio.c - xlisp file i/o */
  2.  
  3. #include "xlisp.h"
  4. #include "ctype.h"
  5.  
  6. /* external variables */
  7. extern NODE *s_stdin,*s_stdout;
  8. extern NODE *xlstack;
  9. extern int xlfsize;
  10. extern char buf[];
  11.  
  12. /* external routines */
  13. extern FILE *fopen();
  14.  
  15. /* forward declarations */
  16. FORWARD NODE *printit();
  17. FORWARD NODE *flatsize();
  18. FORWARD NODE *explode();
  19. FORWARD NODE *implode();
  20. FORWARD NODE *openit();
  21. FORWARD NODE *getfile();
  22.  
  23. /* xread - read an expression */
  24. NODE *xread(args)
  25.   NODE *args;
  26. {
  27.     NODE *oldstk,fptr,eof,*val;
  28.  
  29.     /* create a new stack frame */
  30.     oldstk = xlsave(&fptr,&eof,NULL);
  31.  
  32.     /* get file pointer and eof value */
  33.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  34.     eof.n_ptr = (args ? xlarg(&args) : NIL);
  35.     xllastarg(args);
  36.  
  37.     /* read an expression */
  38.     if (!xlread(fptr.n_ptr,&val))
  39.     val = eof.n_ptr;
  40.  
  41.     /* restore the previous stack frame */
  42.     xlstack = oldstk;
  43.  
  44.     /* return the expression */
  45.     return (val);
  46. }
  47.  
  48. /* xprint - builtin function 'print' */
  49. NODE *xprint(args)
  50.   NODE *args;
  51. {
  52.     return (printit(args,TRUE,TRUE));
  53. }
  54.  
  55. /* xprin1 - builtin function 'prin1' */
  56. NODE *xprin1(args)
  57.   NODE *args;
  58. {
  59.     return (printit(args,TRUE,FALSE));
  60. }
  61.  
  62. /* xprinc - builtin function princ */
  63. NODE *xprinc(args)
  64.   NODE *args;
  65. {
  66.     return (printit(args,FALSE,FALSE));
  67. }
  68.  
  69. /* xterpri - terminate the current print line */
  70. NODE *xterpri(args)
  71.   NODE *args;
  72. {
  73.     NODE *fptr;
  74.  
  75.     /* get file pointer */
  76.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  77.     xllastarg(args);
  78.  
  79.     /* terminate the print line and return nil */
  80.     xlterpri(fptr);
  81.     return (NIL);
  82. }
  83.  
  84. /* printit - common print function */
  85. LOCAL NODE *printit(args,pflag,tflag)
  86.   NODE *args; int pflag,tflag;
  87. {
  88.     NODE *oldstk,fptr,val;
  89.  
  90.     /* create a new stack frame */
  91.     oldstk = xlsave(&fptr,&val,NULL);
  92.  
  93.     /* get expression to print and file pointer */
  94.     val.n_ptr = xlarg(&args);
  95.     fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  96.     xllastarg(args);
  97.  
  98.     /* print the value */
  99.     xlprint(fptr.n_ptr,val.n_ptr,pflag);
  100.  
  101.     /* terminate the print line if necessary */
  102.     if (tflag)
  103.     xlterpri(fptr.n_ptr);
  104.  
  105.     /* restore the previous stack frame */
  106.     xlstack = oldstk;
  107.  
  108.     /* return the result */
  109.     return (val.n_ptr);
  110. }
  111.  
  112. /* xflatsize - compute the size of a printed representation using prin1 */
  113. NODE *xflatsize(args)
  114.   NODE *args;
  115. {
  116.     return (flatsize(args,TRUE));
  117. }
  118.  
  119. /* xflatc - compute the size of a printed representation using princ */
  120. NODE *xflatc(args)
  121.   NODE *args;
  122. {
  123.     return (flatsize(args,FALSE));
  124. }
  125.  
  126. /* flatsize - compute the size of a printed expression */
  127. LOCAL NODE *flatsize(args,pflag)
  128.   NODE *args; int pflag;
  129. {
  130.     NODE *oldstk,val;
  131.  
  132.     /* create a new stack frame */
  133.     oldstk = xlsave(&val,NULL);
  134.  
  135.     /* get the expression */
  136.     val.n_ptr = xlarg(&args);
  137.     xllastarg(args);
  138.  
  139.     /* print the value to compute its size */
  140.     xlfsize = 0;
  141.     xlprint(NIL,val.n_ptr,pflag);
  142.  
  143.     /* restore the previous stack frame */
  144.     xlstack = oldstk;
  145.  
  146.     /* return the length of the expression */
  147.     val.n_ptr = newnode(INT);
  148.     val.n_ptr->n_int = xlfsize;
  149.     return (val.n_ptr);
  150. }
  151.  
  152. /* xexplode - explode an expression */
  153. NODE *xexplode(args)
  154.   NODE *args;
  155. {
  156.     return (explode(args,TRUE));
  157. }
  158.  
  159. /* xexplc - explode an expression using princ */
  160. NODE *xexplc(args)
  161.   NODE *args;
  162. {
  163.     return (explode(args,FALSE));
  164. }
  165.  
  166. /* explode - internal explode routine */
  167. LOCAL NODE *explode(args,pflag)
  168.   NODE *args; int pflag;
  169. {
  170.     NODE *oldstk,val,strm;
  171.  
  172.     /* create a new stack frame */
  173.     oldstk = xlsave(&val,&strm,NULL);
  174.  
  175.     /* get the expression */
  176.     val.n_ptr = xlarg(&args);
  177.     xllastarg(args);
  178.  
  179.     /* create a stream */
  180.     strm.n_ptr = newnode(LIST);
  181.  
  182.     /* print the value into the stream */
  183.     xlprint(strm.n_ptr,val.n_ptr,pflag);
  184.  
  185.     /* restore the previous stack frame */
  186.     xlstack = oldstk;
  187.  
  188.     /* return the list of characters */
  189.     return (car(strm.n_ptr));
  190. }
  191.  
  192. /* ximplode - implode a list of characters into a symbol */
  193. NODE *ximplode(args)
  194.   NODE *args;
  195. {
  196.     return (implode(args,TRUE));
  197. }
  198.  
  199. /* xmaknam - implode a list of characters into an uninterned symbol */
  200. NODE *xmaknam(args)
  201.   NODE *args;
  202. {
  203.     return (implode(args,FALSE));
  204. }
  205.  
  206. /* implode - internal implode routine */
  207. LOCAL NODE *implode(args,intflag)
  208.   NODE *args; int intflag;
  209. {
  210.     NODE *list,*val;
  211.     char *p;
  212.  
  213.     /* get the list */
  214.     list = xlarg(&args);
  215.     xllastarg(args);
  216.  
  217.     /* assemble the symbol's pname */
  218.     for (p = buf; consp(list); list = cdr(list)) {
  219.     if ((val = car(list)) == NIL || !fixp(val))
  220.         xlfail("bad character list");
  221.     if ((int)(p - buf) < STRMAX)
  222.         *p++ = val->n_int;
  223.     }
  224.     *p = 0;
  225.  
  226.     /* create a symbol */
  227.     val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
  228.  
  229.     /* return the symbol */
  230.     return (val);
  231. }
  232.  
  233. /* xopeni - open an input file */
  234. NODE *xopeni(args)
  235.   NODE *args;
  236. {
  237.     return (openit(args,"r"));
  238. }
  239.  
  240. /* xopeno - open an output file */
  241. NODE *xopeno(args)
  242.   NODE *args;
  243. {
  244.     return (openit(args,"w"));
  245. }
  246.  
  247. /* openit - common file open routine */
  248. LOCAL NODE *openit(args,mode)
  249.   NODE *args; char *mode;
  250. {
  251.     NODE *fname,*val;
  252.     FILE *fp;
  253.  
  254.     /* get the file name */
  255.     fname = xlmatch(STR,&args);
  256.     xllastarg(args);
  257.  
  258.     /* try to open the file */
  259.     if ((fp = fopen(fname->n_str,mode)) != NULL) {
  260.     val = newnode(FPTR);
  261.     val->n_fp = fp;
  262.     val->n_savech = 0;
  263.     }
  264.     else
  265.     val = NIL;
  266.  
  267.     /* return the file pointer */
  268.     return (val);
  269. }
  270.  
  271. /* xclose - close a file */
  272. NODE *xclose(args)
  273.   NODE *args;
  274. {
  275.     NODE *fptr;
  276.  
  277.     /* get file pointer */
  278.     fptr = xlmatch(FPTR,&args);
  279.     xllastarg(args);
  280.  
  281.     /* make sure the file exists */
  282.     if (fptr->n_fp == NULL)
  283.     xlfail("file not open");
  284.  
  285.     /* close the file */
  286.     fclose(fptr->n_fp);
  287.     fptr->n_fp = NULL;
  288.  
  289.     /* return nil */
  290.     return (NIL);
  291. }
  292.  
  293. /* xrdchar - read a character from a file */
  294. NODE *xrdchar(args)
  295.   NODE *args;
  296. {
  297.     NODE *fptr,*val;
  298.     int ch;
  299.  
  300.     /* get file pointer */
  301.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  302.     xllastarg(args);
  303.  
  304.     /* get character and check for eof */
  305.     if ((ch = xlgetc(fptr)) == EOF)
  306.     val = NIL;
  307.     else {
  308.     val = newnode(INT);
  309.     val->n_int = ch;
  310.     }
  311.  
  312.     /* return the character */
  313.     return (val);
  314. }
  315.  
  316. /* xpkchar - peek at a character from a file */
  317. NODE *xpkchar(args)
  318.   NODE *args;
  319. {
  320.     NODE *flag,*fptr,*val;
  321.     int ch;
  322.  
  323.     /* peek flag and get file pointer */
  324.     flag = (args ? xlarg(&args) : NIL);
  325.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  326.     xllastarg(args);
  327.  
  328.     /* skip leading white space and get a character */
  329.     if (flag)
  330.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  331.         xlgetc(fptr);
  332.     else
  333.     ch = xlpeek(fptr);
  334.  
  335.     /* check for eof */
  336.     if (ch == EOF)
  337.     val = NIL;
  338.     else {
  339.     val = newnode(INT);
  340.     val->n_int = ch;
  341.     }
  342.  
  343.     /* return the character */
  344.     return (val);
  345. }
  346.  
  347. /* xwrchar - write a character to a file */
  348. NODE *xwrchar(args)
  349.   NODE *args;
  350. {
  351.     NODE *fptr,*chr;
  352.  
  353.     /* get the character and file pointer */
  354.     chr = xlmatch(INT,&args);
  355.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  356.     xllastarg(args);
  357.  
  358.     /* put character to the file */
  359.     xlputc(fptr,chr->n_int);
  360.  
  361.     /* return the character */
  362.     return (chr);
  363. }
  364.  
  365. /* xreadline - read a line from a file */
  366. NODE *xreadline(args)
  367.   NODE *args;
  368. {
  369.     NODE *oldstk,fptr,str;
  370.     char *p,*sptr;
  371.     int len,ch;
  372.  
  373.     /* create a new stack frame */
  374.     oldstk = xlsave(&fptr,&str,NULL);
  375.  
  376.     /* get file pointer */
  377.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  378.     xllastarg(args);
  379.  
  380.     /* make a string node */
  381.     str.n_ptr = newnode(STR);
  382.     str.n_ptr->n_strtype = DYNAMIC;
  383.  
  384.     /* get character and check for eof */
  385.     len = 0; p = buf;
  386.     while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
  387.  
  388.     /* check for buffer overflow */
  389.     if ((int)(p - buf) == STRMAX) {
  390.         *p = 0;
  391.          sptr = stralloc(len + STRMAX); *sptr = 0;
  392.         if (len) {
  393.         strcpy(sptr,str.n_ptr->n_str);
  394.         strfree(str.n_ptr->n_str);
  395.         }
  396.         str.n_ptr->n_str = sptr;
  397.         strcat(sptr,buf);
  398.         len += STRMAX;
  399.         p = buf;
  400.     }
  401.  
  402.     /* store the character */
  403.     *p++ = ch;
  404.     }
  405.  
  406.     /* check for end of file */
  407.     if (len == 0 && p == buf && ch == EOF) {
  408.     xlstack = oldstk;
  409.     return (NIL);
  410.     }
  411.  
  412.     /* append the last substring */
  413.     *p = 0;
  414.     sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
  415.     if (len) {
  416.     strcpy(sptr,str.n_ptr->n_str);
  417.     strfree(str.n_ptr->n_str);
  418.     }
  419.     str.n_ptr->n_str = sptr;
  420.     strcat(sptr,buf);
  421.  
  422.     /* restore the previous stack frame */
  423.     xlstack = oldstk;
  424.  
  425.     /* return the string */
  426.     return (str.n_ptr);
  427. }
  428.  
  429. /* getfile - get a file or stream */
  430. LOCAL NODE *getfile(pargs)
  431.   NODE **pargs;
  432. {
  433.     NODE *arg;
  434.  
  435.     /* get a file or stream (cons) or nil */
  436.     if (arg = xlarg(pargs)) {
  437.     if (filep(arg)) {
  438.         if (arg->n_fp == NULL)
  439.         xlfail("file not open");
  440.     }
  441.     else if (!consp(arg))
  442.         xlfail("bad argument type");
  443.     }
  444.     return (arg);
  445. }
  446.