audacity/lib-src/libnyquist/nyquist/xlisp/xlfio.c

/* 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
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
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
}