/* xlfio.c - xlisp file i/o */

#include "xlisp.h"
#ifdef  AZTEC
#include "ctype.h"
#endif

/* external variables */
extern NODE *s_stdin,*s_stdout;
extern NODE *xlstack;
extern int xlfsize;
extern char buf[];

/* external routines */
extern FILE *fopen();

/* forward declarations */
FORWARD NODE *printit();
FORWARD NODE *flatsize();
FORWARD NODE *explode();
FORWARD NODE *implode();
FORWARD NODE *openit();
FORWARD NODE *getfile();

/* xread - read an expression */
NODE *xread(args)
  NODE *args;
{
    NODE *oldstk,fptr,eof,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&eof,NULL);

    /* get file pointer and eof value */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    eof.n_ptr = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* read an expression */
    if (!xlread(fptr.n_ptr,&val))
	val = eof.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression */
    return (val);
}

/* xprint - builtin function 'print' */
NODE *xprint(args)
  NODE *args;
{
    return (printit(args,TRUE,TRUE));
}

/* xprin1 - builtin function 'prin1' */
NODE *xprin1(args)
  NODE *args;
{
    return (printit(args,TRUE,FALSE));
}

/* xprinc - builtin function princ */
NODE *xprinc(args)
  NODE *args;
{
    return (printit(args,FALSE,FALSE));
}

/* xterpri - terminate the current print line */
NODE *xterpri(args)
  NODE *args;
{
    NODE *fptr;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* terminate the print line and return nil */
    xlterpri(fptr);
    return (NIL);
}

/* printit - common print function */
LOCAL NODE *printit(args,pflag,tflag)
  NODE *args; int pflag,tflag;
{
    NODE *oldstk,fptr,val;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&val,NULL);

    /* get expression to print and file pointer */
    val.n_ptr = xlarg(&args);
    fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* print the value */
    xlprint(fptr.n_ptr,val.n_ptr,pflag);

    /* terminate the print line if necessary */
    if (tflag)
	xlterpri(fptr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result */
    return (val.n_ptr);
}

/* xflatsize - compute the size of a printed representation using prin1 */
NODE *xflatsize(args)
  NODE *args;
{
    return (flatsize(args,TRUE));
}

/* xflatc - compute the size of a printed representation using princ */
NODE *xflatc(args)
  NODE *args;
{
    return (flatsize(args,FALSE));
}

/* flatsize - compute the size of a printed expression */
LOCAL NODE *flatsize(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* print the value to compute its size */
    xlfsize = 0;
    xlprint(NIL,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the length of the expression */
    val.n_ptr = newnode(INT);
    val.n_ptr->n_int = xlfsize;
    return (val.n_ptr);
}

/* xexplode - explode an expression */
NODE *xexplode(args)
  NODE *args;
{
    return (explode(args,TRUE));
}

/* xexplc - explode an expression using princ */
NODE *xexplc(args)
  NODE *args;
{
    return (explode(args,FALSE));
}

/* explode - internal explode routine */
LOCAL NODE *explode(args,pflag)
  NODE *args; int pflag;
{
    NODE *oldstk,val,strm;

    /* create a new stack frame */
    oldstk = xlsave(&val,&strm,NULL);

    /* get the expression */
    val.n_ptr = xlarg(&args);
    xllastarg(args);

    /* create a stream */
    strm.n_ptr = newnode(LIST);

    /* print the value into the stream */
    xlprint(strm.n_ptr,val.n_ptr,pflag);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list of characters */
    return (car(strm.n_ptr));
}

/* ximplode - implode a list of characters into a symbol */
NODE *ximplode(args)
  NODE *args;
{
    return (implode(args,TRUE));
}

/* xmaknam - implode a list of characters into an uninterned symbol */
NODE *xmaknam(args)
  NODE *args;
{
    return (implode(args,FALSE));
}

/* implode - internal implode routine */
LOCAL NODE *implode(args,intflag)
  NODE *args; int intflag;
{
    NODE *list,*val;
    char *p;

    /* get the list */
    list = xlarg(&args);
    xllastarg(args);

    /* assemble the symbol's pname */
    for (p = buf; consp(list); list = cdr(list)) {
	if ((val = car(list)) == NIL || !fixp(val))
	    xlfail("bad character list");
	if ((int)(p - buf) < STRMAX)
	    *p++ = val->n_int;
    }
    *p = 0;

    /* create a symbol */
    val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));

    /* return the symbol */
    return (val);
}

