/* xlread - xlisp expression input routine */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include "xlisp.h"
/* symbol parser modes */
#define DONE 0
#define NORMAL 1
#define ESCAPE 2
/* string constants */
#define WSPACE "\t \f\r\n"
#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
/* forward declarations */
LOCAL LVAL callmacro P2H(LVAL, int);
LOCAL LVAL psymbol P1H(LVAL);
LOCAL LVAL punintern P1H(LVAL);
LOCAL LVAL pnumber P2H(LVAL, int);
LOCAL LVAL pquote P2H(LVAL, LVAL);
LOCAL LVAL plist P1H(LVAL);
LOCAL LVAL pvector P1H(LVAL);
LOCAL LVAL pstruct P1H(LVAL);
LOCAL LVAL readlist P2H(LVAL, int *);
LOCAL VOID pcomment P1H(LVAL);
LOCAL VOID badeof(V);/* TAA MOD to remove unnecessary arg 11/92 */
LOCAL VOID upcase P1H(char *);
LOCAL VOID storech P2H(int *, int);
LOCAL int nextch P1H(LVAL);
LOCAL int checkeof P1H(LVAL);
LOCAL int readone P2H(LVAL, LVAL *);
#ifdef PACKAGES
LOCAL int pname P3H(LVAL, int *, int *);
#else
LOCAL int pname P2H(LVAL, int *);
#endif /* PACKAGES */
LOCAL VOID defmacro P3H(int, LVAL, int);
#ifdef BIGNUMS
LOCAL int isadigit P2H(char, int);
LOCAL LVAL convertnumber P2H(char *, int);
#endif
#ifdef PRINTCIRCLE
LOCAL LVAL findcircval P2H(int, LVAL);
LOCAL VOID cleancircle P2H(LVAL, LVAL);
LOCAL VOID circpush P3H(LVAL, LVAL, LVAL *);
LOCAL VOID registercirc P2H(LVAL, LVAL);
#endif /* PRINTCIRCLE */
/* xlload - load a file of xlisp expressions */
int xlload P3C(char *, fname, int, vflag, int, pflag)
{
char fullname[STRMAX+1];
LVAL fptr,expr;
CONTEXT cntxt;
FILEP fp;
int sts, mask;
LVAL oldrtable = getvalue(s_rtable);
#ifdef PACKAGES
LVAL oldpack = getvalue(s_package);
#endif /* PACKAGES */
#if (! defined(XLISP_STAT) && ! defined(BYTECODE))
/* protect some pointers */
xlstkcheck(3);
xlsave(fptr);
xlsave(expr);
xlprotect(oldrtable);
#ifdef PACKAGES
xlprot1(oldpack);
#endif /* PACKAGES */
/* default the extension */
if (needsextension(fname)) {
strcpy(fullname,fname);
strcat(fullname,".lsp");
fname = fullname;
}
/* allocate a file node */
fptr = cvfile(CLOSED,S_FORREADING);
/* open the file */
#ifdef PATHNAMES
if ((fp = ospopen(fname,TRUE)) == CLOSED)
#else
if ((fp = OSAOPEN(fname,OPEN_RO)) == CLOSED)
#endif
{
xlpopn(3);
#ifdef PACKAGES
xlpop();
#endif /* PACKAGES */
return (FALSE);
}
setfile(fptr,fp);
#else
{
char origname[STRMAX+1];
int extend = needsextension(fname);
int done, Try;
#ifdef XLISP_STAT
extern LVAL s_default_path;
LVAL dp = getvalue(s_default_path);
#endif /* XLISP_STAT */
strcpy(origname, fname);
fname = fullname;
fp = CLOSED;
for (Try = 1, done = FALSE; ! done; Try++) {
switch (Try) {
case 1:
if (extend) {
strcpy(fullname, origname);
strcat(fullname, ".fsl");
break;
}
else Try++;
/* fall through */
case 2:
strcpy(fullname, origname);
if (extend)
strcat(fullname, ".lsp");
break;
#ifdef XLISP_STAT
case 3:
if (extend && stringp(dp)) {
strcpy(fullname, getstring(dp));
strcat(fullname, origname);
strcat(fullname, ".fsl");
break;
}
else Try++;
/* fall through */
case 4:
if (stringp(dp)) {
strcpy(fullname, getstring(dp));
strcat(fullname, origname);
if (extend)
strcat(fullname, ".lsp");
break;
}
else Try++;
/* fall through */
#endif /* XLISP_STAT */
default: done = TRUE;
}
if (! done)
if ((fp = OSAOPEN(fname,OPEN_RO)) != CLOSED)
done = TRUE;
}
}
if (fp == CLOSED)
return(FALSE);
/* protect some pointers */
xlstkcheck(3);
xlsave(fptr);
xlsave(expr);
xlprotect(oldrtable);
#ifdef PACKAGES
xlprot1(oldpack);
#endif /* PACKAGES */
/* allocate a file node */
fptr = cvfile(fp,S_FORREADING);
#endif /* XLISP_STAT */
/* print the information line */
if (vflag) /* TAA MOD -- changed from printing to stdout */
{ sprintf(buf,"; loading \"%s\"\n",fname); dbgputstr(buf); }
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR|CF_UNWIND,s_true); /*TAA mod so file gets closed*/
#ifdef CRAYCC
mask = XL_SETJMP(cntxt.c_jmpbuf); /* TAA mod -- save mask */
if (mask != 0)
#else
if ((mask = XL_SETJMP(cntxt.c_jmpbuf)) != 0) /* TAA mod -- save mask */
#endif /* CRAYCC */
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* restore the readtable and package */
setvalue(s_rtable, oldrtable);
#ifdef PACKAGES
setvalue(s_package, oldpack);
#endif /* PACKAGES */
/* close the file */
OSCLOSE(getfile(fptr));
setfile(fptr,CLOSED);
/* restore the stack */
xlpopn(3);
#ifdef PACKAGES
xlpop();
#endif /* PACKAGES */
/* check for unwind protect TAA MOD */
if ((mask & ~CF_ERROR) != 0)
xljump(xltarget, xlmask, xlvalue);
/* return status */
return (sts);
}
#ifdef PRINTCIRCLE
#define PCHSIZE 31
#define circvalp(x) (consp(x) && car(x) == car(data))
#define circindex(x) (getfixnum(cdr(x)))
LOCAL LVAL findcircval P2C(int, n, LVAL, data)
{
LVAL next;
for (next = cdr(cdr(data)); consp(next); next = cdr(next)) {
if (consp(car(next)) && fixp(car(car(next)))) {
if (getfixnum(car(car(next))) == n)
return cdr(car(next));
}
}
xlerror("bad circle read index", cvfixnum((FIXTYPE) n));
return(NIL);
}
LOCAL VOID circpush P3C(LVAL, val, LVAL, table, LVAL *, ptodo)
{
LVAL next;
int i;
switch (ntype(val)) {
case CONS:
case DARRAY:
case RNDSTATE:
case ARRAY:
case OBJECT:
case VECTOR:
case STRUCT:
#ifdef BYTECODE
case CPSNODE:
case BCODE:
#endif /* BYTECODE */
#ifdef HASHFCNS
if (structp(val) && getelement(val,0) == a_hashtable)
break;
#endif
i = (int) (CVPTR(val) % PCHSIZE);
for (next = getelement(table, i); consp(next); next = cdr(next))
if (car(next) == val)
return;
*ptodo = cons(val, *ptodo);
}
}
LOCAL VOID registercirc P2C(LVAL, entry, LVAL, table)
{
int i = (int) (CVPTR(car(entry)) % PCHSIZE);
rplacd(entry, getelement(table, i));
setelement(table, i, entry);
}
LOCAL VOID cleancircle P2C(LVAL, val, LVAL, data)
{
LVAL todo, table, entry, next;
int i, changed;
if (null(car(cdr(data)))) return;
switch (ntype(val)) {
case SUBR:
case FSUBR:
case FIXNUM:
case FLONUM:
#ifdef BIGNUMS
case RATIO:
case BIGNUM:
#endif /* BIGNUMS */
case STREAM:
case CHAR:
case USTREAM:
case COMPLEX:
#ifdef BYTECODE
case BCCLOSURE:
#endif /* BYTECODE */
case CLOSURE:
case STRING:
case ADATA:
case TVEC:
case NATPTR:
case WEAKBOX:
case SYMBOL:
#ifdef PACKAGES
case PACKAGE:
#endif /* PACKAGES */
return;
}
xlstkcheck(2);
xlsave(todo);
xlsave(table);
table = newvector(PCHSIZE);
do {
changed = FALSE;
todo = consa(val);
for (i = 0; i < PCHSIZE; i++)
setelement(table, i, NIL);
while (consp(todo)) {
entry = todo;
next = car(todo);
todo = cdr(todo);
switch (ntype(next)) {
case CONS:
case DARRAY:
case RNDSTATE:
registercirc(entry, table);
if (circvalp(car(next))) {
rplaca(next, findcircval(circindex(car(next)), data));
changed = TRUE;
}
circpush(car(next), table, &todo);
if (circvalp(cdr(next))) {
rplacd(next, findcircval(circindex(cdr(next)), data));
changed = TRUE;
}
circpush(cdr(next), table, &todo);
break;
case ARRAY:
case OBJECT:
case VECTOR:
case STRUCT:
#ifdef BYTECODE
case CPSNODE:
case BCODE:
#endif /* BYTECODE */
#ifdef HASHFCNS
if (structp(next) && getelement(next,0) == a_hashtable)
break;
#endif
{
int i, n;
registercirc(entry, table);
for (i = 0, n = getsize(next); i < n; i++) {
if (circvalp(getelement(next, i))) {
setelement(next, i,
findcircval(circindex(getelement(next, i)), data));
changed = TRUE;
}
circpush(getelement(next, i), table, &todo);
}
}
break;
}
}
} while (changed);
xlpopn(2);
}
#endif /* PRINTCIRCLE */
/* xlread - read an xlisp expression */
int xlread P4C(LVAL, fptr, LVAL *, pval, int, rflag, int, pwflag)
{
int sts;
LVAL olddenv = xldenv;
#ifdef PRINTCIRCLE
if (! rflag)
xldbind(s_rdcircdat, cons(consa(NIL),consa(NIL)));
#endif /* PRINTCIRCLE */
if (!rflag) xldbind(a_readpw, (pwflag ? s_true : NIL));
/* read an expression */
while ((sts = readone(fptr,pval)) == FALSE)
;
#ifdef PRINTCIRCLE
if (! rflag)
cleancircle(*pval, getvalue(s_rdcircdat));
#endif /* PRINTCIRCLE */
/* unbind a_readpw if necessary */
xlunbind(olddenv);
/* return status */
return (sts == EOF ? FALSE : TRUE);
}
/* readone - attempt to read a single expression */
LOCAL int readone P2C(LVAL, fptr, LVAL *, pval)
{
LVAL val,type;
int ch;
#ifdef STSZ
/* check the stack */
stchck();
#endif
/* 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 */
/* handle single and multiple escapes */ /* combined by TAA MOD */
else if (type == k_const ||
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)) != NIL) && consp(val)) {
*pval = car(val);
return (TRUE);
}
else
return (FALSE);
}
/* handle illegal characters */
else {
/* xlerror("illegal character",cvfixnum((FIXTYPE)ch)); */
xlerror("illegal character",cvchar(ch)); /* friendlier TAA MOD*/
return (0); /* compiler warning */
}
}
/* rmhash - read macro for '#' */
LVAL rmhash(V)
{
LVAL fptr,val;
char *bufp; /* TAA fix to allow control character literals */
int i;
int ch;
#ifdef __SASC__
int testch;
#endif
/* protect some pointers */
xlsave1(val);
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* make the return value */
val = consa(NIL);
/* check the next character */
switch (ch = xlgetc(fptr)) {
case '\'':
rplaca(val,pquote(fptr,s_function));
break;
case '(':
xlungetc(fptr,ch);
rplaca(val,pvector(fptr));
break;
case '.':
if (! null(getvalue(s_read_suppress))) {
rplaca(val,NIL);
break;
}
if (readone(fptr,&car(val)) == EOF)
badeof(); /* Check added 3/98 */
rplaca(val,xleval(car(val)));
break;
case 'b':
case 'B':
rplaca(val,pnumber(fptr,2));
break;
case 'o':
case 'O':
rplaca(val,pnumber(fptr,8));
break;
case 'd': /* added for version 2.1h */
case 'D':
rplaca(val,pnumber(fptr,10));
break;
case 'x':
case 'X':
rplaca(val,pnumber(fptr,16));
break;
case 's':
case 'S':
rplaca(val,pstruct(fptr));
break;
case '\\':
for (i = 0; i < STRMAX-1; i++) {
ch = xlgetc(fptr); /* TAA fix to scan at end of file */
if (ch == EOF ||
(buf[i] = ch,
((tentry((unsigned char)(buf[i])) != k_const) &&
(i > 0) && /* TAA fix for left and right paren */
buf[i] != '\\' && buf[i] != '|'))) {
xlungetc(fptr, buf[i]);
break;
}
}
if (! null(getvalue(s_read_suppress))) {
rplaca(val,NIL);
break;
}
buf[i] = 0;
ch = (unsigned char)buf[0];
#ifdef __SASC__
testch = etoa(ch);
#endif
if (strlen(buf) > (unsigned)1) { /* TAA Fixed */
i = buf[strlen(buf)-1]; /* Value of last character */
upcase(buf);
bufp = &buf[0];
#ifdef __SASC__ /* EBCDIC */
testch = 0;
if (strncmp(bufp,"M-",2) == 0) {
testch = 128;
bufp += 2;
}
if (strcmp(bufp,"NEWLINE") == 0)
testch += 0x0a;
else if (strcmp(bufp,"SPACE") == 0)
testch += 0x20;
else if (strcmp(bufp,"RUBOUT") == 0)
ch += 127;
else if (strlen(bufp) == 1)
ch += i;
else if (strncmp(bufp,"C-",2) == 0 && strlen(bufp) == 3)
testch += etoa(bufp[2]) & 31;
else xlerror("unknown character name",cvstring(buf));
ch = testch;
#else
ch = 0;
if (strncmp(bufp,"M-",2) == 0) {
ch = 128;
bufp += 2;
}
if (strcmp(bufp,"NEWLINE") == 0)
ch += '\n';
else if (strcmp(bufp,"SPACE") == 0)
ch += ' ';
else if (strcmp(bufp,"RUBOUT") == 0)
ch += 127;
else if (strcmp(bufp,"PAGE") == 0)
ch += 12;
else if (strcmp(bufp,"TAB") == 0)
ch += '\t';
else if (strcmp(bufp,"BACKSPACE") == 0)
ch += 8;
else if (strcmp(bufp,"RETURN") == 0)
ch += 13;
else if (strcmp(bufp,"LINEFEED") == 0)
ch += 10;
else if (strcmp(bufp,"ESCAPE") == 0)
ch += 27;
else if (strlen(bufp) == 1)
ch += i;
else if (strncmp(bufp,"C-",2) == 0 && strlen(bufp) == 3)
ch += bufp[2] & 31;
/* for Macintosh check mark character */
else if (strcmp(bufp,"CHECK") == 0)
ch += 0x12;
/* for Macintosh Apple character */
else if (strcmp(bufp,"APPLE") == 0)
ch += 0x14;
else xlerror("unknown character name",cvstring(buf));
#endif
}
#ifdef __SASC__
rplaca(val, cvchar(atoe(testch)));
#else
rplaca(val,cvchar(ch));
#endif
break;
case ':':
rplaca(val,punintern(fptr));
break;
case '|':
pcomment(fptr);
val = NIL;
break;
case 'c':
case 'C': /* From XLISP-STAT, Copyright (c) 1988, Luke Tierney */
{
LVAL list;
if (readone(fptr, &list) == EOF)
badeof(); /* check added 3/98 */
if (! consp(list) || ! consp(cdr(list)) || cdr(cdr(list)) != NIL)
xlerror("bad complex number specification", list);
rplaca(val, newcomplex(car(list), car(cdr(list))));
break;
}
case '+': /* From XLISP-STAT, Copyright (c) 1988, Luke Tierney */
case '-':
{
LVAL arg;
int sts; /* added eof check 3/98 */
LVAL olddenv;
xlsave1(arg);
olddenv = xldenv;
xldbind(s_package, xlkeypack);
while (! (sts = readone(fptr, &arg)));
xlunbind(olddenv);
if (sts == EOF) badeof();
if (null(getvalue(s_read_suppress)) && checkfeatures(arg, ch)) {
while (! (sts = readone(fptr, &arg)));
if (sts==EOF) badeof();
rplaca(val, arg);
}
else {
olddenv = xldenv;
xldbind(s_read_suppress, s_true);
while (! (sts = readone(fptr, &arg)));
if (sts==EOF) badeof();
val = NIL;
xlunbind(olddenv);
}
xlpop();
break;
}
/*************************************************************************/
/* Lines below added to allow for common lisp arrays */
/* Luke Tierney, March 1, 1988 */
/*************************************************************************/
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
{
int rank = 0;
while (isdigit(ch)) {
rank = 10 * rank + ch - '0';
ch = xlgetc(fptr);
}
#ifdef PRINTCIRCLE
if (ch == '=') {
LVAL data;
if (! boundp(s_rdcircdat)) xlfail("no top level read");
if (!xlread(fptr,&val,TRUE,FALSE))
badeof();
data = getvalue(s_rdcircdat);
rplacd(cdr(data), cons(cons(cvfixnum((FIXTYPE) rank),val),
cdr(cdr(data))));
val = consa(val);
}
else if (ch == '#') {
LVAL next;
int found = FALSE;
if (! boundp(s_rdcircdat)) xlfail("no top level read");
for (next = cdr(cdr(getvalue(s_rdcircdat)));
consp(next);
next = cdr(next)) {
if (consp(car(next)) && fixp(car(car(next)))) {
if (getfixnum(car(car(next))) == rank) {
found = TRUE;
val = consa(cdr(car(next)));
break;
}
}
}
if (! found) {
rplaca(cdr(getvalue(s_rdcircdat)), s_true);
val = consa(cons(car(getvalue(s_rdcircdat)),
cvfixnum((FIXTYPE) rank)));
}
}
else
#endif /* PRINTCIRCLE */
if ((ch == 'A') || (ch == 'a')) {
readone(fptr, &val);
val = nested_list_to_array(val, rank);
val = consa(val);
}
else if ((ch == 'r' || ch == 'R')) {
if (rank < 2 || rank > 36)
xlfail("bad radix specifier");
rplaca(val, pnumber(fptr, rank));
}
else
xlfail("incomplete array specification");
}
break;
/*************************************************************************/
/* Lines above added to allow for common lisp arrays */
/* Luke Tierney, March 1, 1988 */
/*************************************************************************/
#ifdef BYTECODE
case 'k':
case 'K':
{
LVAL olddenv = xldenv;
LVAL arg;
xlsave1(arg);
xldbind(s_rtcase, k_upcase);
xldbind(s_rtable, getvalue(s_stdrtable));
xldbind(s_read_suppress, NIL);
readone(fptr, &arg);
xlunbind(olddenv);
rplaca(val, xlapplysubr(xlmakebcode, arg));
xlpop();
}
break;
#endif /* BYTECODE */
case '$':
{
LVAL arg, *oldargv, *oldsp;
int oldargc;
xlsave1(arg);
oldargv = xlargv;
oldargc = xlargc;
oldsp = xlsp;
xlargv = xlsp;
readone(fptr, &arg);
pusharg(s_true);
xlargc = 1;
for (; consp(arg); arg = cdr(arg)) {
pusharg(car(arg));
xlargc++;
}
rplaca(val, xmkrndstate());
xlsp = oldsp;
xlargc = oldargc;
xlargv = oldargv;
xlpop();
}
break;
case EOF: /* added 3/98 */
badeof();
default:
/* xlerror("illegal character after #",cvfixnum((FIXTYPE)ch)); */
xlerror("illegal character after #",cvchar(ch)); /*TAA Mod */
}
/* restore the stack */
xlpop();
/* return the value */
return (val);
}
/* rmquote - read macro for '\'' */
LVAL rmquote(V)
{
LVAL fptr;
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* parse the quoted expression */
return (consa(pquote(fptr,s_quote)));
}
/* rmdquote - read macro for '"' */
LVAL rmdquote(V)
{
char buf[STRMAX+1],*p, *sptr;
LVAL fptr,str,newstr;
int len,blen,ch,d2,d3;
/* protect some pointers */
xlsave1(str);
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* 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 = newstring(len + STRMAX);
sptr = getstring(newstr);
if (str != NIL)
MEMCPY(sptr, getstring(str), len);
*p = '\0';
MEMCPY(sptr+len, buf, blen+1);
p = buf;
blen = 0;
len += STRMAX;
str = newstr;
}
/* store the character */
*p++ = ch; ++blen;
}
/* append the last substring */
if (str == NIL || blen) {
newstr = newstring(len + blen);
sptr = getstring(newstr);
if (str != NIL) MEMCPY(sptr, getstring(str), len);
*p = '\0';
MEMCPY(sptr+len, buf, blen+1);
str = newstr;
}
/* restore the stack */
xlpop();
/* return the new string */
return (consa(str));
}
/* rmbquote - read macro for '`' */
LVAL rmbquote(V)
{
LVAL fptr;
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* parse the quoted expression */
return (consa(pquote(fptr,s_bquote)));
}
/* rmcomma - read macro for ',' */
LVAL rmcomma(V)
{
LVAL fptr,sym;
int ch;
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* check the next character */
if ((ch = xlgetc(fptr)) == '@' || ch == '.')
sym = s_comat;
else {
xlungetc(fptr,ch);
sym = s_comma;
}
/* make the return value */
return (consa(pquote(fptr,sym)));
}
/* rmlpar - read macro for '(' */
LVAL rmlpar(V)
{
LVAL fptr;
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* make the return value */
return (consa(plist(fptr)));
}
/* rmrpar - read macro for ')' */
LVAL rmrpar(V)
{
xlfail("misplaced close paren");
return (NIL); /* never returns */
}
/* rmsemi - read macro for ';' */
LVAL rmsemi(V)
{
LVAL fptr;
int ch;
/* get the file and macro character */
fptr = xlgetarg(); /* internal -- don't bother with error checks */
/* 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 P1C(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 */
#ifdef BIGNUMS
LOCAL LVAL convertnumber(buf, radix)
char *buf; int radix;
{
if (radix==10 && strlen(buf) < 10) {
/* take shortcut */
return cvfixnum(ICNV(buf));
}
else {
LVAL x;
FIXTYPE temp;
x = cvtstrbignum(buf, radix);
return (cvtbigfixnum(x, &temp) ? cvfixnum(temp) : x);
}
}
LOCAL LVAL pnumber P2C(LVAL, fptr, int, radix)
{
int i=0; /* index into buffer */
int digits=0; /* number of digits so far */
int ch;
LVAL resulta = NULL, resultb;
while ((ch = xlgetc(fptr)) != EOF && i < STRMAX) {
if (i == 0 && ch == '+') { /* ignore leading + */
i++;
continue;
}
if (i == 0 && ch == '-') { /* negative number */
buf[i++] = ch;
continue;
}
if (ch == '/' && resulta==NULL) { /* a ratio */
buf[i] = '\0';
if (digits==0) xlfail("unrecognized number");
digits = i = 0;
resulta = cvtstrbignum(buf, radix); /* do numerator */
continue;
}
if (isadigit(ch, radix)) { /* number constituent */
buf[i++] = ch;
digits++;
continue;
}
break; /* invalid character terminates number */
}
xlungetc(fptr,ch);
if (i == STRMAX) xlfail("number too long to process");
if (digits==0) xlfail("unrecognized number");
buf[i] = '\0';
if (resulta) { /* finish up a ratio */
xlprot1(resulta);
resultb = cvtstrbignum(buf, radix);
xlpop();
if (zeropbignum(resultb)) xlfail("invalid ratio");
return cvbratio(resulta, resultb);
}
return convertnumber(buf, radix);
}
#else
LOCAL LVAL pnumber P2C(LVAL, fptr, int, radix)
{
int digit,ch;
long num;
for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
if (ISLOWER7(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));
}
#endif
/* plist - parse a list */
LOCAL LVAL plist P1C(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();
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,FALSE))
badeof();
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 P1C(LVAL, fptr)
{
LVAL list,val;
int len,i;
/* protect some pointers */
xlsave1(list);
/* read the list */
list = readlist(fptr,&len);
/* 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 */
xlpop();
/* return successfully */
return (val);
}
/* pstruct - parse a structure */
LOCAL LVAL pstruct P1C(LVAL, fptr)
{
LVAL list,val;
int len;
/* protect some pointers */
xlsave1(list);
/* read the list */
list = readlist(fptr,&len);
/* make the structure */
val = xlrdstruct(list);
/* restore the stack */
xlpop();
/* return successfully */
return (val);
}
/* pquote - parse a quoted expression */
LOCAL LVAL pquote P2C(LVAL, fptr, LVAL, sym)
{
LVAL val,p;
int sts; /* EOF checking added 3/98 */
/* protect some pointers */
xlsave1(val);
/* allocate two nodes */
val = consa(sym);
rplacd(val,consa(NIL));
/* initialize the second to point to the quoted expression */
while ((sts = readone(fptr,&p)) == FALSE);
if (sts == EOF)
badeof();
rplaca(cdr(val),p);
/* restore the stack */
xlpop();
/* return the quoted expression */
return (val);
}
/* psymbol - parse a symbol name */
#ifdef PACKAGES
LOCAL LVAL psymbol P1C(LVAL, fptr)
{
int escflag, packindex;
LVAL val, pack;
int colons;
char *p;
pname(fptr,&escflag,&packindex);
if (! null(getvalue(s_read_suppress))) return(NIL);
if (escflag || packindex >= 0 || !xlisnumber(buf,&val)) {
if (packindex >= 0) {
/* check for zero-length name */
if (buf[packindex+1] == 0) xlfail("zero length name after ':'");
if (packindex == 0) {
/* count the colons */
for (p = buf + packindex + 1, colons = 1; *p == ':'; p++, colons++);
if (colons > 2) xlfail("too many :'s");
val = xlintern(p, xlkeypack);
}
else {
/* find the package */
buf[packindex] = 0;
pack = xlfindpackage(buf);
if (! packagep(pack))
xlerror("package not found", cvstring(buf));
/* count the colons and switch */
for (p = buf + packindex + 1, colons = 1; *p == ':'; p++, colons++);
switch (colons) {
case 1:
if (xlfindsymbol(p, pack, &val) != SYM_EXTERNAL)
xlerror("external symbol not found", cvstring(p));
break;
case 2:
val = xlintern(p, pack);
break;
default: xlfail("too many :'s");
}
}
}
else {
pack = getvalue(s_package);
return(goodpackagep(pack) ? xlintern(buf, pack) : NIL);
}
}
return(val);
}
#else
LOCAL LVAL psymbol P1C(LVAL, fptr)
{
int escflag;
LVAL val;
pname(fptr,&escflag);
if (! null(getvalue(s_read_suppress))) return(NIL);
return (escflag || !xlisnumber(buf,&val) ? xlenter(buf) : val);
}
#endif /* PACKAGES */
/* punintern - parse an uninterned symbol */
#ifdef PACKAGES
LOCAL LVAL punintern P1C(LVAL, fptr)
{
int escflag,packindex;
pname(fptr,&escflag,&packindex);
return (xlmakesym(buf));
}
#else
LOCAL LVAL punintern P1C(LVAL, fptr)
{
int escflag;
pname(fptr,&escflag);
return (xlmakesym(buf));
}
#endif /* PACKAGES */
/* pname - parse a symbol/package name */
#ifdef PACKAGES
LOCAL int pname P3C(LVAL, fptr, int *, pescflag, int *, ppackindex)
#else
LOCAL int pname P2C(LVAL, fptr, int *, pescflag)
#endif /* PACKAGES */
{
int mode, ch = 0, i;
LVAL type;
#ifdef READTABLECASE
LVAL rtcase = getvalue(s_rtcase);
int low=0, up=0;
#endif
/* initialize */
*pescflag = FALSE;
#ifdef PACKAGES
*ppackindex = -1;
#endif /* PACKAGES */
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) {
storech(&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))
#ifdef PACKAGES
{
if (ch == ':') {
if (*ppackindex < 0) *ppackindex = i;
storech(&i,ch);
}
else
#endif /* PACKAGES */
#ifdef READTABLECASE
{
if (rtcase == k_preserve)
storech(&i,ch);
else if (rtcase == k_downcase)
storech(&i,ISUPPER(ch) ? TOLOWER(ch) : ch);
else if (rtcase == k_invert)
storech(&i,ISLOWER(ch) ? (low++, TOUPPER(ch)) :
(ISUPPER(ch) ? (up++, TOLOWER(ch)) : ch));
else /* default upcase */
storech(&i,ISLOWER(ch) ? TOUPPER(ch) : ch);
}
#else
storech(&i,ISLOWER(ch) ? TOUPPER(ch) : ch);
#endif
#ifdef PACKAGES
}
#endif /* PACKAGES */
else
mode = DONE;
/* handle multiple escape mode */
while (mode == ESCAPE)
if ((ch = xlgetc(fptr)) == EOF)
badeof();
else if ((type = tentry(ch)) == k_sescape)
storech(&i,checkeof(fptr));
else if (type == k_mescape)
mode = NORMAL;
else
storech(&i,ch);
}
buf[i] = 0;
#ifdef READTABLECASE /* TAA Mod, sorta fixing a bug */
if (rtcase == k_invert && low != 0 && up != 0) {
/* must undo inversion (ugh!). Unfortunately, we don't know if
any characters are quoted, so we'll just label this bug as
a feature in the manual. The problem will only occur in symbols
with mixed case characters outside of quotes and at least one
quoted alpha character -- not very likely, I hope. */
int cnt, c;
for (cnt = 0; cnt < i; cnt++ ) {
c = buf[cnt];
if (ISUPPER(c)) buf[cnt] = TOLOWER(c);
else if (ISLOWER(c)) buf[cnt] = TOUPPER(c);
}
}
#endif
/* check for a zero length name */
if (i == 0)
xlfail("zero length name"); /* TAA fix, Jeff Prothero improved*/
/* unget the last character and return it */
if (tentry(ch) != k_wspace || ! null(getvalue(a_readpw)))
xlungetc(fptr, ch);
return (ch);
}
/* readlist - read a list terminated by a ')' */
LOCAL LVAL readlist P2C(LVAL, fptr, int *, plen)
{
LVAL list,expr,lastnptr,nptr;
int ch;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(expr);
/* get the open paren */
if ((ch = nextch(fptr)) != '(')
xlfail("expecting an open paren");
xlgetc(fptr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
/* check for end of file */
if (ch == EOF)
badeof();
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof();
case TRUE:
nptr = consa(expr);
if (lastnptr == NIL)
list = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
++(*plen);
break;
}
}
/* skip the closing paren */
xlgetc(fptr);
/* restore the stack */
xlpopn(2);
/* return the list */
return (list);
}
/* storech - store a character in the print name buffer */
/* TAA MOD -- since buffer is always global buf, it is no longer passed
as argument. also return value is stored in i, so i is now address of
the int rather than its value */
LOCAL VOID storech P2C(int *, i, int, ch)
{
if (*i < STRMAX)
buf[(*i)++] = ch;
}
/* tentry - get a readtable entry */
LVAL tentry P1C(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 P1C(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 P1C(LVAL, fptr)
{
int ch;
if ((ch = xlgetc(fptr)) == EOF)
badeof();
return (ch);
}
/* badeof - unexpected eof */
LOCAL VOID badeof(V)
{
xlfail("EOF reached before expression end");
}
/* xlisnumber - check if this string is a number */
#define DBL_DIGITS 50
#ifdef BIGNUMS
LOCAL int isadigit P2C(char, c, int, r)
{
if (isdigit(c)) return ((c - '0') < r);
else if (ISLOWER7(c)) return ((c + 10 - 'a') < r);
else if (isupper(c)) return ((c + 10 - 'A') < r);
return 0;
}
int xlisnumber P2C(char *, str, LVAL *, pval)
{
int dl=0, dr=0;
char *p = str;
char *denp = NULL; /* pointer to denominator string */
int ratio=0; /* flag */
int badratio=0; /* set if invalid ratio (upon conversion) */
int radix = 10;
FIXTYPE numbr; /* converted integer */
LVAL numerp, denomp; /* in case it is a a bignum/ratio */
int eoff = 0; /* added to handle 'D' */
numerp = getvalue(s_readbase);
if (fixp(numerp)) {
numbr = getfixnum(numerp);
if (numbr <2 || numbr > 36) radix = 10;
else radix = (int)numbr;
}
/* check for a sign */
if (*p == '+' || *p == '-') p++;
/* check for a string of constituent digits */
if (radix==10) while (isdigit(*p)) p++, dl++;
else while (isadigit(*p, radix)) p++, dl++;
if (*p == '/') { /* check for a ratio */
if (dl == 0) return FALSE;
p++;
denp = p; /* save start of denominator */
if (radix == 10) {
while (isdigit(*p)) {
if (*p++ != 0) ratio = 1;
dr++;
}
}
else {
while (isadigit(*p, radix)) {
if (*p++ != 0) ratio = 1;
dr++;
}
}
if (dr == 0) return FALSE;
badratio = !ratio;
ratio = 1; /* providing there was no junk at the end */
}
else if (*p != '\0') { /* failed to complete scan */
radix = 10;
if (*p == '.' && p[1] == '\0') {
p++; /* a forced decimal number that scanned */
}
else { /* force decimal and start all over */
p = str;
dr = dl = 0;
/* check for a sign */
if (*p == '+' || *p == '-') p++;
/* check for a string of constituent digits */
while (isdigit(*p)) p++, dl++;
/* check for a decimal point */
if (*p == '.') {
p++;
while (isdigit(*p)) p++, dr++;
}
/* check for an exponent */
#ifdef READTABLECASE
if ((dl || dr) && *p && strchr("esfdlESFDL", *p))
#else
if ((dl || dr) && *p && strchr("ESFDL", *p))
#endif
{
eoff = p - str;
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 != NULL) {
if (*str == '+') ++str;
if (str[strlen(str)-1] == '.') {
str[strlen(str)-1] = '\0';
}
if (ratio) {
if (badratio) xlerror ("invalid rational number", cvstring (str));
*(denp-1) = '\0'; /* delimit numerator string */
xlsave1(numerp);
numerp = cvtstrbignum(str, radix);
denomp = cvtstrbignum(denp, radix);
xlpop();
if (zeropbignum(denomp)) xlerror("invalid rational number", cvstring(str));
*pval = cvbratio(numerp, denomp);
}
else if (dr) {
char buf[DBL_DIGITS + 1];
strncpy(buf, str, DBL_DIGITS);
buf[DBL_DIGITS] = 0;
if (eoff && eoff < DBL_DIGITS)
buf[eoff] = 'E';
*pval = cvflonum(atof(buf));
}
else {
*pval = convertnumber(str, radix);
}
}
return (TRUE);
}
#else
int xlisnumber P2C(char *, str, LVAL *, pval)
{
int dl=0, dr=0;
char *p = str;
int eoff = 0; /* added to handle 'D' */
/* 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 */
#ifdef READTABLECASE
if ((dl || dr) && *p && strchr("esfdlESFDL", *p))
#else
if ((dl || dr) && *p && strchr("ESFDL", *p))
#endif
{
eoff = p - str;
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 != NULL) {
if (*str == '+') ++str;
if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
if (dr) {
char buf[DBL_DIGITS + 1];
strncpy(buf, str, DBL_DIGITS);
buf[DBL_DIGITS] = 0;
if (eoff && eoff < DBL_DIGITS)
buf[eoff] = 'E';
*pval = cvflonum(atof(buf));
}
else
*pval = cvfixnum(ICNV(str));
}
return (TRUE);
}
#endif
/* defmacro - define a read macro */
LOCAL VOID defmacro P3C(int, ch, LVAL, type, int, offset)
{
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 */
LOCAL LVAL callmacro P2C(LVAL, fptr, int, ch)
{
FRAMEP 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 P1C(char *, str)
{
for (; *str != '\0'; ++str)
if (ISLOWER7(*str))
*str = toupper(*str);
}
/* xlrinit - initialize the reader */
VOID xlrinit(V)
{
LVAL rtable;
char *p;
int ch;
/* create the read table */
rtable = newvector(256);
setsvalue(s_rtable,rtable);
/* initialize the readtable */
for (p = WSPACE; (ch = *p++) != 0; )
setelement(rtable,ch,k_wspace);
for (p = CONST1; (ch = *p++) != 0; )
setelement(rtable,ch,k_const);
for (p = CONST2; (ch = *p++) != 0; )
setelement(rtable,ch,k_const);
#ifdef ASCII8
/* TAA MOD (8/92) to make extended ASCII character constituent */
for (ch=128; ch < 255; ch++)
setelement(rtable,ch,k_const);
#endif
/* 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);
#ifdef BYTECODE
defconstant(s_stdrtable,copyvector(rtable));
#endif /* BYTECODE */
}
syntax highlighted by Code2HTML, v. 0.9.1