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