summaryrefslogtreecommitdiff
path: root/xlisp/xlfio.c
diff options
context:
space:
mode:
Diffstat (limited to 'xlisp/xlfio.c')
-rw-r--r--xlisp/xlfio.c734
1 files changed, 734 insertions, 0 deletions
diff --git a/xlisp/xlfio.c b/xlisp/xlfio.c
new file mode 100644
index 0000000..44d734f
--- /dev/null
+++ b/xlisp/xlfio.c
@@ -0,0 +1,734 @@
+/* xlfio.c - xlisp file i/o */
+/* Copyright (c) 1985, by David Michael Betz
+ All Rights Reserved
+ Permission is granted for unrestricted non-commercial use */
+
+/* CHANGE LOG
+ * --------------------------------------------------------------------
+ * 30Sep06 rbd added xbigendianp
+ * 28Apr03 dm eliminate some compiler warnings
+ */
+
+
+#include "switches.h"
+
+#include <string.h>
+
+#include "xlisp.h"
+
+/* do some sanity checking: */
+#ifndef XL_BIG_ENDIAN
+#ifndef XL_LITTLE_ENDIAN
+#error configuration error -- either XL_BIG_ or XL_LITTLE_ENDIAN must be defined
+in xlisp.h
+#endif
+#endif
+#ifdef XL_BIG_ENDIAN
+#ifdef XL_LITTLE_ENDIAN
+#error configuration error -- both XL_BIG_ and XL_LITTLE_ENDIAN are defined!
+#endif
+#endif
+
+/* forward declarations */
+FORWARD LOCAL LVAL getstroutput(LVAL stream);
+FORWARD LOCAL LVAL printit(int pflag, int tflag);
+FORWARD LOCAL LVAL flatsize(int pflag);
+
+/* xread - read an expression */
+LVAL xread(void)
+{
+ LVAL fptr,eof,rflag,val;
+
+ /* get file pointer and eof value */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ eof = (moreargs() ? xlgetarg() : NIL);
+ rflag = (moreargs() ? xlgetarg() : NIL);
+ xllastarg();
+
+ /* read an expression */
+ if (!xlread(fptr,&val,rflag != NIL))
+ val = eof;
+
+ /* return the expression */
+ return (val);
+}
+
+/* xprint - built-in function 'print' */
+LVAL xprint(void)
+{
+ return (printit(TRUE,TRUE));
+}
+
+/* xprin1 - built-in function 'prin1' */
+LVAL xprin1(void)
+{
+ return (printit(TRUE,FALSE));
+}
+
+/* xprinc - built-in function princ */
+LVAL xprinc(void)
+{
+ return (printit(FALSE,FALSE));
+}
+
+/* xterpri - terminate the current print line */
+LVAL xterpri(void)
+{
+ LVAL fptr;
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ xllastarg();
+
+ /* terminate the print line and return nil */
+ xlterpri(fptr);
+ return (NIL);
+}
+
+/* printit - common print function */
+LOCAL LVAL printit(int pflag, int tflag)
+{
+ LVAL fptr,val;
+
+ /* get expression to print and file pointer */
+ val = xlgetarg();
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ xllastarg();
+
+ /* print the value */
+ xlprint(fptr,val,pflag);
+
+ /* terminate the print line if necessary */
+ if (tflag)
+ xlterpri(fptr);
+
+ /* return the result */
+ return (val);
+}
+
+/* xflatsize - compute the size of a printed representation using prin1 */
+LVAL xflatsize(void)
+{
+ return (flatsize(TRUE));
+}
+
+/* xflatc - compute the size of a printed representation using princ */
+LVAL xflatc(void)
+{
+ return (flatsize(FALSE));
+}
+
+/* flatsize - compute the size of a printed expression */
+LOCAL LVAL flatsize(int pflag)
+{
+ LVAL val;
+
+ /* get the expression */
+ val = xlgetarg();
+ xllastarg();
+
+ /* print the value to compute its size */
+ xlfsize = 0;
+ xlprint(NIL,val,pflag);
+
+ /* return the length of the expression */
+ return (cvfixnum((FIXTYPE)xlfsize));
+}
+
+/* xlopen - open a text or binary file */
+LVAL xlopen(int binaryflag)
+{
+ char *name,*mode=NULL;
+ FILE *fp;
+ LVAL dir;
+
+ /* get the file name and direction */
+ name = (char *)getstring(xlgetfname());
+ if (!xlgetkeyarg(k_direction,&dir))
+ dir = k_input;
+
+ /* get the mode */
+ if (dir == k_input)
+ mode = "r";
+ else if (dir == k_output)
+ mode = "w";
+ else
+ xlerror("bad direction",dir);
+
+ /* try to open the file */
+ if (binaryflag) {
+ fp = osbopen(name,mode);
+ } else {
+ fp = osaopen(name,mode);
+ }
+ return (fp ? cvfile(fp) : NIL);
+}
+
+
+/* xopen - open a file */
+LVAL xopen(void)
+{
+ return xlopen(FALSE);
+}
+
+/* xbopen - open a binary file */
+LVAL xbopen(void)
+{
+ return xlopen(TRUE);
+}
+
+/* xclose - close a file */
+LVAL xclose(void)
+{
+ LVAL fptr;
+
+ /* get file pointer */
+ fptr = xlgastream();
+ xllastarg();
+
+ /* make sure the file exists */
+ if (getfile(fptr) == NULL)
+ xlfail("file not open");
+
+ /* close the file */
+ osclose(getfile(fptr));
+ setfile(fptr,NULL);
+
+ /* return nil */
+ return (NIL);
+}
+
+/* xrdchar - read a character from a file */
+LVAL xrdchar(void)
+{
+ LVAL fptr;
+ int ch;
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ xllastarg();
+
+ /* get character and check for eof */
+ return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
+}
+
+/* xrdint - read an integer from a file */
+/* positive byte count means big-endian, negative is little-endian */
+LVAL xrdint(void)
+{
+ LVAL fptr;
+ unsigned char b[4];
+ long i;
+ int n = 4;
+ int index = 0; /* where to start in array */
+ int incr = 1; /* how to step through array */
+ int rslt;
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ /* get byte count */
+ if (moreargs()) {
+ LVAL count = typearg(fixp);
+ n = getfixnum(count);
+ if (n < 0) {
+ n = -n;
+ index = n - 1;
+ incr = -1;
+ }
+ if (n > 4) {
+ xlerror("4-byte limit", count);
+ }
+ }
+ xllastarg();
+ for (i = 0; i < n; i++) {
+ int ch = xlgetc(fptr);
+ if (ch == EOF) return NIL;
+ b[index] = ch;
+ index += incr;
+ }
+ /* build result, b is now big-endian */
+ /* extend sign bit for short integers */
+ rslt = ((b[0] & 0x80) ? -1 : 0);
+ for (i = 0; i < n; i++) {
+ rslt = (rslt << 8) + b[i];
+ }
+ /* return integer result */
+ return cvfixnum(rslt);
+}
+
+
+/* xrdfloat - read a float from a file */
+LVAL xrdfloat(void)
+{
+ LVAL fptr;
+ union {
+ char b[8];
+ float f;
+ double d;
+ } rslt;
+ int n = 4;
+ int i;
+ int index = 3; /* where to start in array */
+ int incr = -1; /* how to step through array */
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ /* get byte count */
+ if (moreargs()) {
+ LVAL count = typearg(fixp);
+ n = getfixnum(count);
+ if (n < 0) {
+ n = -n;
+ index = 0;
+ incr = 1;
+ }
+ if (n != 4 && n != 8) {
+ xlerror("must be 4 or 8 bytes", count);
+ }
+ }
+ xllastarg();
+
+#ifdef XL_BIG_ENDIAN
+ /* flip the bytes */
+ index = n - 1 - index;
+ incr = -incr;
+#endif
+ for (i = 0; i < n; i++) {
+ int ch = xlgetc(fptr);
+ if (ch == EOF) return NIL;
+ rslt.b[index] = ch;
+ index += incr;
+ }
+ /* return result */
+ return cvflonum(n == 4 ? rslt.f : rslt.d);
+}
+
+
+/* xrdbyte - read a byte from a file */
+LVAL xrdbyte(void)
+{
+ LVAL fptr;
+ int ch;
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ xllastarg();
+
+ /* get character and check for eof */
+ return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
+}
+
+/* xpkchar - peek at a character from a file */
+LVAL xpkchar(void)
+{
+ LVAL flag,fptr;
+ int ch;
+
+ /* peek flag and get file pointer */
+ flag = (moreargs() ? xlgetarg() : NIL);
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ xllastarg();
+
+ /* skip leading white space and get a character */
+ if (flag)
+ while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
+ xlgetc(fptr);
+ else
+ ch = xlpeek(fptr);
+
+ /* return the character */
+ return (ch == EOF ? NIL : cvchar(ch));
+}
+
+/* xwrchar - write a character to a file */
+LVAL xwrchar(void)
+{
+ LVAL fptr,chr;
+
+ /* get the character and file pointer */
+ chr = xlgachar();
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ xllastarg();
+
+ /* put character to the file */
+ xlputc(fptr,getchcode(chr));
+
+ /* return the character */
+ return (chr);
+}
+
+/* xwrbyte - write a byte to a file */
+LVAL xwrbyte(void)
+{
+ LVAL fptr,chr;
+
+ /* get the byte and file pointer */
+ chr = xlgafixnum();
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ xllastarg();
+
+ /* put byte to the file */
+ xlputc(fptr,(int)getfixnum(chr));
+
+ /* return the character */
+ return (chr);
+}
+
+/* xwrint - write an integer to a file */
+/* positive count means write big-endian */
+LVAL xwrint(void)
+{
+ LVAL val, fptr;
+ unsigned char b[4];
+ long i;
+ int n = 4;
+ int index = 3; /* where to start in array */
+ int incr = -1; /* how to step through array */
+ int v;
+ /* get the int and file pointer and optional byte count */
+ val = xlgafixnum();
+ v = getfixnum(val);
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ if (moreargs()) {
+ LVAL count = typearg(fixp);
+ n = getfixnum(count);
+ index = n - 1;
+ if (n < 0) {
+ n = -n;
+ index = 0;
+ incr = 1;
+ }
+ if (n > 4) {
+ xlerror("4-byte limit", count);
+ }
+ }
+ xllastarg();
+ /* build output b as little-endian */
+ for (i = 0; i < n; i++) {
+ b[i] = (unsigned char) v;
+ v = v >> 8;
+ }
+
+ /* put bytes to the file */
+ while (n) {
+ n--;
+ xlputc(fptr, b[index]);
+ index += incr;
+ }
+
+ /* return the integer */
+ return val;
+}
+
+/* xwrfloat - write a float to a file */
+LVAL xwrfloat(void)
+{
+ LVAL val, fptr;
+ union {
+ char b[8];
+ float f;
+ double d;
+ } v;
+ int n = 4;
+ int i;
+ int index = 3; /* where to start in array */
+ int incr = -1; /* how to step through array */
+
+ /* get the float and file pointer and optional byte count */
+ val = xlgaflonum();
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
+ if (moreargs()) {
+ LVAL count = typearg(fixp);
+ n = getfixnum(count);
+ if (n < 0) {
+ n = -n;
+ index = 0;
+ incr = 1;
+ }
+ if (n != 4 && n != 8) {
+ xlerror("must be 4 or 8 bytes", count);
+ }
+ }
+ xllastarg();
+
+#ifdef XL_BIG_ENDIAN
+ /* flip the bytes */
+ index = n - 1 - index;
+ incr = -incr;
+#endif
+ /* build output v.b */
+ if (n == 4) v.f = (float) getflonum(val);
+ else v.d = getflonum(val);
+
+ /* put bytes to the file */
+ for (i = 0; i < n; i++) {
+ xlputc(fptr, v.b[index]);
+ index += incr;
+ }
+
+ /* return the flonum */
+ return val;
+}
+
+/* xreadline - read a line from a file */
+LVAL xreadline(void)
+{
+ unsigned char buf[STRMAX+1],*p,*sptr;
+ LVAL fptr,str,newstr;
+ int len,blen,ch;
+
+ /* protect some pointers */
+ xlsave1(str);
+
+ /* get file pointer */
+ fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
+ xllastarg();
+
+ /* get character and check for eof */
+ len = blen = 0; p = buf;
+ while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
+
+ /* check for buffer overflow */
+ if (blen >= STRMAX) {
+ newstr = new_string(len + STRMAX + 1);
+ sptr = getstring(newstr); *sptr = '\0';
+ if (str) strcat((char *) sptr, (char *) getstring(str));
+ *p = '\0'; strcat((char *) sptr, (char *) buf);
+ p = buf; blen = 0;
+ len += STRMAX;
+ str = newstr;
+ }
+
+ /* store the character */
+ *p++ = ch; ++blen;
+ }
+
+ /* check for end of file */
+ if (len == 0 && p == buf && ch == EOF) {
+ xlpop();
+ return (NIL);
+ }
+
+ /* append the last substring */
+ if (str == NIL || blen) {
+ newstr = new_string(len + blen + 1);
+ sptr = getstring(newstr); *sptr = '\0';
+ if (str) strcat((char *) sptr, (char *) getstring(str));
+ *p = '\0'; strcat((char *) sptr, (char *) buf);
+ str = newstr;
+ }
+
+ /* restore the stack */
+ xlpop();
+
+ /* return the string */
+ return (str);
+}
+
+
+/* xmkstrinput - make a string input stream */
+LVAL xmkstrinput(void)
+{
+ int start,end,len,i;
+ unsigned char *str;
+ LVAL string,val;
+
+ /* protect the return value */
+ xlsave1(val);
+
+ /* get the string and length */
+ string = xlgastring();
+ str = getstring(string);
+ len = getslength(string) - 1;
+
+ /* get the starting offset */
+ if (moreargs()) {
+ val = xlgafixnum();
+ start = (int)getfixnum(val);
+ }
+ else start = 0;
+
+ /* get the ending offset */
+ if (moreargs()) {
+ val = xlgafixnum();
+ end = (int)getfixnum(val);
+ }
+ else end = len;
+ xllastarg();
+
+ /* check the bounds */
+ if (start < 0 || start > len)
+ xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
+ if (end < 0 || end > len)
+ xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
+
+ /* make the stream */
+ val = newustream();
+
+ /* copy the substring into the stream */
+ for (i = start; i < end; ++i)
+ xlputc(val,str[i]);
+
+ /* restore the stack */
+ xlpop();
+
+ /* return the new stream */
+ return (val);
+}
+
+/* xmkstroutput - make a string output stream */
+LVAL xmkstroutput(void)
+{
+ return (newustream());
+}
+
+/* xgetstroutput - get output stream string */
+LVAL xgetstroutput(void)
+{
+ LVAL stream;
+ stream = xlgaustream();
+ xllastarg();
+ return (getstroutput(stream));
+}
+
+/* xgetlstoutput - get output stream list */
+LVAL xgetlstoutput(void)
+{
+ LVAL stream,val;
+
+ /* get the stream */
+ stream = xlgaustream();
+ xllastarg();
+
+ /* get the output character list */
+ val = gethead(stream);
+
+ /* empty the character list */
+ sethead(stream,NIL);
+ settail(stream,NIL);
+
+ /* return the list */
+ return (val);
+}
+
+/* xformat - formatted output function */
+LVAL xformat(void)
+{
+ unsigned char *fmt;
+ LVAL stream,val;
+ int ch;
+
+ /* protect stream in case it is a new ustream */
+ xlsave1(stream);
+
+ /* get the stream and format string */
+ stream = xlgetarg();
+ if (stream == NIL)
+ val = stream = newustream();
+ else {
+ if (stream == s_true)
+ stream = getvalue(s_stdout);
+ else if (!streamp(stream) && !ustreamp(stream))
+ xlbadtype(stream);
+ val = NIL;
+ }
+ fmt = getstring(xlgastring());
+
+ /* process the format string */
+ while ((ch = *fmt++))
+ if (ch == '~') {
+ switch (*fmt++) {
+ case '\0':
+ xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
+ case 'a': case 'A':
+ xlprint(stream,xlgetarg(),FALSE);
+ break;
+ case 's': case 'S':
+ xlprint(stream,xlgetarg(),TRUE);
+ break;
+ case '%':
+ xlterpri(stream);
+ break;
+ case '~':
+ xlputc(stream,'~');
+ break;
+ case '\n':
+ case '\r':
+ /* mac may read \r -- this should be ignored */
+ if (*fmt == '\r') *fmt++;
+ while (*fmt && *fmt != '\n' && isspace(*fmt))
+ ++fmt;
+ break;
+ default:
+ xlerror("unknown format directive",cvstring((char *) (fmt-1)));
+ }
+ }
+ else
+ xlputc(stream,ch);
+
+ /* return the value */
+ if (val) val = getstroutput(val);
+ xlpop();
+ return val;
+}
+
+/* getstroutput - get the output stream string (internal) */
+LOCAL LVAL getstroutput(LVAL stream)
+{
+ unsigned char *str;
+ LVAL next,val;
+ int len,ch;
+
+ /* compute the length of the stream */
+ for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
+ ++len;
+
+ /* create a new string */
+ val = new_string(len + 1);
+
+ /* copy the characters into the new string */
+ str = getstring(val);
+ while ((ch = xlgetc(stream)) != EOF)
+ *str++ = ch;
+ *str = '\0';
+
+ /* return the string */
+ return (val);
+}
+
+
+LVAL xlistdir(void)
+{
+ char *path;
+ LVAL result = NULL;
+ LVAL *tail;
+ /* get the path */
+ path = (char *)getstring(xlgetfname());
+ /* try to start listing */
+ if (osdir_list_start(path)) {
+ char *filename;
+ xlsave1(result);
+ tail = &result;
+ while (filename = osdir_list_next()) {
+ *tail = cons(NIL, NIL);
+ rplaca(*tail, cvstring(filename));
+ tail = &cdr(*tail);
+ }
+ osdir_list_finish();
+ xlpop();
+ }
+ return result;
+}
+
+
+/* xbigendianp -- is this a big-endian machine? T or NIL */
+LVAL xbigendianp()
+{
+#ifdef XL_BIG_ENDIAN
+ return s_true;
+#else
+ return NIL;
+#endif
+}
+
+