char *
read_token(void)
{
int c;
int left_paren = 0;
char *p;
p = poolp;
c = readc();
while (isspace(c))
c = readc();
do {
if (c == '(') {
left_paren++;
pushc(c);
} else if (c == ')') {
if (left_paren == 0) {
break;
} else {
left_paren--;
pushc(c);
}
} else if (isspace(c) && left_paren == 0) {
do
c = readc();
while (isspace(c));
break;
} else if (c == '@') {
c = readc();
if (c == '\'') {
(void)read_symbol(0);
poolp--;
} else if (c == '[') {
(void)read_symbol(1);
poolp--;
} else if (c == '@') {
pushc(c);
} else {
char *name;
unreadc(c);
poolp = name = read_function();
(void)translate_function(poolp);
}
} else {
pushc(c);
}
c = readc();
} while (1);
unreadc(c);
pushc('\0');
return(p);
}
struct blk *
readin(void){
register struct blk *p,*q;
int dp,dpct;
register int c;
dp = dpct=0;
p = salloc(0);
while(1){
c = readc();
switch(c){
case '.':
if(dp != 0){
unreadc(c);
break;
}
dp++;
continue;
case '\\':
readc();
continue;
default:
if(c >= 'A' && c <= 'F')c = c - 'A' + 10;
else if(c >= '0' && c <= '9')c -= '0';
else goto gotnum;
if(dp != 0){
if(dpct >= 99)continue;
dpct++;
}
create(chptr);
if(c != 0)sputc(chptr,c);
q = mult(p,inbas);
release(p);
p = add(chptr,q);
release(q);
}
}
gotnum:
unreadc(c);
if(dp == 0){
sputc(p,0);
return(p);
}
else{
q = scale(p,dpct);
return(q);
}
}
void
get_return(void)
{
int c;
nres = 0;
for (;;) {
if ((c = nextc()) == ')')
return;
unreadc(c);
result[nres++] = read_token();
}
}
char *
read_function()
{
char c, *name = poolp;
c = readc();
if (c == '"') {
c = readc();
while (c != '"') {
pushc(c);
c = readc();
}
pushc(0);
return name;
}
while (c != '(' && !isspace(c) && c != ')' && c != ',') {
if (c == '_') c = '-';
pushc(c);
c = readc();
}
unreadc(c);
pushc(0);
return name;
}
void
commnds(void)
{
Blk *p, *q, **ptr, *s, *t;
long l;
Sym *sp;
int sk, sk1, sk2, c, sign, n, d;
while(1) {
Bflush(&bout);
if(((c = readc())>='0' && c <= '9') ||
(c>='A' && c <='F') || c == '.') {
unreadc(c);
p = readin();
pushp(p);
continue;
}
switch(c) {
case ' ':
case '\t':
case '\n':
case -1:
continue;
case 'Y':
sdump("stk",*stkptr);
Bprint(&bout, "all %ld rel %ld headmor %ld\n",all,rel,headmor);
Bprint(&bout, "nbytes %ld\n",nbytes);
Bprint(&bout, "longest %ld active %ld maxsize %ld\n", longest,
active, maxsize);
Bprint(&bout, "new all %d rel %d copy %d more %d lbytes %d\n",
lall, lrel, lcopy, lmore, lbytes);
lall = lrel = lcopy = lmore = lbytes = 0;
continue;
case '_':
p = readin();
savk = sunputc(p);
chsign(p);
sputc(p,savk);
pushp(p);
continue;
case '-':
subt();
continue;
case '+':
if(eqk() != 0)
continue;
binop('+');
continue;
case '*':
arg1 = pop();
EMPTY;
arg2 = pop();
EMPTYR(arg1);
sk1 = sunputc(arg1);
sk2 = sunputc(arg2);
savk = sk1+sk2;
binop('*');
p = pop();
if(savk>k && savk>sk1 && savk>sk2) {
sclobber(p);
sk = sk1;
if(sk<sk2)
sk = sk2;
if(sk<k)
sk = k;
p = removc(p,savk-sk);
savk = sk;
sputc(p,savk);
}
pushp(p);
continue;
case '/':
casediv:
if(dscale() != 0)
continue;
binop('/');
if(irem != 0)
release(irem);
release(rem);
continue;
case '%':
if(dscale() != 0)
continue;
binop('/');
p = pop();
release(p);
if(irem == 0) {
sputc(rem,skr+k);
pushp(rem);
continue;
}
p = add0(rem,skd-(skr+k));
q = add(p,irem);
release(p);
release(irem);
sputc(q,skd);
pushp(q);
continue;
case 'v':
p = pop();
EMPTY;
savk = sunputc(p);
if(length(p) == 0) {
sputc(p,savk);
pushp(p);
continue;
}
if(sbackc(p)<0) {
error("sqrt of neg number\n");
}
if(k<savk)
n = savk;
else {
n = k*2-savk;
savk = k;
}
arg1 = add0(p,n);
arg2 = dcsqrt(arg1);
sputc(arg2,savk);
pushp(arg2);
continue;
case '^':
neg = 0;
arg1 = pop();
EMPTY;
if(sunputc(arg1) != 0)
error("exp not an integer\n");
arg2 = pop();
EMPTYR(arg1);
if(sfbeg(arg1) == 0 && sbackc(arg1)<0) {
neg++;
chsign(arg1);
}
if(length(arg1)>=3) {
error("exp too big\n");
}
savk = sunputc(arg2);
p = dcexp(arg2,arg1);
release(arg2);
rewind(arg1);
c = sgetc(arg1);
if(c == -1)
c = 0;
else
if(sfeof(arg1) == 0)
c = sgetc(arg1)*100 + c;
d = c*savk;
release(arg1);
/* if(neg == 0) { removed to fix -exp bug*/
if(k>=savk)
n = k;
else
n = savk;
if(n<d) {
q = removc(p,d-n);
sputc(q,n);
pushp(q);
} else {
sputc(p,d);
pushp(p);
}
/* } else { this is disaster for exp <-127 */
/* sputc(p,d); */
/* pushp(p); */
/* } */
if(neg == 0)
continue;
p = pop();
q = salloc(2);
sputc(q,1);
sputc(q,0);
pushp(q);
pushp(p);
goto casediv;
case 'z':
p = salloc(2);
n = stkptr - stkbeg;
if(n >= 100) {
sputc(p,n/100);
n %= 100;
}
sputc(p,n);
sputc(p,0);
pushp(p);
continue;
case 'Z':
p = pop();
EMPTY;
n = (length(p)-1)<<1;
fsfile(p);
backc(p);
if(sfbeg(p) == 0) {
if((c = sbackc(p))<0) {
n -= 2;
if(sfbeg(p) == 1)
n++;
else {
if((c = sbackc(p)) == 0)
n++;
else
if(c > 90)
n--;
}
} else
if(c < 10)
n--;
}
release(p);
q = salloc(1);
if(n >= 100) {
sputc(q,n%100);
n /= 100;
}
sputc(q,n);
sputc(q,0);
pushp(q);
continue;
case 'i':
p = pop();
EMPTY;
p = scalint(p);
release(inbas);
inbas = p;
continue;
case 'I':
p = copy(inbas,length(inbas)+1);
sputc(p,0);
pushp(p);
continue;
case 'o':
p = pop();
EMPTY;
p = scalint(p);
sign = 0;
n = length(p);
q = copy(p,n);
fsfile(q);
l = c = sbackc(q);
if(n != 1) {
if(c<0) {
sign = 1;
chsign(q);
n = length(q);
fsfile(q);
l = c = sbackc(q);
}
if(n != 1) {
while(sfbeg(q) == 0)
l = l*100+sbackc(q);
}
}
logo = log2(l);
obase = l;
release(basptr);
if(sign == 1)
obase = -l;
basptr = p;
outdit = bigot;
if(n == 1 && sign == 0) {
if(c <= 16) {
outdit = hexot;
fw = 1;
fw1 = 0;
ll = 70;
release(q);
continue;
}
}
n = 0;
if(sign == 1)
n++;
p = salloc(1);
sputc(p,-1);
t = add(p,q);
n += length(t)*2;
fsfile(t);
if(sbackc(t)>9)
n++;
release(t);
release(q);
release(p);
fw = n;
fw1 = n-1;
ll = 70;
if(fw>=ll)
continue;
ll = (70/fw)*fw;
continue;
case 'O':
p = copy(basptr,length(basptr)+1);
sputc(p,0);
pushp(p);
continue;
case '[':
n = 0;
p = salloc(0);
for(;;) {
if((c = readc()) == ']') {
if(n == 0)
break;
n--;
}
sputc(p,c);
if(c == '[')
n++;
}
pushp(p);
continue;
case 'k':
p = pop();
EMPTY;
p = scalint(p);
if(length(p)>1) {
error("scale too big\n");
}
rewind(p);
k = 0;
if(!sfeof(p))
k = sgetc(p);
release(scalptr);
scalptr = p;
continue;
case 'K':
p = copy(scalptr,length(scalptr)+1);
sputc(p,0);
pushp(p);
continue;
case 'X':
p = pop();
EMPTY;
fsfile(p);
n = sbackc(p);
release(p);
p = salloc(2);
sputc(p,n);
sputc(p,0);
pushp(p);
continue;
case 'Q':
p = pop();
EMPTY;
if(length(p)>2) {
error("Q?\n");
}
rewind(p);
if((c = sgetc(p))<0) {
error("neg Q\n");
}
release(p);
while(c-- > 0) {
if(readptr == &readstk[0]) {
error("readstk?\n");
}
if(*readptr != 0)
release(*readptr);
readptr--;
}
continue;
case 'q':
if(readptr <= &readstk[1])
exits(0);
if(*readptr != 0)
release(*readptr);
readptr--;
if(*readptr != 0)
release(*readptr);
readptr--;
continue;
case 'f':
if(stkptr == &stack[0])
Bprint(&bout,"empty stack\n");
else {
for(ptr = stkptr; ptr > &stack[0];) {
dcprint(*ptr--);
}
}
continue;
case 'p':
if(stkptr == &stack[0])
Bprint(&bout,"empty stack\n");
else {
dcprint(*stkptr);
}
continue;
case 'P':
p = pop();
EMPTY;
sputc(p,0);
Bprint(&bout,"%s",p->beg);
release(p);
continue;
case 'd':
if(stkptr == &stack[0]) {
Bprint(&bout,"empty stack\n");
continue;
}
q = *stkptr;
n = length(q);
p = copy(*stkptr,n);
pushp(p);
continue;
case 'c':
while(stkerr == 0) {
p = pop();
if(stkerr == 0)
release(p);
}
continue;
case 'S':
if(stkptr == &stack[0]) {
error("save: args\n");
}
c = getstk() & 0377;
sptr = stable[c];
sp = stable[c] = sfree;
sfree = sfree->next;
if(sfree == 0)
goto sempty;
sp->next = sptr;
p = pop();
EMPTY;
if(c >= ARRAYST) {
q = copy(p,length(p)+PTRSZ);
for(n = 0;n < PTRSZ;n++) {
sputc(q,0);
}
release(p);
p = q;
}
sp->val = p;
continue;
sempty:
error("symbol table overflow\n");
case 's':
if(stkptr == &stack[0]) {
error("save:args\n");
}
c = getstk() & 0377;
sptr = stable[c];
if(sptr != 0) {
p = sptr->val;
if(c >= ARRAYST) {
rewind(p);
while(sfeof(p) == 0)
release(dcgetwd(p));
}
release(p);
} else {
sptr = stable[c] = sfree;
sfree = sfree->next;
if(sfree == 0)
goto sempty;
sptr->next = 0;
}
p = pop();
sptr->val = p;
continue;
case 'l':
load();
continue;
case 'L':
c = getstk() & 0377;
sptr = stable[c];
if(sptr == 0) {
error("L?\n");
}
stable[c] = sptr->next;
sptr->next = sfree;
sfree = sptr;
p = sptr->val;
if(c >= ARRAYST) {
rewind(p);
while(sfeof(p) == 0) {
q = dcgetwd(p);
if(q != 0)
release(q);
}
}
pushp(p);
continue;
case ':':
p = pop();
EMPTY;
q = scalint(p);
fsfile(q);
c = 0;
if((sfbeg(q) == 0) && ((c = sbackc(q))<0)) {
error("neg index\n");
}
if(length(q)>2) {
error("index too big\n");
}
if(sfbeg(q) == 0)
c = c*100+sbackc(q);
if(c >= MAXIND) {
error("index too big\n");
}
release(q);
n = getstk() & 0377;
sptr = stable[n];
if(sptr == 0) {
sptr = stable[n] = sfree;
sfree = sfree->next;
if(sfree == 0)
goto sempty;
sptr->next = 0;
p = salloc((c+PTRSZ)*PTRSZ);
zero(p);
} else {
p = sptr->val;
if(length(p)-PTRSZ < c*PTRSZ) {
q = copy(p,(c+PTRSZ)*PTRSZ);
release(p);
p = q;
}
}
seekc(p,c*PTRSZ);
q = lookwd(p);
if(q!=0)
release(q);
s = pop();
EMPTY;
salterwd(p, s);
sptr->val = p;
continue;
case ';':
p = pop();
EMPTY;
q = scalint(p);
fsfile(q);
c = 0;
if((sfbeg(q) == 0) && ((c = sbackc(q))<0)) {
error("neg index\n");
}
if(length(q)>2) {
error("index too big\n");
}
if(sfbeg(q) == 0)
c = c*100+sbackc(q);
if(c >= MAXIND) {
error("index too big\n");
}
release(q);
n = getstk() & 0377;
sptr = stable[n];
if(sptr != 0){
p = sptr->val;
if(length(p)-PTRSZ >= c*PTRSZ) {
seekc(p,c*PTRSZ);
s = dcgetwd(p);
if(s != 0) {
q = copy(s,length(s));
pushp(q);
continue;
}
}
}
q = salloc(1); /*so uninitialized array elt prints as 0*/
sputc(q, 0);
pushp(q);
continue;
case 'x':
execute:
p = pop();
EMPTY;
if((readptr != &readstk[0]) && (*readptr != 0)) {
if((*readptr)->rd == (*readptr)->wt)
release(*readptr);
else {
if(readptr++ == &readstk[RDSKSZ]) {
error("nesting depth\n");
}
}
} else
readptr++;
*readptr = p;
if(p != 0)
rewind(p);
else {
if((c = readc()) != '\n')
unreadc(c);
}
continue;
case '?':
if(++readptr == &readstk[RDSKSZ]) {
error("nesting depth\n");
}
*readptr = 0;
fsave = curfile;
curfile = &bin;
while((c = readc()) == '!')
command();
p = salloc(0);
sputc(p,c);
while((c = readc()) != '\n') {
sputc(p,c);
if(c == '\\')
sputc(p,readc());
}
curfile = fsave;
*readptr = p;
continue;
case '!':
if(command() == 1)
goto execute;
continue;
case '<':
case '>':
case '=':
if(cond(c) == 1)
goto execute;
continue;
default:
Bprint(&bout,"%o is unimplemented\n",c);
}
}
}
void
commnds(void){
register int c;
register struct blk *p,*q;
long l;
int sign;
struct blk **ptr,*s,*t;
struct sym *sp;
int sk,sk1,sk2;
int n,d;
while(1){
if(((c = readc())>='0' && c <= '9')|| (c>='A' && c <='F') || c == '.'){
unreadc(c);
p = readin();
pushp(p);
continue;
}
switch(c){
case ' ':
case '\n':
case 0377:
case EOF:
continue;
case 'Y':
sdump("stk",*stkptr);
printf("all %ld rel %ld headmor %ld\n",all,rel,headmor);
printf("nbytes %ld\n",nbytes);
continue;
case '_':
p = readin();
savk = sunputc(p);
chsign(p);
sputc(p,savk);
pushp(p);
continue;
case '-':
subt();
continue;
case '+':
if(eqk() != 0)continue;
binop('+');
continue;
case '*':
arg1 = pop();
EMPTY;
arg2 = pop();
EMPTYR(arg1);
sk1 = sunputc(arg1);
sk2 = sunputc(arg2);
binop('*');
p = pop();
sunputc(p);
savk = n = sk1+sk2;
if(n>k && n>sk1 && n>sk2){
sk = sk1;
if(sk<sk2)sk = sk2;
if(sk<k)sk = k;
p = removc(p,n-sk);
savk = sk;
}
sputc(p,savk);
pushp(p);
continue;
case '/':
casediv:
if(dscale() != 0)continue;
binop('/');
if(irem != 0)release(irem);
release(rem);
continue;
case '%':
if(dscale() != 0)continue;
binop('/');
p = pop();
release(p);
if(irem == 0){
sputc(rem,skr+k);
pushp(rem);
continue;
}
p = add0(rem,skd-(skr+k));
q = add(p,irem);
release(p);
release(irem);
sputc(q,skd);
pushp(q);
continue;
case 'v':
p = pop();
EMPTY;
savk = sunputc(p);
if(length(p) == 0){
sputc(p,savk);
pushp(p);
continue;
}
if((c = sbackc(p))<0){
error("sqrt of neg number\n");
}
if(k<savk)n = savk;
else{
n = k*2-savk;
savk = k;
}
arg1 = add0(p,n);
arg2 = dcsqrt(arg1);
sputc(arg2,savk);
pushp(arg2);
continue;
case '^':
neg = 0;
arg1 = pop();
EMPTY;
if(sunputc(arg1) != 0)error("exp not an integer\n");
arg2 = pop();
EMPTYR(arg1);
if(sfbeg(arg1) == 0 && sbackc(arg1)<0){
neg++;
chsign(arg1);
}
if(length(arg1)>=3){
error("exp too big\n");
}
savk = sunputc(arg2);
p = dcexp(arg2,arg1);
release(arg2);
rewind(arg1);
c = sgetc(arg1);
if(sfeof(arg1) == 0)
c = sgetc(arg1)*100 + c;
d = c*savk;
release(arg1);
if(neg == 0){
if(k>=savk)n = k;
else n = savk;
if(n<d){
q = removc(p,d-n);
sputc(q,n);
pushp(q);
}
else {
sputc(p,d);
pushp(p);
}
}
else {
sputc(p,d);
pushp(p);
}
if(neg == 0)continue;
p = pop();
q = salloc(2);
sputc(q,1);
sputc(q,0);
pushp(q);
pushp(p);
goto casediv;
case 'z':
p = salloc(2);
n = stkptr - stkbeg;
if(n >= 100){
sputc(p,n/100);
n %= 100;
}
sputc(p,n);
sputc(p,0);
pushp(p);
continue;
case 'Z':
p = pop();
EMPTY;
n = (length(p)-1)<<1;
fsfile(p);
sbackc(p);
if(sfbeg(p) == 0){
if((c = sbackc(p))<0){
n -= 2;
if(sfbeg(p) == 1)n += 1;
else {
if((c = sbackc(p)) == 0)n += 1;
else if(c > 90)n -= 1;
}
}
else if(c < 10) n -= 1;
}
release(p);
q = salloc(1);
if(n >= 100){
sputc(q,n%100);
n /= 100;
}
sputc(q,n);
sputc(q,0);
pushp(q);
continue;
case 'i':
p = pop();
EMPTY;
p = scalint(p);
release(inbas);
inbas = p;
continue;
case 'I':
p = copy(inbas,length(inbas)+1);
sputc(p,0);
pushp(p);
continue;
case 'o':
p = pop();
EMPTY;
p = scalint(p);
sign = 0;
n = length(p);
q = copy(p,n);
fsfile(q);
l = c = sbackc(q);
if(n != 1){
if(c<0){
sign = 1;
chsign(q);
n = length(q);
fsfile(q);
l = c = sbackc(q);
}
if(n != 1){
while(sfbeg(q) == 0)l = l*100+sbackc(q);
}
}
if (l > BC_BASE_MAX)
error("output base is too large\n");
logo = log_2(l);
obase = l;
release(basptr);
if(sign == 1)obase = (long)-l;
basptr = p;
outdit = (int (*)(struct blk *, int, int))bigot;
if(n == 1 && sign == 0){
if(c <= 16){
outdit = (int (*)(struct blk *, int, int))hexot;
fw = 1;
fw1 = 0;
ll = 68;
release(q);
continue;
}
}
n = 0;
if(sign == 1)n++;
p = salloc(1);
sputc(p,-1);
t = add(p,q);
n += length(t)*2;
fsfile(t);
if((c = sbackc(t))>9)n++;
release(t);
release(q);
release(p);
fw = n;
fw1 = n-1;
ll = 68;
if(fw>=ll)continue;
ll = (68/fw)*fw;
continue;
case 'O':
p = copy(basptr,length(basptr)+1);
sputc(p,0);
pushp(p);
continue;
case '[':
n = 0;
p = salloc(0);
while(1){
if((c = readc()) == ']'){
if(n == 0)break;
n--;
}
sputc(p,c);
if(c == '[')n++;
}
pushp(p);
continue;
case 'k':
p = pop();
EMPTY;
p = scalint(p);
if(length(p)>1){
error("scale too big\n");
}
rewind(p);
k = sfeof(p)?0:sgetc(p);
release(scalptr);
scalptr = p;
continue;
case 'K':
p = copy(scalptr,length(scalptr)+1);
sputc(p,0);
pushp(p);
continue;
case 'X':
p = pop();
EMPTY;
fsfile(p);
n = sbackc(p);
release(p);
p = salloc(2);
sputc(p,n);
sputc(p,0);
pushp(p);
continue;
case 'Q':
p = pop();
EMPTY;
if(length(p)>2){
error("Q?\n");
}
rewind(p);
if((c = sgetc(p))<0){
error("neg Q\n");
}
release(p);
while(c-- > 0){
if(readptr == &readstk[0]){
error("readstk?\n");
}
if(*readptr != 0)release(*readptr);
readptr--;
}
continue;
case 'q':
if(readptr <= &readstk[1])exit(0);
if(*readptr != 0)release(*readptr);
readptr--;
if(*readptr != 0)release(*readptr);
readptr--;
continue;
case 'f':
if(stkptr == &stack[0])printf("empty stack\n");
else {
for(ptr = stkptr; ptr > &stack[0];){
print(*ptr--);
}
}
continue;
case 'p':
if(stkptr == &stack[0])printf("empty stack\n");
else{
print(*stkptr);
}
continue;
case 'P':
p = pop();
EMPTY;
sputc(p,0);
printf("%s",p->beg);
release(p);
continue;
case 'd':
if(stkptr == &stack[0]){
printf("empty stack\n");
continue;
}
q = *stkptr;
n = length(q);
p = copy(*stkptr,n);
pushp(p);
continue;
case 'c':
while(stkerr == 0){
p = pop();
if(stkerr == 0)release(p);
}
continue;
case 'S':
if(stkptr == &stack[0]){
error("save: args\n");
}
c = readc() & 0377;
sptr = stable[c];
sp = stable[c] = sfree;
sfree = sfree->next;
if(sfree == 0)goto sempty;
sp->next = sptr;
p = pop();
EMPTY;
if(c >= ARRAYST){
q = copy(p,length(p));
for(n = 0;n < PTRSZ;n++)sputc(q,0);
release(p);
p = q;
}
sp->val = p;
continue;
sempty:
error("symbol table overflow\n");
case 's':
if(stkptr == &stack[0]){
error("save:args\n");
}
c = readc() & 0377;
sptr = stable[c];
if(sptr != 0){
p = sptr->val;
if(c >= ARRAYST){
rewind(p);
while(sfeof(p) == 0)release(dcgetwd(p));
}
release(p);
}
else{
sptr = stable[c] = sfree;
sfree = sfree->next;
if(sfree == 0)goto sempty;
sptr->next = 0;
}
p = pop();
sptr->val = p;
continue;
case 'l':
load();
continue;
case 'L':
c = readc() & 0377;
sptr = stable[c];
if(sptr == 0){
error("L?\n");
}
stable[c] = sptr->next;
sptr->next = sfree;
sfree = sptr;
p = sptr->val;
if(c >= ARRAYST){
rewind(p);
while(sfeof(p) == 0){
q = dcgetwd(p);
if(q != 0)release(q);
}
}
pushp(p);
continue;
case ':':
p = pop();
EMPTY;
q = scalint(p);
fsfile(q);
c = 0;
if((sfbeg(q) == 0) && ((c = sbackc(q))<0)){
error("neg index\n");
}
if(length(q)>2){
error("index too big\n");
}
if(sfbeg(q) == 0)c = c*100+sbackc(q);
if(c >= BC_DIM_MAX){
error("index too big\n");
}
release(q);
n = readc() & 0377;
sptr = stable[n];
if(sptr == 0){
sptr = stable[n] = sfree;
sfree = sfree->next;
if(sfree == 0)goto sempty;
sptr->next = 0;
p = salloc((c+PTRSZ)*PTRSZ);
zero(p);
}
else{
p = sptr->val;
if(length(p)-PTRSZ < c*PTRSZ){
q = copy(p,(c+PTRSZ)*PTRSZ);
release(p);
p = q;
}
}
seekc(p,c*PTRSZ);
q = lookwd(p);
if (q!=NULL) release(q);
s = pop();
EMPTY;
salterwd((struct wblk *)p,s);
sptr->val = p;
continue;
case ';':
p = pop();
EMPTY;
q = scalint(p);
fsfile(q);
c = 0;
if((sfbeg(q) == 0) && ((c = sbackc(q))<0)){
error("neg index\n");
}
if(length(q)>2){
error("index too big\n");
}
if(sfbeg(q) == 0)c = c*100+sbackc(q);
if(c >= BC_DIM_MAX){
error("index too big\n");
}
release(q);
n = readc() & 0377;
sptr = stable[n];
if(sptr != 0){
p = sptr->val;
if(length(p)-PTRSZ >= c*PTRSZ){
seekc(p,c*PTRSZ);
s = dcgetwd(p);
if(s != 0){
q = copy(s,length(s));
pushp(q);
continue;
}
}
}
q = salloc(1);
sputc(q, 0);
pushp(q);
continue;
case 'x':
execute:
p = pop();
EMPTY;
if((readptr != &readstk[0]) && (*readptr != 0)){
if((*readptr)->rd == (*readptr)->wt)
release(*readptr);
else{
if(readptr++ == &readstk[RDSKSZ]){
error("nesting depth\n");
}
}
}
else readptr++;
*readptr = p;
if(p != 0)rewind(p);
else{
if((c = readc()) != '\n')unreadc(c);
}
continue;
case '?':
if(++readptr == &readstk[RDSKSZ]){
error("nesting depth\n");
}
*readptr = 0;
fsave = curfile;
curfile = stdin;
while((c = readc()) == '!')command();
p = salloc(0);
sputc(p,c);
while((c = readc()) != '\n'){
sputc(p,c);
if(c == '\\')sputc(p,readc());
}
curfile = fsave;
*readptr = p;
continue;
case '!':
if(command() == 1)goto execute;
continue;
case '<':
case '>':
case '=':
if(cond(c) == 1)goto execute;
continue;
default:
printf("%o is unimplemented\n",c);
}
}
}
void
main_loop(void)
{
int c;
int in_defun=0;
char *p;
lineno = 1;
reset();
put_lineno();
LOOP:
c = jump_to_at();
if (c == ')') {
if (!in_defun)
error("unmatched @) found");
in_defun = 0;
putc('}',out);
reset();
goto LOOP;
} else if (c == '\'') {
char *p;
poolp = pool;
p = read_symbol(0);
pushc('\0');
fprintf(out,"%s",p);
goto LOOP;
} else if (c == '[') {
char *p;
poolp = pool;
p = read_symbol(1);
pushc('\0');
fprintf(out,"%s",p);
goto LOOP;
} else if (c != '(') {
char *p;
unreadc(c);
poolp = pool;
poolp = p = read_function();
fprintf(out,"%s",translate_function(poolp));
goto LOOP;
}
p = read_token();
if (strcmp(p, "defun") == 0) {
if (in_defun)
error("@) expected before new function definition");
in_defun = 1;
get_function();
get_lambda_list();
put_fhead();
put_lineno();
c = jump_to_at();
put_declaration();
put_lineno();
} else if (strcmp(p, "return") == 0) {
tab_save = tab;
get_return();
put_return();
} else
error_symbol(p);
goto LOOP;
}
void
get_lambda_list(void)
{
int c;
char *p;
if ((c = nextc()) != '(')
error("( expected");
for (;;) {
if ((c = nextc()) == ')')
return;
if (c == '&') {
p = read_token();
goto _OPT;
}
unreadc(c);
p = read_token();
if (nreq >= MAXREQ)
error("too many required variables");
required[nreq++] = p;
}
_OPT:
if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0)
goto _REST;
for (;; nopt++) {
if ((c = nextc()) == ')')
return;
if (c == '&') {
p = read_token();
goto _REST;
}
if (nopt >= MAXOPT)
error("too many optional argument");
if (c == '(') {
optional[nopt].o_var = read_token();
if ((c = nextc()) == ')')
continue;
unreadc(c);
optional[nopt].o_init = read_token();
if ((c = nextc()) == ')')
continue;
unreadc(c);
optional[nopt].o_svar = read_token();
if (nextc() != ')')
error(") expected");
} else {
unreadc(c);
optional[nopt].o_var = read_token();
}
}
_REST:
if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0)
goto _KEY;
rest_flag = TRUE;
if ((c = nextc()) == ')' || c == '&')
error("&rest var missing");
unreadc(c);
rest_var = read_token();
if ((c = nextc()) == ')')
return;
if (c != '&')
error("& expected");
p = read_token();
_KEY:
if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0)
goto _AUX;
key_flag = TRUE;
for (;; nkey++) {
if ((c = nextc()) == ')')
return;
if (c == '&') {
p = read_token();
if (strcmp(p, "allow_other_keys") == 0 ||
strcmp(p, "aok") == 0) {
allow_other_keys_flag = TRUE;
if ((c = nextc()) == ')')
return;
if (c != '&')
error("& expected");
p = read_token();
}
goto _AUX;
}
if (nkey >= MAXKEY)
error("too many optional argument");
if (c == '(') {
if ((c = nextc()) == '(') {
p = read_token();
if (p[0] != ':' || p[1] == '\0')
error("keyword expected");
keyword[nkey].k_key = p + 1;
keyword[nkey].k_var = read_token();
if (nextc() != ')')
error(") expected");
} else {
unreadc(c);
keyword[nkey].k_key
= keyword[nkey].k_var
= read_token();
}
if ((c = nextc()) == ')')
continue;
unreadc(c);
keyword[nkey].k_init = read_token();
if ((c = nextc()) == ')')
continue;
unreadc(c);
keyword[nkey].k_svar = read_token();
if (nextc() != ')')
error(") expected");
} else {
unreadc(c);
keyword[nkey].k_key
= keyword[nkey].k_var
= read_token();
}
}
_AUX:
if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0)
error("illegal lambda-list keyword");
for (;;) {
if ((c = nextc()) == ')')
return;
if (c == '&')
error("illegal lambda-list keyword");
if (naux >= MAXAUX)
error("too many auxiliary variable");
if (c == '(') {
aux[naux].a_var = read_token();
if ((c = nextc()) == ')')
continue;
unreadc(c);
aux[naux].a_init = read_token();
if (nextc() != ')')
error(") expected");
} else {
unreadc(c);
aux[naux].a_var = read_token();
}
naux++;
}
}
