/* xlfio.c - xlisp file i/o */ #ifdef AZTEC #include "stdio.h" #else #include #include #endif #include "xlisp.h" /* external variables */ extern struct node *s_stdin,*s_stdout; extern struct node *xlstack; extern int xlfsize; /* external routines */ extern FILE *fopen(); /* local variables */ static char buf[STRMAX+1]; /* forward declarations */ FORWARD struct node *printit(); FORWARD struct node *flatsize(); FORWARD struct node *explode(); FORWARD struct node *makesym(); FORWARD struct node *openit(); FORWARD struct node *getfile(); /* xread - read an expression */ struct node *xread(args) struct node *args; { struct 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) : NULL); 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' */ struct node *xprint(args) struct node *args; { return (printit(args,TRUE,TRUE)); } /* xprin1 - builtin function 'prin1' */ struct node *xprin1(args) struct node *args; { return (printit(args,TRUE,FALSE)); } /* xprinc - builtin function princ */ struct node *xprinc(args) struct node *args; { return (printit(args,FALSE,FALSE)); } /* xterpri - terminate the current print line */ struct node *xterpri(args) struct node *args; { struct 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 (NULL); } /* printit - common print function */ LOCAL struct node *printit(args,pflag,tflag) struct node *args; int pflag,tflag; { struct 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 */ struct node *xflatsize(args) struct node *args; { return (flatsize(args,TRUE)); } /* xflatc - compute the size of a printed representation using princ */ struct node *xflatc(args) struct node *args; { return (flatsize(args,FALSE)); } /* flatsize - compute the size of a printed expression */ LOCAL struct node *flatsize(args,pflag) struct node *args; int pflag; { struct 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(NULL,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 */ struct node *xexplode(args) struct node *args; { return (explode(args,TRUE)); } /* xexplc - explode an expression using princ */ struct node *xexplc(args) struct node *args; { return (explode(args,FALSE)); } /* explode - internal explode routine */ LOCAL struct node *explode(args,pflag) struct node *args; int pflag; { struct 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 (strm.n_ptr->n_listvalue); } /* ximplode - implode a list of characters into an expression */ struct node *ximplode(args) struct node *args; { return (makesym(args,TRUE)); } /* xmaknam - implode a list of characters into an uninterned symbol */ struct node *xmaknam(args) struct node *args; { return (makesym(args,FALSE)); } /* makesym - internal implode routine */ LOCAL struct node *makesym(args,intflag) struct node *args; int intflag; { struct node *list,*val; char *p; /* get the list */ list = xlarg(&args); xllastarg(args); /* assemble the symbol's pname */ for (p = buf; list && list->n_type == LIST; list = list->n_listnext) { if ((val = list->n_listvalue) == NULL || val->n_type != INT) 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 */ struct node *xopeni(args) struct node *args; { return (openit(args,"r")); } /* xopeno - open an output file */ struct node *xopeno(args) struct node *args; { return (openit(args,"w")); } /* openit - common file open routine */ LOCAL struct node *openit(args,mode) struct node *args; char *mode; { struct 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 = NULL; /* return the file pointer */ return (val); } /* xclose - close a file */ struct node *xclose(args) struct node *args; { struct 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 (NULL); } /* xrdchar - read a character from a file */ struct node *xrdchar(args) struct node *args; { struct 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 = NULL; else { val = newnode(INT); val->n_int = ch; } /* return the character */ return (val); } /* xpkchar - peek at a character from a file */ struct node *xpkchar(args) struct node *args; { struct node *flag,*fptr,*val; int ch; /* peek flag and get file pointer */ flag = (args ? xlarg(&args) : NULL); 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 = NULL; else { val = newnode(INT); val->n_int = ch; } /* return the character */ return (val); } /* xwrchar - write a character to a file */ struct node *xwrchar(args) struct node *args; { struct 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 */ struct node *xreadline(args) struct node *args; { struct 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 (NULL); } /* 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 struct node *getfile(pargs) struct node **pargs; { struct node *arg; /* get a file or stream (cons) or nil */ if (arg = xlarg(pargs)) { if (arg->n_type == FPTR) { if (arg->n_fp == NULL) xlfail("file closed"); } else if (arg->n_type != LIST) xlfail("bad file or stream"); } return (arg); }