xlread.c

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

/* rmlpar - read macro for '(' */
LVAL rmlpar(void)
{
    LVAL fptr,mch;

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* make the return value */
    return (consa(plist(fptr)));
}

/* 4035 is the "no return value" warning message */
/* rmrpar, pcomment, badeof, and upcase don't return anything */
/* #pragma warning(disable: 4035) */

/* rmrpar - read macro for ')' */
LVAL rmrpar(void)
{
    xlfail("misplaced right paren");
    return NULL; /* never used */
}

/* rmsemi - read macro for ';' */
LVAL rmsemi(void)
{
    LVAL fptr,mch;
    int ch;

    /* get the file and macro character */
    fptr = xlgetfile();
    mch = xlgachar();
    xllastarg();

    /* skip to end of line */
    while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
        ;

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

/* pcomment - parse a comment delimited by #| and |# */
LOCAL void pcomment(LVAL fptr)
{
    int lastch,ch,n;

    /* look for the matching delimiter (and handle nesting) */
    for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
        if (lastch == '|' && ch == '#')
            { --n; ch = -1; }
        else if (lastch == '#' && ch == '|')
            { ++n; ch = -1; }
        lastch = ch;
    }
}

/* pnumber - parse a number */
LOCAL LVAL pnumber(LVAL fptr, int radix)
{
    int digit,ch;
    long num;
    
    for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
        if (islower(ch)) ch = toupper(ch);
        if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
            break;
        if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
            break;
        num = num * (long)radix + (long)digit;
    }
    xlungetc(fptr,ch);
    return (cvfixnum((FIXTYPE)num));
}

/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
    LVAL val,expr,lastnptr,nptr;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(val);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL; nextch(fptr) != ')'; )

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:

            /* check for a dotted tail */
            if (expr == s_dot) {
                /* make sure there's a node */
                if (lastnptr == NIL)
                    xlfail("invalid dotted pair");

                /* parse the expression after the dot */
                if (!xlread(fptr,&expr,TRUE))
                    badeof(fptr);
                rplacd(lastnptr,expr);

                /* make sure its followed by a close paren */
                if (nextch(fptr) != ')')
                    xlfail("invalid dotted pair");
            }

            /* otherwise, handle a normal list element */
            else {
                nptr = consa(expr);
                if (lastnptr == NIL)
                    val = nptr;
                else
                    rplacd(lastnptr,nptr);
                lastnptr = nptr;
            }
            break;
        }

    /* skip the closing paren */
    xlgetc(fptr);

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}

/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
    LVAL list,expr,val,lastnptr,nptr;
    int len,ch,i;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(list);
    xlsave(expr);

    /* keep appending nodes until a closing paren is found */
    for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {

        /* check for end of file */
        if (ch == EOF)
            badeof(fptr);

        /* get the next expression */
        switch (readone(fptr,&expr)) {
        case EOF:
            badeof(fptr);
        case TRUE:
            nptr = consa(expr);
            if (lastnptr == NIL)
                list = nptr;
            else
                rplacd(lastnptr,nptr);
            lastnptr = nptr;
            len++;
            break;
        }
    }

    /* skip the closing paren */
    xlgetc(fptr);

    /* make a vector of the appropriate length */
    val = newvector(len);

    /* copy the list into the vector */
    for (i = 0; i < len; ++i, list = cdr(list))
        setelement(val,i,car(list));

    /* restore the stack */
    xlpopn(2);

    /* return successfully */
    return (val);
}

