xlread.c

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

/* xlread - xlisp expression input routine */
/*	Copyright (c) 1985, by David Michael Betz
        All Rights Reserved
        Permission is granted for unrestricted non-commercial use	*/
/* CHANGE LOG
 * --------------------------------------------------------------------
 * 28Apr03  dm  eliminate some compiler warnings
 *              replaced system-specific code with generic calls (see path.c)
 */


#include "stdlib.h"
#include "string.h"
#include "switches.h"
#include "xlisp.h"
#ifdef WINDOWS
#include "winfun.h"
#endif
#ifdef MACINTOSH
#include "macstuff.h"
#endif

/* symbol parser modes */
#define DONE	0
#define NORMAL	1
#define ESCAPE	2

/* external variables */
extern LVAL s_stdout,s_true,s_dot;
extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
extern LVAL k_sescape,k_mescape;
extern char buf[];

/* external routines */
extern FILE *osaopen();
/* on the NeXT, atof is a macro in stdlib.h */
#ifndef atof
extern double atof();
#endif
#ifndef __MWERKS__
#ifdef ITYPE
extern ITYPE;
#endif
#endif

#define WSPACE "\t \f\r\n"
#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"

/* forward declarations */
FORWARD LVAL callmacro(LVAL fptr, int ch);
FORWARD LOCAL LVAL psymbol(LVAL fptr);
FORWARD LOCAL LVAL punintern(LVAL fptr);
FORWARD LOCAL LVAL pnumber(LVAL fptr, int radix);
FORWARD LOCAL LVAL pquote(LVAL fptr, LVAL sym);
FORWARD LOCAL LVAL plist(LVAL fptr);
FORWARD LOCAL LVAL pvector(LVAL fptr);
FORWARD LOCAL void upcase(char *str);
FORWARD LOCAL int pname(LVAL fptr,int *pescflag);
FORWARD LOCAL void pcomment(LVAL fptr);
FORWARD LOCAL int checkeof(LVAL fptr);
FORWARD LOCAL int nextch(LVAL fptr);
FORWARD LOCAL void badeof(LVAL fptr);
FORWARD LOCAL int storech(char *buf, int i, int ch);

#ifdef WINDOWS
static char save_file_name[STRMAX+1]; /* keeps files opened by prompt */
static int sfn_valid = FALSE;
#endif

/* xlload - load a file of xlisp expressions */
int xlload(char *fname, int vflag, int pflag)
{
    char fullname[STRMAX+1];
#ifdef WINDOWS
    char *ptr;
#endif
    LVAL fptr,expr;
    XLCONTEXT cntxt;
    FILE *fp;
    int sts;

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

    /* space for copy + extension? */
    if (strlen(fname) > STRMAX - 4) goto toolong;
    strcpy(fullname,fname);
#ifdef WINDOWS
#ifdef WINGUI
    if (strcmp(fullname, "*") == 0) {
        if (sfn_valid) {
            strcpy(fullname, save_file_name);
        } else {
            strcpy(fullname, "*.*");
        }
    }
    if (strcmp(fullname, "*.*") == 0) {
        char *name = getfilename(NULL, "lsp", "r", "Load file");
        if (name) {
            strcpy(fullname, name);
            strcpy(save_file_name, name);
            sfn_valid = TRUE;
        } else {
            xlpopn(2);
            return FALSE;
        }
    }
#endif
    /* replace "/" with "\" so that (current-path) will work */
    for (ptr = fullname; *ptr; ptr++) {
        if (*ptr == '/') *ptr = '\\';
    }
#endif

    /* default the extension if there is room */
    if (needsextension(fullname)) {
        strcat(fullname,".lsp");
    }

    /* allocate a file node */
    fptr = cvfile(NULL);

    /* open the file */
    if ((fp = osaopen(fullname,"r")) == NULL) {
        /* new cross-platform code by dmazzoni - new xlisp_path
           implementation is in path.c */
        const char *newname = find_in_xlisp_path(fullname);
        if (newname && newname[0]) {
            if (strlen(newname) > STRMAX)
                goto toolong;
            strcpy(fullname, newname);
            fp = osaopen(fullname, "r");
        }

        if (!fp) {
           /* the file STILL wasn't found */
           xlpopn(2);
           return (FALSE);
        }
    }

    setfile(fptr,fp);
    setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
    setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));

    /* print the information line */
    if (vflag)
        { sprintf(buf,"; loading \"%s\"\n",fullname); stdputstr(buf); }

    /* read, evaluate and possibly print each expression in the file */
    xlbegin(&cntxt,CF_ERROR,s_true);
    if (setjmp(cntxt.c_jmpbuf))
        sts = FALSE;
    else {
        while (xlread(fptr,&expr,FALSE)) {
            expr = xleval(expr);
            if (pflag)
                stdprint(expr);
        }
        sts = TRUE;
    }
    xlend(&cntxt);

    /* close the file */
    osclose(getfile(fptr));
    setfile(fptr,NULL);
    if (consp(getvalue(s_loadingfiles)) && 
        consp(cdr(getvalue(s_loadingfiles))) &&
        car(cdr(getvalue(s_loadingfiles))) == fptr) {
        setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
    }

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

    /* return status */
    return (sts);