/* xopeni - open an input file */
NODE *xopeni(args)
  NODE *args;
{
    return (openit(args,"r"));
}

/* xopeno - open an output file */
NODE *xopeno(args)
  NODE *args;
{
    return (openit(args,"w"));
}

/* openit - common file open routine */
LOCAL NODE *openit(args,mode)
  NODE *args; char *mode;
{
    NODE *fname,*val;
    FILE *fp;

    /* get the file name */
    fname = xlmatch(STR,&args);
    xllastarg(args);

    /* try to open the file */
    if ((fp = fopen(fname->n_str,mode)) != NULL) {
	val = newnode(FPTR);
	val->n_fp = fp;
	val->n_savech = 0;
    }
    else
	val = NIL;

    /* return the file pointer */
    return (val);
}

/* xclose - close a file */
NODE *xclose(args)
  NODE *args;
{
    NODE *fptr;

    /* get file pointer */
    fptr = xlmatch(FPTR,&args);
    xllastarg(args);

    /* make sure the file exists */
    if (fptr->n_fp == NULL)
	xlfail("file not open");

    /* close the file */
    fclose(fptr->n_fp);
    fptr->n_fp = NULL;

    /* return nil */
    return (NIL);
}

/* xrdchar - read a character from a file */
NODE *xrdchar(args)
  NODE *args;
{
    NODE *fptr,*val;
    int ch;

    /* get file pointer */
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* get character and check for eof */
    if ((ch = xlgetc(fptr)) == EOF)
	val = NIL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xpkchar - peek at a character from a file */
NODE *xpkchar(args)
  NODE *args;
{
    NODE *flag,*fptr,*val;
    int ch;

    /* peek flag and get file pointer */
    flag = (args ? xlarg(&args) : NIL);
    fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* skip leading white space and get a character */
    if (flag)
	while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
	    xlgetc(fptr);
    else
	ch = xlpeek(fptr);

    /* check for eof */
    if (ch == EOF)
	val = NIL;
    else {
	val = newnode(INT);
	val->n_int = ch;
    }

    /* return the character */
    return (val);
}

/* xwrchar - write a character to a file */
NODE *xwrchar(args)
  NODE *args;
{
    NODE *fptr,*chr;

    /* get the character and file pointer */
    chr = xlmatch(INT,&args);
    fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
    xllastarg(args);

    /* put character to the file */
    xlputc(fptr,chr->n_int);

    /* return the character */
    return (chr);
}

/* xreadline - read a line from a file */
NODE *xreadline(args)
  NODE *args;
{
    NODE *oldstk,fptr,str;
    char *p,*sptr;
    int len,ch;

    /* create a new stack frame */
    oldstk = xlsave(&fptr,&str,NULL);

    /* get file pointer */
    fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
    xllastarg(args);

    /* make a string node */
    str.n_ptr = newnode(STR);
    str.n_ptr->n_strtype = DYNAMIC;

    /* get character and check for eof */
    len = 0; p = buf;
    while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {

	/* check for buffer overflow */
	if ((int)(p - buf) == STRMAX) {
	    *p = 0;
 	    sptr = stralloc(len + STRMAX); *sptr = 0;
	    if (len) {
		strcpy(sptr,str.n_ptr->n_str);
		strfree(str.n_ptr->n_str);
	    }
	    str.n_ptr->n_str = sptr;
	    strcat(sptr,buf);
	    len += STRMAX;
	    p = buf;
	}

	/* store the character */
	*p++ = ch;
    }

    /* check for end of file */
    if (len == 0 && p == buf && ch == EOF) {
	xlstack = oldstk;
	return (NIL);
    }

    /* append the last substring */
    *p = 0;
    sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
    if (len) {
	strcpy(sptr,str.n_ptr->n_str);
	strfree(str.n_ptr->n_str);
    }
    str.n_ptr->n_str = sptr;
    strcat(sptr,buf);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the string */
    return (str.n_ptr);
}

/* getfile - get a file or stream */
LOCAL NODE *getfile(pargs)
  NODE **pargs;
{
    NODE *arg;

    /* get a file or stream (cons) or nil */
    if (arg = xlarg(pargs)) {
	if (filep(arg)) {
	    if (arg->n_fp == NULL)
		xlfail("file not open");
	}
	else if (!consp(arg))
	    xlfail("bad argument type");
    }
    return (arg);
}