/* pquote - parse a quoted expression */
LOCAL LVAL pquote(LVAL fptr, LVAL sym)
{
    LVAL val,p;

    /* protect some pointers */
    xlsave1(val);

    /* allocate two nodes */
    val = consa(sym);
    rplacd(val,consa(NIL));

    /* initialize the second to point to the quoted expression */
    if (!xlread(fptr,&p,TRUE))
        badeof(fptr);
    rplaca(cdr(val),p);

    /* restore the stack */
    xlpop();

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

/* psymbol - parse a symbol name */
LOCAL LVAL psymbol(LVAL fptr)
{
    int escflag;
    LVAL val;
    pname(fptr,&escflag);
    return (escflag || !xlisnumber(buf,&val) ? xlenter(buf) : val);
}

/* punintern - parse an uninterned symbol */
LOCAL LVAL punintern(LVAL fptr)
{
    int escflag;
    pname(fptr,&escflag);
    return (xlmakesym(buf));
}

/* pname - parse a symbol/package name */
LOCAL int pname(LVAL fptr,int *pescflag)
{
    int mode,ch=0,i;
    LVAL type;

    /* initialize */
    *pescflag = FALSE;
    mode = NORMAL;
    i = 0;

    /* accumulate the symbol name */
    while (mode != DONE) {

        /* handle normal mode */
        while (mode == NORMAL)
            if ((ch = xlgetc(fptr)) == EOF)
                mode = DONE;
            else if ((type = tentry(ch)) == k_sescape) {
                i = storech(buf,i,checkeof(fptr));
                *pescflag = TRUE;
            }
            else if (type == k_mescape) {
                *pescflag = TRUE;
                mode = ESCAPE;
            }
            else if (type == k_const
                 ||  (consp(type) && car(type) == k_nmacro))
                i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
            else
                mode = DONE;

        /* handle multiple escape mode */
        while (mode == ESCAPE)
            if ((ch = xlgetc(fptr)) == EOF)
                badeof(fptr);
            else if ((type = tentry(ch)) == k_sescape)
                i = storech(buf,i,checkeof(fptr));
            else if (type == k_mescape)
                mode = NORMAL;
            else
                i = storech(buf,i,ch);
    }
    buf[i] = 0;

    /* check for a zero length name */
    if (i == 0)
        xlerror("zero length name", s_unbound);

    /* unget the last character and return it */
    xlungetc(fptr,ch);
    return (ch);
}

/* storech - store a character in the print name buffer */
LOCAL int storech(char *buf, int i, int ch)
{
    if (i < STRMAX)
        buf[i++] = ch;
    return (i);
}

/* tentry - get a readtable entry */
LVAL tentry(int ch)
{
    LVAL rtable;
    rtable = getvalue(s_rtable);
    if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
        return (NIL);
    return (getelement(rtable,ch));
}

/* nextch - look at the next non-blank character */
LOCAL int nextch(LVAL fptr)
{
    int ch;

    /* return and save the next non-blank character */
    while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
        ;
    xlungetc(fptr,ch);
    return (ch);
}

/* checkeof - get a character and check for end of file */
LOCAL int checkeof(LVAL fptr)
{
    int ch;

    if ((ch = xlgetc(fptr)) == EOF)
        badeof(fptr);
    return (ch);
}

/* badeof - unexpected eof */
LOCAL void badeof(LVAL fptr)
{
    xlgetc(fptr);
    xlfail("unexpected EOF");
}

/* xlisnumber - check if this string is a number */
int xlisnumber(char *str, LVAL *pval)
{
    int dl,dr;
    char *p;

    /* initialize */
    p = str; dl = dr = 0;

    /* check for a sign */
    if (*p == '+' || *p == '-')
        p++;

    /* check for a string of digits */
    while (isdigit(*p))
        p++, dl++;

    /* check for a decimal point */
    if (*p == '.') {
        p++;
        while (isdigit(*p))
            p++, dr++;
    }

    /* check for an exponent */
    if ((dl || dr) && *p == 'E') {
        p++;

        /* check for a sign */
        if (*p == '+' || *p == '-')
            p++;

        /* check for a string of digits */
        while (isdigit(*p))
            p++, dr++;
    }

    /* make sure there was at least one digit and this is the end */
    if ((dl == 0 && dr == 0) || *p)
        return (FALSE);

    /* convert the string to an integer and return successfully */
    if (pval) {
        if (*str == '+') ++str;
        if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
        *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
    }
    return (TRUE);
}

/* defmacro - define a read macro */
void defmacro(int ch, LVAL type, int offset)
{
    extern FUNDEF funtab[];
    LVAL subr;
    subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
    setelement(getvalue(s_rtable),ch,cons(type,subr));
}

/* callmacro - call a read macro */
LVAL callmacro(LVAL fptr, int ch)
{
    LVAL *newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(cdr(getelement(getvalue(s_rtable),ch)));
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(fptr);
    pusharg(cvchar(ch));
    xlfp = newfp;
    return (xlapply(2));
}

/* upcase - translate a string to upper case */
LOCAL void upcase(char *str)
{
    for (; *str != '\0'; ++str)
        if (islower(*str))
            *str = toupper(*str);
}

/* xlrinit - initialize the reader */
void xlrinit(void)
{
    LVAL rtable;
    char *p;
    int ch;

    /* create the read table */
    rtable = newvector(256);
    setvalue(s_rtable,rtable);

    /* initialize the readtable */
    for (p = WSPACE; (ch = *p++); )
        setelement(rtable,ch,k_wspace);
    for (p = CONST1; (ch = *p++); )
        setelement(rtable,ch,k_const);
    for (p = CONST2; (ch = *p++); )
        setelement(rtable,ch,k_const);

    /* setup the escape characters */
    setelement(rtable,'\\',k_sescape);
    setelement(rtable,'|', k_mescape);

    /* install the read macros */
    defmacro('#', k_nmacro,FT_RMHASH);
    defmacro('\'',k_tmacro,FT_RMQUOTE);
    defmacro('"', k_tmacro,FT_RMDQUOTE);
    defmacro('`', k_tmacro,FT_RMBQUOTE);
    defmacro(',', k_tmacro,FT_RMCOMMA);
    defmacro('(', k_tmacro,FT_RMLPAR);
    defmacro(')', k_tmacro,FT_RMRPAR);
    defmacro(';', k_tmacro,FT_RMSEMI);
}