toolong:
    xlcerror("ignore file", "file name too long", NIL);
    xlpopn(2);
    return FALSE;
}

/* xlread - read an xlisp expression */
int xlread(LVAL fptr, LVAL *pval, int rflag)
{
    int sts;

    /* read an expression */
    while ((sts = readone(fptr,pval)) == FALSE)
        ;

    /* return status */
    return (sts == EOF ? FALSE : TRUE);
}

/* readone - attempt to read a single expression */
int readone(LVAL fptr, LVAL *pval)
{
    LVAL val,type;
    int ch;

    /* get a character and check for EOF */
    if ((ch = xlgetc(fptr)) == EOF)
        return (EOF);

    /* handle white space */
    if ((type = tentry(ch)) == k_wspace)
        return (FALSE);

    /* handle symbol constituents */
    else if (type == k_const) {
        xlungetc(fptr,ch);
        *pval = psymbol(fptr);
        return (TRUE);	    
    }

    /* handle single and multiple escapes */
    else if (type == k_sescape || type == k_mescape) {
        xlungetc(fptr,ch);
        *pval = psymbol(fptr);
        return (TRUE);
    }
    
    /* handle read macros */
    else if (consp(type)) {
        if ((val = callmacro(fptr,ch)) && consp(val)) {
            *pval = car(val);
            return (TRUE);
        }
        else
            return (FALSE);
    }

    /* handle illegal characters */
    else
        xlerror("illegal character",cvfixnum((FIXTYPE)ch));
}

/* rmhash - read macro for '#' */
LVAL rmhash(void)
{
    LVAL fptr,mch,val;
    int escflag,ch;

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

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

    /* make the return value */
    val = consa(NIL);

    /* check the next character */
    switch (ch = xlgetc(fptr)) {
    case '\'':
                rplaca(val,pquote(fptr,s_function));
                break;
    case '(':
                rplaca(val,pvector(fptr));
                break;
    case 'b':
    case 'B':
                rplaca(val,pnumber(fptr,2));
                break;
    case 'o':
    case 'O':
                rplaca(val,pnumber(fptr,8));
                break;
    case 'x':
    case 'X':
                    rplaca(val,pnumber(fptr,16));
                break;
    case '\\':
                xlungetc(fptr,ch);
                pname(fptr,&escflag);
                ch = buf[0];
                if (strlen(buf) > 1) {
                    upcase((char *) buf);
                    if (strcmp(buf,"NEWLINE") == 0)
                        ch = '\n';
                    else if (strcmp(buf,"SPACE") == 0)
                        ch = ' ';
                    else if (strcmp(buf,"TAB") == 0)
                        ch = '\t';
                    else
                        xlerror("unknown character name",cvstring(buf));
                }
                rplaca(val,cvchar(ch));
                break;
    case ':':
                rplaca(val,punintern(fptr));
                break;
    case '|':
                    pcomment(fptr);
                val = NIL;
                break;
    default:
                xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
    }

    /* restore the stack */
    xlpop();

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

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

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

    /* parse the quoted expression */
    return (consa(pquote(fptr,s_quote)));
}

/* rmdquote - read macro for '"' */
LVAL rmdquote(void)
{
    unsigned char buf[STRMAX+1],*p,*sptr;
    LVAL fptr,str,newstr,mch;
    int len,blen,ch,d2,d3;

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

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

    /* loop looking for a closing quote */
    len = blen = 0; p = buf;
    while ((ch = checkeof(fptr)) != '"') {

        /* handle escaped characters */
        switch (ch) {
        case '\\':
                switch (ch = checkeof(fptr)) {
                case 't':
                        ch = '\011';
                        break;
                case 'n':
                        ch = '\012';
                        break;
                case 'f':
                        ch = '\014';
                        break;
                case 'r':
                        ch = '\015';
                        break;
                default:
                        if (ch >= '0' && ch <= '7') {
                            d2 = checkeof(fptr);
                            d3 = checkeof(fptr);
                            if (d2 < '0' || d2 > '7'
                             || d3 < '0' || d3 > '7')
                                xlfail("invalid octal digit");
                            ch -= '0'; d2 -= '0'; d3 -= '0';
                            ch = (ch << 6) | (d2 << 3) | d3;
                        }
                        break;
                }
        }

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

    /* 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 new string */
    return (consa(str));
}

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

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

    /* parse the quoted expression */
    return (consa(pquote(fptr,s_bquote)));
}

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

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

    /* check the next character */
    if ((ch = xlgetc(fptr)) == '@')
        sym = s_comat;
    else {
        xlungetc(fptr,ch);
        sym = s_comma;
    }

    /* make the return value */
    return (consa(pquote(fptr,sym)));
}