/*********************************************************/
/*                                                       */
/* PISTOL-Portably Implemented Stack Oriented Language   */
/*                      Version 1.3                      */
/* (C) 1982 by  Ernest E. Bergmann                       */
/*              Physics, Building #16                    */
/*              Lehigh Univerisity                       */
/*              Bethlehem, Pa. 18015                     */
/*                                                       */
/* Permission is hereby granted for all reproduction and */
/* distribution of this material provided this notice is */
/* is included.                                          */
/*                                                       */
/*********************************************************/

/* sixth and final module in BDS 'C', February, 1982 */

#include "bdscio.h"
#include "pistol.h"

synterr()
{ram[-14].in=TRU;if(ram[-24].in)carret();
       if((ram[-11].in) && (ram[-13].in==FALS))
               message(&strings[LINEBUF]);
       merr(synt);
}

pushck(chkch)
char chkch;
{ if(CHKLMT>(++strings[1])) strings[1+strings[1]]=chkch;
else{ram[-14].in=TRU; message(ovflo); synterr();}
}

aloop()
{if(lstack[lptr]<lstack[lptr-1]){Pw=ip;ip += *Pw; }
else{lptr -=3; if(lptr<0) merr(undflo); ip +=W ; }
}

pdo()
{drop(); drop();
       if(stack[stkptr+2]<stack[stkptr+1])
       {lpush(stack[stkptr+2]);
       lpush(stack[stkptr+1]);
       lpush(stack[stkptr+2]); ip += W;
       }
       else{ Pw=ip; ip += *Pw; }
}

dropck()
{if(strings[1]) strings[1]--; else synterr(); }

geoln() /* Feb 17 */
{       while(*ram[-15].pc != NEWLINE) ram[-15].pc++;
}

move(as,ad,nowd)
int as,ad,nowd;
{int endaddr;
       endaddr=as+nowd; Pw=as; Pw2=ad;
       while(Pw <= endaddr)
       { *Pw2=*Pw ; Pw++; Pw2++;}
}

swap() /* Feb 17 */
{Pc=stack[stkptr];stack[stkptr]=stack[stkptr-1];
       stack[stkptr-1]=Pc;
}

permstrings()
{       if(ram[-5].pc<ram[-4].pc) ram[-5].pc=ram[-4].pc;
}

enter() /* Feb 17 eliminate Pw */
{drop();temp=find(stack[stkptr+1]);
if(temp){message(redef);spaces(3);
       message(stack[stkptr+1]);carret();
       }append(0);
       append((*ram[-6].pw).in);
       append(stack[stkptr+1]);
       append(COMPHERE);
       (*ram[-6].pw).in=ram[-3].in;
}

fenter(i) /* Feb 17, shortened */
int i;
{ Pw = (*ram[-6].pw).pw - 4 ; *Pw = i ; }

getline()
{if(!ram[-11].in)
       {/* input from console*/
       cinline();
       }
else
       {/*input from file*/
       finline(ldfil1,&Pc);    /*Pc can get*/
       }                       /*clobbered if eof*/
if(ram[-13].in&&ram[-11].in) message(&strings[LINEBUF]);
}

lpush(item)
int item;
{if(LSIZE<= ++lptr) merr(ovflo); lstack[lptr]=item;}

cpush(item)
int item;
{if(CSIZE<= ++cptr) merr(ovflo); cstack[cptr]=item; }

touchup()
{int val;
       Pw=val=stack[stkptr];drop();*Pw=ram[-2].in-val; }

fwdref()
{ push(ram[-2].in); compile(0); }

compile(address) /* Feb 17 */
int address;
{ if(ram[-2].pw >= &ram[RAMSIZE-2]) merr(ovflo);
Pw=ram[-2].pw++ ; *Pw=address;
}



/* addstring - convenience for initialization phase to emplace
       string and update ram[-4]
*/
char *addstring(length,string)
int length;
char *string;
{
int i;
char *start;
       start=ram[-4].pc++;
       movmem(string,ram[-4].pc,length);
       ram[-4].pc += length;
       permstrings();
       *start=length;
       return(start);
}

append(item)    /* place item at end of dictionary */
int     item;   /* doesn't check for overflow yet, Feb 17 */
{
       (*ram[-3].pw).in=item;
       ram[-3].pw++;
}

penter(length, name, opcode) /* Feb 17 */
int     length,opcode;
char    *name;
{
       Pc=addstring(length,name);
       append(0);
       append((*ram[-6].pw).in);
       append(Pc);
       if(opcode<0)
       {append(-opcode);append(PSEMICOLON);}
       else
       {append(COMPME);append(opcode);}
       (*ram[-6].pw).pw = ram[-3].pw - 1 ;
       fenter(ram[-3].in);
}

carret()        /* outputs the CR-LF sequence*/
{       if(ram[-14].in)
       {       if(ram[-21].in == ++ram[-22].in)
               {ram[-22].in=0;
               cinline(); Pc =ram[-15].pc;
               if('Q' == toupper(*Pc)) abort();
               }
               ram[-24].in=0;
               printf("\n");
       }
       if(ram[-12].in) fprintf(list,"\n");
}

merr(m)
char *m;
{       ram[-14].in=TRU;
       if(ram[-24].in) carret();
       message(m);
       abort();
}

message(st)
char *st;
{char *last;
char len;
       len=*st;
       last=st + *st;
       while(st < last){st++; chout(*st);}
}

drop()
{       if(stkptr<1)merr(undflo);
       else stkptr--;
}

push(item)
int item;
{       if(++stkptr >= SSIZE) merr(ovflo);
       stack[stkptr]=item;
}

rpush(item)
int item;
{       if(++rptr >= RSIZE) merr(ovflo);
       rstack[rptr]=item;
}

chout(ch)
char ch;
{       if(ch == 13) carret();
       else if(ch == 9) tab();
       else{if(ram[-24].in==ram[-23].in)carret();
               ram[-24].in++;
               if(ram[-14].in)putc(ch,1);
               if(ram[-12].in)putc(ch,list);
       }
}

tab()
{       if(ram[-27].in>0)
       spaces(ram[-27].in-ram[-24].in%ram[-27].in);
}

spaces(num)
int num;
{       while(num>0){chout(' ');num--;}
}

cinline()       /*input line from console*/
{       ram[-15].pc=&strings[LINEBUF+1];
       ram[-16].in=1+strlen(gets(&strings[LINEBUF+1]));
       Pc=&strings[LINEBUF];
       *Pc=ram[-16].in;
       Pc += ram[-16].in;
       *Pc=NEWLINE; Pc++ ;
       *Pc=10 ; Pc++ ;
       *Pc = 0;
       if(ram[-12].in)fputs(ram[-15].pc,list);
}

finline(iobuf,iostat)
char *iobuf;
int *iostat;    /*not used anymore ???*/
{       ram[-15].pc=fgets(&strings[LINEBUF+1],iobuf);
       if(!ram[-15].in) merr(feof);
       ram[-16].in=strlen(ram[-15].pc);
       Pc=&strings[LINEBUF];
       *Pc=ram[-16].in;
       Pc += ram[-16].in;
       *Pc=NEWLINE; Pc++ ;
       *Pc=10; Pc++ ;
       *Pc=0 ;
}

eof(iobuf)      /* used to test for eof status on */
char *iobuf;    /* buffered i/o in analogy to PASCAL*/
{int c;
       c=getc(iobuf);
       if((c == ERROR) || (c== CPMEOF)) return(TRU);
       ungetc(c,iobuf);
       return(FALS);
}