Category : Miscellaneous Language Source Code
Archive   : ADA.ZIP
Filename : AUGUSTA.PAS

 
Output of file : AUGUSTA.PAS contained in archive : ADA.ZIP

Program Augusta;
{ A public domain subset of the US Deptartment of Defense }
{ computer language Ada. }

{$U+,R+}

const
CrLf = #13#10; FF = #12;

quote = '"';
alf = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
lc = 'abcdefghijklmnopqrstuvwxyz';
dig = '0123456789';
hdig = '0123456789ABCDEF';
an = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_';

PLDCI = 1; PLDL = 2; PLLA = 3; PLDB = 4; PLDO = 5; PLAO = 6; PDUP = 7;
PLOD = 8; PLDA = 9; PPOP = 10; PSTO = 11; PSINDO = 12; PLCA = 13;
PSAS = 14; PAND = 16; POR = 17; PNOT = 18; PADI = 19; PNGI = 20;
PSBI = 21; PMPI = 22; PDVI = 23; PIND = 24; PEQUI = 25; PNEQI = 26;
PLEQI = 27; PSLDC = 61; PINCL = 80; PDECL = 81; PLESI = 28; PGEQI = 29;
PGTRI = 30; PEQUSTR = 31; PNEQSTR = 32; PLEQSTR = 33; PLESSTR = 34;
PGEQSTR = 35; PGTRSTR = 36; PUJP = 37; PFJP = 38; PXJP = 39; PCLP = 40;
PCGP = 41; PCSP = 42; PRET = 43; PMODI = 45; PCIP = 46; PRNP = 47;
PEOP = 15; PSLDCN1 = 63; PIXA = 48; PSLDO = 57; PSLAO = 58; PSLLA = 59;
PSLDLO = 49; PSLDL = 60;

squote = 0; eol = 1; c = 2; lp = 3; rp = 4;
mul = 5; kdiv = 6; add = 7; subt = 8; les = 9; leq = 10; gt = 11;
geq = 12; eq = 13; neq = 14; bar = 15; kid = 16;
sc = 17; comma = 18; semicolon = 19; colon = 20; eqgt = 21;
coloneq = 22; dot = 23; dotdot = 24; kch = 25; at = 26;
kand = 27; karray = 28; kbegin = 29; kcase = 30; kconst = 31;
kdeclare = 32; kelse = 33; kelseif = 34; kend = 35; kexit = 36;
kfor = 37; kfunc = 38; kif = 39; kin = 40; kis = 41; kloop = 42;
klast = 43; klen = 44; kmod = 45; knot = 46; knull = 47; kof = 48;
kor = 49; kothers = 50; kout = 51; kpragma = 52; kproc = 53;
kret = 54; kreverse = 55; kthen = 56; kwhen = 57; kwhile = 58;

TSTR = 0; TINT = 1; TCHR = 2; TBOL = 4; FMSZ = 14; NKEY = 33; MB = 3;

{ Define sets of token numbers as character strings }
addop = #7#8; { ADD,SUBT }
mulop = #5#6#45; { MUL,KDIV,KMOD }
logicalop = #27#49; { KAND,KOR }
unaryop = #7#8#46; { ADD,SUBT,KNOT }
relop = #9#10#11#12#13#14; { LES,LEQ,GT,GEQ,EQ,NEQ }
declpartx = #16#53#38#52; { ID,KPROC,KFUNC,KPRAGMA }
stmtx = #58#37#42#32#29#36#54#39#30#47#16#52;
{ KWHILE,KFOR,KLOOP,KDECLARE,KBEGIN,KEXIT,KRET,KIF,KCASE,KNULL,ID,KPRAGMA }

type
anystring = string[255];
string2 = string[2];
string8 = string[8];
proc_entry_type = record
T1 : array[1..2] of char;
T2 : array[1..2] of char;
T3 : array[1..2] of char;
D : array[1..2] of char;
S : array[1..2] of char;
end;
buffer_type = array[1..128] of char;

var
spaces,lexch : anystring; { constant strings too long to declare }
null_rec : buffer_type;
Plst,Clst : boolean; { true if print or crt listing are on }
LP_Str : anystring; { printer init string, read from datafile }
C_Str : anystring;

MAP : array[0..26] of integer;
KEYWD : array[0..33] of string8;
S_str : array[0..100] of anystring;
TY : array[0..20] of integer;
buffer : array[0..Mb] of buffer_type;
B : array[0..Mb] of integer;
D : buffer_type;
S : array[0..500] of integer;
buf : anystring; { holds the current line }
B_ptr,Oldb : integer; { indexes into buf }
Ch : char; { the most recent char out of buf }
sym_str : anystring;
Id : string8; { formatted symbol string }
infile : array[2..4] of text; { input file variables }
isopen : array[2..4] of boolean;
One : file of buffer_type; { code output file }
Ln : integer; { line number being proceesed }
Eoi : boolean; { true for end of input }
LL,L1,P1,C1 : integer;
Cproc,proc : integer; { proc # being compiled, proc count }
M0 : integer; { maximum code record }
TSP,SSP : integer; { internal type and symbol stack counter }
GC,CP,CB,SP : integer; { various code pointers }
SI : integer; { input file number (changes with includes) }
pType,Kind,
Pinfo,pConst,
Ofst,MxOf,Addr,
ObjSz,Lex : integer; { procedure descriptors }
I,J,X,W,Hash : integer;
R0,R1,R2 : integer; { record numbers }
T1,T2,T3,T4,
T5,T6,T7,T8 : integer;
T1_Str,T2_Str : anystring;
LOC1,LOC2 : integer;
T,T0,TN : integer; { token numbers and values }
TT : char; { and character equivalents for search }
XitJp,LFjp,LUjp : integer; { heads of lists of jumps to be patched }
lpflg : integer; { non-zero when inside a LOOP-END structure }
cases : integer;

Procedure ShowErr(E : integer);
begin
writeln(CrLf,'*** Error ',E,' in line ',LN,CrLf,BUF);
writeln(copy(spaces,1,B_ptr-1),'*');
if PLST then writeln(Lst,'*** Error ',E,' in line ',LN);
end;

Procedure Error(E : integer);
begin
showerr(E);
for SI:=2 to 4 do if isopen[SI] then close(infile[SI]);
close(One);
halt;
end;

Procedure Expected(E : integer);
begin
writeln(CrLf,T0,' expected'); ShowErr(E);
end;

Function MKI(I : integer): string2;
begin
mki := chr(lo(I)) + chr(hi(I));
end;

Procedure Push(X : integer);
{ 4280 '********** Push }
begin
S[SP] := X; SP := SP + 1;
end;

Procedure Pop(var X : integer);
{ 4300 '********** Pop }
begin
SP := SP - 1; X := S[SP];
end;

Procedure PushSyms;
{ 5400 '********** Push Syms }
begin
X := LENgth(S_str[SSP]);
IF X=255 THEN begin
SSP := SSP + 1; s_str[SSP] := '';
X := 0;
end;
Push(X); X := SSP; Push(X);
end;

Procedure PopSyms;
{ 5500 '********** Pop Syms }
begin
Pop(X);
FOR I:=X+1 TO SSP do S_str[I] := '';
SSP := X; Pop(X); LOC2 := X;
end;

Procedure GetBuf;
{ 4140 '********** GetBuf }
var
temp : integer;
begin
R1 := (CP + CB) div 128 + 1; R2 := (CP + CB) and 127;
IF R1<>R0 THEN begin
J := 0;
for temp:=1 to MB do
if (B[temp]=R0) or (B[temp]=0) then J := temp;
IF J<>0 THEN begin
Buffer[J] := D; B[J] := R0; END
else begin
Buffer[0] := D;
J := trunc(Random*MB) + 1;
D := Buffer[J];
while filesize(One)<(B[J]-1) do begin
seek(One,filesize(One)); write(One,null_rec);
end;
Seek(One,B[J]-1); write(One,D);
Buffer[J] := Buffer[0]; B[J] := R0;
end;
J := 0;
for temp:=1 to MB do
if B[temp]=R1 then J := temp;
IF J<>0 THEN begin
D := Buffer[J]; R0 := R1;
IF R1>M0 THEN M0 := R1; end
else begin
if R1>filesize(One) then
D := null_rec
else begin
seek(One,R1-1); Read(One,D);
end;
R0 := R1;
IF R1>M0 THEN M0 := R1;
end;
end;
end;

Procedure ReadByte;
{ 4260 '********** ReadByte }
begin
GetBuf;
W := ord(D[R2+1]);
end;

Procedure ReadWrd;
{ 4010 '********** read wrd }
begin
ReadByte; T1 := W;
CP := CP + 1;
ReadByte; W := (W shl 8) + T1;
CP := CP - 1;
end;

Procedure GenByte;
{ 3990 '********** GenByte }
begin
GetBuf;
D[R2+1] := CHR(W);
CP := CP + 1;
end;

Procedure GenWord;
{ 4030 '********** GenWord W }
var
temp : integer;
tmp_str : string[2];
begin
GetBuf;
IF R2<127 THEN begin
tmp_str := MKI(W);
D[R2+1] := tmp_str[1]; D[R2+2] := tmp_str[2];
CP := CP + 2; end
else begin
temp := W;
W := W and 255; GenByte;
W := temp shr 8; GenByte;
end;
end;

Procedure Open_source;
{1230 }
begin
SI := SI + 1;
if SI in[2..4] then begin
assign(infile[SI],sym_str); reset(infile[SI]); isopen[SI] := true;
end
else begin
writeln('Bad file number :',SI); halt;
end;
end;

Procedure Getline;
{ 1280 }
begin
repeat
LN := LN + 1;
IF EOF(infile[SI]) THEN begin
CLOSE(infile[SI]);
SI := SI - 1;
IF (SI>1) AND PLST THEN writeln(lst,'* End of INCLUDE');
end;
IF SI=1 THEN
EOI := true
else begin
readln(infile[SI],BUF);
IF PLST THEN begin
writeln(lst,ln:5,' ',cproc:4,' ',cp:6,' ',ofst:6,' ',copy(BUF,1,54));
if (LN MOD 60)=0 THEN writeln(lst,ff,LP_Str);
end;
IF CLST THEN
writeln(BUF)
else IF (LN AND 63)=63 THEN
writeln(LN,'...');
end;
until (buf>'') or EOI;
if not EOI then begin
BUF := BUF + CHR(3); B_ptr := 1;
WHILE BUF[B_ptr]=' ' do B_ptr := B_ptr + 1;
CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
end;
end;

Procedure Getch;
{ 1360 '********** GetCh }
begin
CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
end;

Procedure LookupKeyword;
begin
HASH := MAP[pos(id[1],ALF)];
while keywd[hash] if keywd[hash]=id then
T := hash + 26
else
T := kID;
end;

Procedure GetSStr;
{ 1930 '********** Get S$ }
begin
Sym_str := copy(BUF,OLDB-1,B_ptr-OLDB); {1940}
end;

Procedure Getsym;
{ 1400 '********** GetSym }
var
flag : boolean;
I1 : integer;
begin
repeat
oldb := b_ptr; Ch := upcase(Ch);
I := pos(ch,LEXCH);
IF I=0 THEN Error(1);
IF I<27 THEN begin
sym_str := '';
while pos(ch,an)<>0 do begin
IF CH<>'_' THEN Sym_str := Sym_str + CH;
GetCh; Ch := upcase(Ch);
end;
IF LENgth(Sym_str)>8 THEN Sym_str := copy(Sym_str,1,8);
ID := Sym_str + copy(SPACEs,1,8-LENgth(Sym_str));
LookupKeyword;
end
else begin
case I of
27..36: begin
TN := 0; I1 := 10;
repeat
flag := true;
WHILE pos(ch,HDIG)<>0 do begin
TN := TN * I1 + pos(ch,HDIG) - 1;
Getch;
end;
IF CH='#' THEN begin
flag := false; I1 := TN; TN := 0; Getch;
end;
until flag;
T := C;
end;
37: begin
WHILE CH=' ' do begin
CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
end;
OLDB := B_ptr;
end;
38: begin
T := AT; Getch;
end;
39: begin
T := MUL; Getch;
end;
40: begin
T := ADD; Getch;
end;
41: begin
Getch;
IF CH='>' THEN begin
T := EQGT; Getch;
end
ELSE T := EQ;
end;
42: begin
T := SUBT; Getch;
IF CH='-' THEN begin
Getline; OLDB := B_ptr;
end;
end;
43: begin
Getch;
IF CH='=' THEN begin
T := LEQ; Getch;
end
ELSE T := LES;
end;
44: begin
Getch;
IF CH='=' THEN begin
T := GEQ; Getch;
end
ELSE T := GT;
end;
45: begin
Getch;
IF CH='=' THEN begin
T := NEQ; Getch;
end
ELSE T := kDIV;
end;
46: begin
Getch;
IF CH='=' THEN begin
T := COLONEQ; Getch;
end
ELSE T := COLON;
end;
47: begin
T := SEMICOLON; Getch;
end;
48: begin
Getch; Getch;
IF CH<>#39 THEN error(11);
Getch; GetSStr;
TN := ord(Sym_str[2]); T := kCH;
end;
49: begin
T := RP; Getch;
end;
50: begin
T := LP; Getch;
end;
51: begin
T := COMMA; Getch;
end;
52: begin
I1 := pos('"',copy(buf,b_ptr,255));
IF I1=0 THEN error(10);
Sym_str := copy(BUF,B_ptr,I1-1);
T := SC; B_ptr := B_ptr + I1; Getch;
end;
53: begin
T := DOT; Getch;
IF CH='.' THEN begin
T := DOTDOT; Getch;
end;
end;
54: begin
T := BAR; Getch;
end;
55: begin
T := BAR; Getch;
end;
56: begin
GetLine; OLDB := B_ptr;
end;
57: begin
T := SQUOTE; Getch;
end;
58: begin
Getch;
OLDB := B_ptr;
end;
end;
end;
IF EOI THEN error(12);
until oldb<>b_ptr;
TT := CHR(T);
end;

Procedure AddID;
{ 3850 '********** Add ID }
begin
IF (LENgth(S_str[SSP])+17)>255 THEN begin
SSP := SSP + 1; s_str[ssp] := '';
end;
insert(ID+CHR(pTYPE)+CHR(KIND)+CHR(PINFO)+MKI(pCONST)+CHR(OBJSZ)
+MKI(ADDR)+CHR(LL),s_str[SSP],1);
end;

Procedure LookupID;
{ 3890 '********** Lookup ID }
var
work : anystring;
begin
LOC1 := SSP; Loc2 := 0;
while (loc1>0) and (Loc2=0) do begin
LOC2 := pos(ID,S_str[LOC1]);
IF LOC2=0 THEN LOC1 := LOC1 - 1;
end;
IF LOC1<1 THEN Error(2);
work := s_str[loc1];
pTYPE := ord(work[loc2+8]); KIND := ord(work[loc2+9]);
PINFO := ord(work[loc2+10]);
pCONST := ord(work[loc2+11]) + (ord(work[loc2+12]) shl 8);
OBJSZ := ord(work[loc2+13]);
ADDR := ord(work[loc2+14]) + (ord(work[loc2+15]) shl 8);
LEX := ord(work[loc2+16]);
end;

Procedure TestToken;
var
T_Str : anystring;
begin
while T0<>T do begin {1950}
expected(4);
write('Reenter+ ');
readln(T_str); BUF := copy(BUF,1,B_ptr-1) + T_str + CHR(3);
Getch; Getsym;
end;
end;


Procedure TstToken_GetNext;
begin
IF T0<>T THEN TestToken;
Getsym;
end;

Procedure Get_C;
{ 2290 '********** Get C }
var
v1,v2,v3,v4,v5,v6 : integer; { temp variables to preserve the id }
begin
IF T=kID THEN begin
V1 := pTYPE; V2 := KIND; V3 := PINFO;
V4 := pCONST; V5 := OBJSZ; V6 := LL;
LookupID;
IF (KIND=0) AND (pTYPE=1) THEN begin
T := C; T2 := pCONST;
end;
pTYPE := V1; KIND := V2; PINFO := V3; pCONST := V4; OBJSZ := V5; LL := V6;
end;
T0 := C; TstToken_GetNext;
end;

Procedure Pragma;
{ 2770 '********** Pragma }
var
t_str : string8;
begin
while T=KPRAGMA do begin
Getsym;
if sym_str='CRT' then begin
Getsym; T0 := LP; TstToken_GetNext; T_str := Sym_str;
Getsym; T0 := RP; TstToken_GetNext;
IF T_str='ON' THEN
CLST := true
ELSE
CLST := false;
end
else if sym_str='INCLUDE' then begin
Getsym; T0 := LP; TstToken_GetNext;
IF T<>SC THEN Error(9) ELSE begin
Open_Source; Getsym; T0 := RP; TstToken_GetNext;
end; end
else if sym_str='LIST' then begin
Getsym; T0 := LP; TstToken_GetNext; T_str := Sym_str;
Getsym; T0 := RP; TstToken_GetNext;
IF T_str='ON' THEN begin
PLST := true; write(lst,lp_str); end
ELSE IF T_str='OFF' THEN
PLST := false;
end;
Getline; Getsym;
end;
end;

Procedure SubTIDUnit;
{ 2250 '********** SubtypeIdentificationUnit }
begin
LookupID;
IF KIND<>4 THEN error(8);
IF PINFO=0 THEN KIND := 1 ELSE KIND := 5;
IF pTYPE<>0 THEN
Getsym
else begin
Getsym;
IF T=LP THEN begin
Getsym; Get_C; OBJSZ := TN + 1; T0 := RP; TstToken_GetNext;
end;
IF OBJSZ>255 THEN error(15);
end;
end;

Procedure ProcDef;
{ 5200 '********** Proc DEF }
begin
LL := LL + 1; Push(cproc); Push(OFST); Push(MXOF); T0 := kID; TestToken;
PushSyms;
end;

Procedure ProcFormalPart;
{ 2100 '********** ProcFormalPart }
var
flag : boolean;

Procedure ProcParamDecl;
{ 2160 '********** ProcParamDecl }
var
flag : boolean;
begin
T1_str := '';
repeat
flag := true; T0 := kID; TestToken;
T1_str := T1_str + ID; Getsym;
IF T=COMMA THEN begin
Getsym; flag := false;
end;
until flag;
T0 := COLON; TstToken_GetNext; P1 := 1;
IF T=KOUT THEN begin
P1 := 2; Getsym; end
else IF T=KIN THEN Getsym;
SubTIDUnit; PINFO := P1;
WHILE LENgth(T1_str)>0 do begin
T2_str := T2_str + copy(T1_str,1,8) + CHR(pTYPE) + CHR(KIND) + CHR(PINFO)
+ MKI(pCONST) + CHR(OBJSZ) + MKI(0) + CHR(LL);
delete(T1_str,1,9);
OFST := OFST-2;
end;
end;

begin
T2_str := ''; T0 := LP; TstToken_GetNext;
repeat
flag := true;
ProcParamDecl;
IF T=SEMICOLON THEN begin
Getsym; flag := false;
end;
until flag;
T0 := RP; TstToken_GetNext;
I := OFST;
repeat
T1_str := copy(T2_str,1,17); delete(T2_str,1,17);
IF (LENgth(S_str[SSP])+17)>255 THEN begin
SSP := SSP + 1; s_str[SSP] := '';
end;
insert(copy(T1_str,1,14)+MKI(I)+T1_str[length(T1_str)],S_str[SSP],1);
I := I + 2;
until I>(-FMSZ-2);
end;

Procedure ProcEndDef;
{ 5300 '********** Proc END DEF }

Procedure WriteProc;
{ 4910 '********** WriteProc }
begin
T2 := CP; T3 := CB; CB := 0; CP := (ADDR-1)*7 + 128;
W := C1 - 1920; GenWord; W := L1; GenWord; W := P1; GenWord;
W := LL; GenByte; CP := T2; CB := T3;
end;

begin
W := PEOP; GenByte; Pop(P1); Pop(ADDR); CPROC := ADDR; L1 := MXOF;
C1 := GC; WriteProc; GC := GC + CP;
LL := LL - 1;
PopSyms; Delete(S_str[SSP],1,length(s_str[ssp])-LOC2-17);
Pop(MXOF); Pop(OFST); Pop(X); CPROC := X;
end;

Procedure BodyPart; forward;
{ parseproc -> bodypart -> declpart -> parseproc or parsefunc. }
{ One has to be Forwarded }

Procedure ParseProc;
{ 2010 '********** Parse Proc }
begin
ProcDef;
KIND := 2; PROC := PROC + 1; CPROC := PROC; ADDR := PROC;
X := ADDR; Push(X); AddID; Getsym;
OFST := -FMSZ;
IF T<>KIS THEN begin
ProcFormalPart;
T0 := KIS; TestToken;
end;
X := -(OFST+FMSZ); Push(X);
Getsym;OFST := 0; MXOF := 0; BodyPart;
W := PRET; GenByte;
ProcEndDef;
end;

Procedure ParseFunc;
{ 2340 '********** ParseFunc }
begin
ProcDef;
KIND := 3; PROC := PROC + 1; CPROC := PROC; ADDR := PROC;
X := ADDR; Push(X); AddID;
Push(SSP); X := LENgth(S_str[SSP]); Push(X);
Getsym; OFST := -FMSZ;
IF T=LP THEN ProcFormalPart;
T0 := KRET; TstToken_GetNext; SubTIDUnit; Pop(T2);
Pop(X); T1 := X; T3 := LENgth(S_str[T1]);
IF (KIND<>5) OR (OBJSZ<>2) THEN error(16);
S_str[T1][T3-T2+9] := CHR(pTYPE);
T0 := KIS; TstToken_GetNext;
X := -(OFST+FMSZ); Push(X);
OFST := 0; MXOF := 0; BodyPart; ProcEndDef;
end;

Procedure DeclPart;
{ 2480 '********** DeclPart }
var
K1 : integer;

Procedure ObjDecl;
{ 2560 '********** ObjDecl }
var
objsize : integer;
begin
Getsym;
while T=COMMA do begin
Getsym; T0 := kID; TestToken;
T1_str := T1_str + ID;
GetSym;
end;
T0 := COLON; TstToken_GetNext;
IF T=KCONST THEN begin
K1 := 0; OBJSIZE := 0; Getsym; T0 := COLONEQ; TstToken_GetNext;
IF T=kID THEN
LookupID
ELSE begin
IF T=SUBT THEN begin
T1 := -1; Getsym; end
ELSE T1 := 1;
pCONST := TN*T1;
IF T=C THEN pTYPE := 1 ELSE pTYPE := 2;
end;
Getsym;
end
else IF T=KARRAY THEN begin
K1 := 1; Getsym; T0 := LP; TstToken_GetNext; T2 := TN; Get_C;
T0:= RP; TstToken_GetNext; T0 := KOF; TstToken_GetNext;
SubTIDUnit; pCONST := T2; OBJSIZE := (T2+1)*OBJSZ;
IF (T2<0) OR (T2>16383) THEN error(15);
end
else begin
SubTIDUnit; OBJSIZE := OBJSZ;
end;
PINFO := 0; KIND := K1;
WHILE LENgth(T1_str)>0 do begin
ID := copy(T1_str,1,8); delete(T1_str,1,8);
ADDR := OFST; OFST := OFST + OBJSIZE;
AddID;
end;

end;

begin
case T of
kID: begin
T1_str := ID; K1 := 5; ObjDecl;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
KPROC: begin
Getsym; ParseProc;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
KFUNC: begin
Getsym; ParseFunc;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
KPRAGMA: Pragma
else error(3);
end;
IF pos(TT,DECLPARTx)<>0 THEN
declpart
ELSE IF OFST>MXOF THEN MXOF := OFST;
end;

Procedure B_B;
begin
GenByte; W := ADDR; GenByte;
end;

Procedure B_W;
begin
GenByte; W := ADDR; GenWord;
end;

Procedure LDCons;
{ 3635 '********** LD Cons }
begin
case TN of
-1 : begin
W := PSLDCN1; Genbyte
end;
0..15 : begin
W := 64 + TN; Genbyte;
end;
16..255 : begin
W := PSLDC; GenByte; W := TN; GenByte;
end;
else begin
W := PLDCI; GenByte; W := TN; GenWord;
end;
end;
end;

Procedure LDVal;
{ 3820 '********** LD Val }
begin
IF LEX=1 THEN
IF ADDR<256 THEN begin
W := PSLDO; B_B; end
ELSE begin
W := PLDO; B_W;
end
ELSE IF LEX=LL THEN
IF (ADDR>=0) AND (ADDR<8) THEN begin
W := PSLDLO + ADDR; GenByte; end
else IF (ADDR>7) AND (ADDR<256) THEN begin
W := PSLDL; B_B; end
ELSE begin
W := PLDL; B_W;
end
ELSE begin
W := PLOD; GenByte; W := LL - LEX; B_W;
end;
end;

Procedure LDAdr;
{ 4060 '********** LD Adr }
begin
IF PINFO=2 THEN
LDVal
else IF LEX=1 THEN
IF ADDR<256 THEN begin
W := PSLAO; B_B; end
ELSE begin
W := PLAO; B_W;
end
ELSE IF LEX=LL THEN
IF (ADDR>=0) AND (ADDR<256) THEN begin
W := PSLLA; B_B; end
ELSE begin
W := PLLA; B_W;
end
ELSE begin
W := PLDA; GenByte; W := LL - LEX; B_W;
end;
end;

Procedure CheckBool;
{ 4930 '********** Check Bool }
begin
IF TY[TSP]<>TBOL THEN Error(9);
TSP := TSP - 1;
end;

Procedure CheckInt;
{ 4960 '********** Check Int }
begin
IF TY[TSP]<>TINT THEN Error(9);
TSP := TSP - 1;
end;

Procedure Expr; forward;
{ primary -> actualparam -> expr -> se -> primary. One has to be forwarded }

Procedure ActualParam;
{ 3570 '********** ActualParam }
begin
IF T=AT THEN begin
Getsym; T0 := kID; TestToken; LookupID;
LDAdr; Getsym;
IF KIND=1 THEN begin
X := OBJSZ; Push(X);
T0 := LP; TstToken_GetNext; Expr; CheckInt; Pop(X);
IF X=2 THEN
W := PIND
ELSE begin
W := PIXA; GenByte; W := X;
end;
GenByte; T0 := RP; TstToken_GetNext;
end;
end
ELSE begin
Expr; TSP := TSP - 1;
end;
IF T=COMMA THEN begin
Getsym; ActualParam;
end;
end;

Procedure CallProc;
{ 4100 '********** Call Proc }
begin
Pop(LEX); Pop(X); ADDR := X;
if Lex=0 then
W := PCSP
else if Lex=2 then
W := PCGP
else if LEX=(LL+1) then
W := PCLP
else W := PCIP;
GenByte; W := ADDR; GenByte;
end;

Procedure Se;

Procedure Term;
{ 3350 '********** Term }

Procedure Primary;
{ 3610 '********** Primary }
begin
case T of
LP : begin
Getsym; Expr; T0 := RP; TstToken_GetNext;
end;
C : begin
TSP := TSP + 1; TY[TSP] := TINT; LDCons; Getsym;
end;
kCH : begin
TSP := TSP + 1; TY[TSP] := TCHR; LDCons; Getsym;
end;
SC : begin
TSP := TSP + 1; TY[TSP] := TSTR;
W := PLCA; GenByte; W := LENgth(Sym_str); GenByte;
FOR I:=1 TO LENgth(Sym_str) do begin
W := ord(Sym_str[I]); GenByte;
end;
Getsym;
end;
else begin
T0 := kID; TestToken; LookupID;
IF KIND=0 THEN begin
TSP := TSP + 1; TY[TSP] := pTYPE; TN := pCONST; LDCons;
Getsym; end
else begin
Getsym;
IF T=SQUOTE THEN begin
TSP := TSP + 1; TY[TSP] := TINT; Getsym;
IF T=KLAST THEN begin
W := PLDCI; GenByte; W := pCONST; GenWord; Getsym; end
else IF T=KLEN THEN begin
LDAdr; W := PLDB; GenByte; end
ELSE Error(7); end
else IF KIND=4 THEN begin
X := pTYPE; Push(X); T0:=LP; TstToken_GetNext;
Expr; T0:=RP; TstToken_GetNext;
Pop(X); TY[TSP] := X; end
else begin
TSP := TSP + 1; TY[TSP] := pTYPE;
IF pTYPE=0 THEN
IF KIND=1 THEN begin
LDAdr; X := OBJSZ; Push(X); T0 := LP; TstToken_GetNext;
Expr;
IF TY[TSP]<>TINT THEN Error(9);
TSP := TSP - 1; Pop(X); W := PIXA; GenByte;
W := X; GenByte; T0 := RP; TstToken_GetNext; end
else LDAdr
else IF KIND=1 THEN begin
LDAdr; T0 := LP; TstToken_GetNext; Expr;
IF TY[TSP]<>TINT THEN Error(9);
TSP := TSP - 1; W := PIND; GenByte;
W := PSINDO; GenByte; T0 := RP; TstToken_GetNext; end
else IF KIND=3 THEN begin
Push(ADDR); X := LEX; Push(X);
IF T=LP THEN begin
Getsym; ActualParam; T0 := RP; TstToken_GetNext;
end;
CallProc; end
else begin
LDVal;
IF PINFO=2 THEN begin
W := PSINDO; GenByte;
end;
end;
end;
end;
end;
end;
end;

begin
Primary;
while pos(TT,MULOP)<>0 do begin
X := T; Push(X); Getsym; Primary;
IF (TY[TSP]<>TY[TSP-1]) OR (TY[TSP]<>TINT) THEN Error(9);
TSP := TSP - 1;
Pop(X);
IF X=MUL THEN
W := PMPI
ELSE IF X=kDIV THEN
W := PDVI
ELSE W := PMODI;
GenByte;
end;
end;

begin
IF pos(TT,UNARYOP)<>0 THEN begin
Push(T); X := 1; Push(1); Getsym; end
ELSE begin
X := 0; Push(0);
end;
Term; Pop(X);
IF X=1 THEN begin
Pop(X);
IF X=SUBT THEN begin
W := PNGI; GenByte; end
ELSE begin
W := PNOT; GenByte;
end;
end;
while pos(TT,ADDOP)<>0 do begin
X := T; Push(X); Getsym; Term; Pop(X);
IF X=ADD THEN W := PADI ELSE W := PSBI;
IF TY[TSP]<>TINT THEN error(9);
TSP := TSP - 1; GenByte;
end;
end;

Procedure Expr;
{ 3100 '********** Expr }
var
Prev : integer;

Procedure Relation;
{ 3190 '********** Relation }
begin
Se;
IF pos(TT,RELOP)<>0 THEN begin
X := T; Push(X); Getsym; Se;
IF (TY[TSP]=TINT) or (TY[TSP]=TCHR) or (TY[TSP]=TBOL) THEN begin
IF TY[TSP]<>TY[TSP-1] THEN Error(9) ELSE begin
TSP := TSP - 1; TY[TSP] := TBOL;
end;
Pop(X);
case X of
LES : w := PLESI;
LEQ : W := PLEQI;
GT : W := PGTRI;
GEQ : W := PGEQI;
EQ : W := PEQUI;
NEQ : W := PNEQI;
end; end
else begin
IF (TY[TSP]<>TSTR) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9) else begin
TSP := TSP - 1; TY[TSP] := TBOL;
end;
Pop(X);
case X of
LES : W := PLESSTR;
LEQ : W := PLEQSTR;
GT : W := PGTRSTR;
GEQ : W := PGEQSTR;
EQ : W := PEQUSTR;
NEQ : W := PNEQSTR;
end;
end;
GenByte;
end;
end;

begin
Relation; LFJP := 0; PREV := 0;
while pos(TT,Logicalop)<>0 do begin
X := T; GetSym;
IF (X=KAND) AND (T=KTHEN) THEN
X := KAND + KTHEN
ELSE IF (X=KOR) AND (T=KELSE) THEN
X := KOR + KELSE;
IF (PREV<>0) AND (PREV<>X) THEN Error(10);
if (X=KAND) or (X=KOR) then begin
Push(X); Relation;
IF (TY[TSP]<>TBOL) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9);
TSP := TSP - 1; Pop(X); PREV := X;
IF X=KAND THEN W := PAND ELSE W := POR;
end
else begin
Push(X); T1 := X; W := PDUP; GenByte;
IF T1=(KAND+KTHEN) THEN W := PFJP ELSE W := PNOT; GenByte;
W := PFJP; GenByte;
W := LFJP; LFJP := CP; GenWord;
GetSym; X := LFJP; Push(X); Relation;
IF (TY[TSP]<>TBOL) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9);
TSP := TSP - 1; Pop(LFJP); Pop(X); PREV := X;
IF PREV=(KAND+KTHEN) THEN W := PAND ELSE W := POR;
end;
genbyte;
end;
if prev<>0 then begin
T2 := CP;
WHILE LFJP<>0 do begin
CP := LFJP;
ReadWrd; LFJP := W;
W := T2 - CP - 2; GenWord;
end;
CP := T2;
end;
end;

Procedure Stmt; forward;
{ stmt -> seqofstmts -> stmt. one has to be forwarded }

Procedure SeqOfStmts;
{ 2810 '********** SeqOfStmts }
var
flag : boolean;

Procedure Loop1; {4590}
begin
T0 := KLOOP; TstToken_GetNext; Push(XITJP); XITJP := 0; X := LPFLG; Push(X);
LPFLG := -1; SeqOfStmts; T0 := KEND; TstToken_GetNext;
T0 := KLOOP; TstToken_GetNext; Pop(T5); Pop(X); T6 := X;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;

Procedure Loop2; {4620}
begin
T2 := CP;
WHILE XITJP<>0 do begin
CP := XITJP; ReadWrd; XITJP := W; W := T2 - CP - 2; GenWord;
end;
CP := T2; LPFLG := T5; XITJP := T6;
end;

Procedure FixFJP;
begin
T1 := CP; Pop(CP); W := T1-CP-2; GenWord; CP := T1;
end;

Procedure GenUJP;
{ 3060 '********** Gen UJP }
begin
W := PUJP; GenByte; W := LUJP; LUJP := CP; GenWord;
end;

Procedure Four780;
begin
T0 := EQGT; TstToken_GetNext; Push(CP); Push(T1); Push(LUJP);
CASES := CASES + 1; X := CASES; Push(X); SeqOfStmts; W:= PUJP; GenByte;
Pop(CASES); Pop(X); W := X; LUJP := CP; GenWord;
end;

begin
I := pos(TT,STMTx);
while I<>0 do begin
I := pos(TT,STMTx);
case I of
1..3: begin
if T=KWHILE then begin
Getsym; X := CP; Push(X); Expr; CheckBool;
W := PFJP; GenByte; X := CP; Push(X); W := 0; GenWord;
Loop1; Pop(X); T1 := CP; CP := X; W := T1 - CP + 1; GenWord;
CP := T1; W := PUJP; GenByte; Pop(X);
W := X - CP - 2; GenWord; Loop2; end
else if T=KFOR then begin
Getsym; T0 := kID; TestToken; X := OFST; Push(X); PushSyms;
ADDR := OFST; pTYPE := 1; KIND := 5; PINFO := 0; AddID;
Getsym; T0 := KIN; TstToken_GetNext;
IF T=KREVERSE THEN begin
X := -1; Getsym; end
ELSE X := 1;
Push(X); W := PLLA; GenByte; W := OFST; GenWord;
Se; CheckInt; W := PSTO; GenByte;
X := CP; Push(X); W := PLDL; GenByte; W := OFST; GenWord;
T0 := DOTDOT; TstToken_GetNext; Se; CheckInt;
Pop(T1); Pop(X); IF X<0 THEN W := PGEQI ELSE W := PLEQI;
GenByte; W := PFJP; GenByte; Push(X); Push(T1);
Push(CP); W := 0; GenWord; Push(OFST); OFST := OFST + 2;
IF OFST>MXOF THEN MXOF := OFST;
Loop1; Pop(T3); Pop(T1); Pop(T2); Pop(X);
IF X<0 THEN W := PDECL ELSE W := PINCL;
GenByte; W := T3; GenWord; W := PUJP; GenByte;
W := T2 - CP - 2; GenWord; T2 := CP; CP := T1;
W := T2 - T1 - 2; GenWord; CP := T2; PopSyms;
Delete(S_str[SSP],1,length(s_str[ssp])-LOC2);
Pop(X); OFST := X; Loop2; end
else begin
X := CP; Push(X); Loop1; W := PUJP; GenByte;
Pop(X); W := X - CP - 2; GenWord; Loop2;
end;
end;
4..5: begin
Push(OFST); OFST := OFST + 2; PushSyms;
IF T=KDECLARE THEN begin
Getsym; DeclPart;
end;
Stmt; PopSyms;
Delete(S_str[SSP],1,length(s_str[ssp])-LOC2);
Pop(X); OFST := X;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
6: begin
IF LPFLG=0 THEN error(14);
Getsym;
IF T=SEMICOLON THEN begin
W := PUJP; GenByte; end
else begin
T0 := KWHEN; TstToken_GetNext; Expr; CheckBool;
W := PNOT; GenByte; W := PFJP; GenByte;
end;
W := XITJP; XITJP := CP; GenWord;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
7: begin
Getsym;
IF T<>SEMICOLON THEN begin
Expr; TSP := TSP - 1; W := PRNP; end
ELSE W := PRET;
GenByte;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
8: begin
LUJP := 0; flag := true;
repeat
Getsym; Expr; CheckBool; W := PFJP; GenByte;
Push(CP); GenWord; X := LUJP; Push(X);
T0 := KTHEN; TstToken_GetNext; SeqOfStmts;
Pop(X); LUJP := X;
IF T=KEND THEN
FixFJP
else IF T=KELSEIF THEN begin
GenUJP; FixFJP; flag := false; end
else begin
T0 := KELSE; TstToken_GetNext; GenUJP; FixFJP;
Push(LUJP); SeqOfStmts; Pop(LUJP);
end;
until flag;
T0 := KEND; TstToken_GetNext;
T0 := KIF; TstToken_GetNext; T2 := CP;
WHILE LUJP<>0 do begin
CP := LUJP; ReadWrd; LUJP := W; W := T2-CP-2; GenWord;
end;
CP := T2;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
9: begin
Getsym; Expr;
IF (TY[TSP]<>TINT) AND (TY[TSP]<>TCHR) THEN Error(9);
TSP := TSP - 1; W := PXJP; GenByte; X := CP; Push(X);
GenWord; GenWord; GenWord;
CASES := 0; LUJP := 0; T0 := KIS; TstToken_GetNext;
repeat
T0 := KWHEN; TstToken_GetNext;
IF T=KOTHERS THEN begin
flag := true; Getsym; X := -1; Push(X);
T1 := 1; Four780; end
ELSE begin
T1 := 0;
repeat
flag := false;
if T=kID then begin
LookupID; TN := pCONST;
IF (pTYPE=1) OR (pTYPE=2) THEN T := C;
end;
IF (T<>kCH) AND (T<>C) THEN Error(5);
X := TN; Push(X); T1 := T1 + 1; Getsym;
IF T=BAR THEN begin
Getsym; flag := true;
end;
until not flag;
Four780;
end;
until (T<>KWHEN) or flag;
if not flag then begin
Push(0); Push(0); X := 1; Push(X); CASES := CASES + 1;
end;
T0 := KEND; TstToken_GetNext; T0 := KCASE; TstToken_GetNext;
T1 := SP - 4; T3 := 32767; T4 := -32767;
FOR I:=1 TO CASES-1 do begin
T2 := S[T1]; T1 := T1 - 2;
FOR J:=1 TO T2 do begin
IF S[T1] IF S[T1]>T4 THEN T4 := S[T1];
T1 := T1 - 1;
end;
end;
W := PUJP; GenByte; T5 := CP; Pop(X); Pop(T1); Pop(X);
IF X=-1 THEN begin
W := T1 - CP - 2; GenWord; end
ELSE begin
W := LUJP; LUJP := CP; GenWord;
end;
FOR I:=T3 TO T4 do begin { *** build table }
W := T5 - CP - 3; GenWord;
end;
T7 := CP;
FOR I:=1 TO CASES-1 do begin
Pop(T2); Pop(T6);
FOR T8:=1 TO T2 do begin
Pop(X); CP := T5 + (X-T3)*2 + 2; W := T6 - CP - 2; GenWord;
end;
end;
CP := T7; Pop(X); T2 := CP; CP := X;
W := T3; GenWord; W := T4; GenWord; W := T5 - CP - 2; GenWord;
WHILE LUJP<>0 do begin
CP := LUJP; ReadWrd; LUJP := W; W := T2 - CP - 2; GenWord;
end;
CP := T2;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
10: begin
GetSym;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
11: begin
LookupID;
IF KIND<>2 THEN begin
X := pTYPE; Push(X); LDAdr; Getsym;
if KIND=1 then begin
X := OBJSZ; Push(X); T0 := LP; TstToken_GetNext;
Expr; CheckInt; Pop(X);
if X=2 then W := PIND else begin
W := PIXA; GenByte; W := X;
end;
GenByte; T0 := RP; TstToken_GetNext;
end;
T0 := COLONEQ; TstToken_GetNext; Expr; Pop(X);
IF (X<>TY[TSP]) and ((X<>TINT) or (TY[TSP]<>TBOL)) and
((X<>TBOL) or (TY[TSP]<>TINT)) THEN Error(9);
IF X=TSTR THEN W := PSAS ELSE W := PSTO;
TSP := TSP - 1; GenByte;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end
ELSE begin
Push(ADDR); X := LEX; Push(X);
Getsym;
IF T<>SEMICOLON THEN begin
T0 :=LP; TstToken_GetNext; ActualParam;
T0 := RP; TstToken_GetNext;
end;
CallProc;
IF T=SEMICOLON THEN Getsym ELSE expected(13);
end;
end;
12: Pragma;
end;
end;
end;

Procedure Stmt;
begin
T0 := KBEGIN; TstToken_GetNext; SeqOfStmts; T0 := KEND; TstToken_GetNext;
end;

Procedure BodyPart;
{ 2440 '********** BodyPart }
begin
IF pos(TT,DECLPARTx)<>0 THEN declpart;
CB := GC; CP := 0; Stmt;
end;

Procedure Compilation;
{ 1970 '********** Compilation }
begin
Pragma;
IF T=KPROC THEN begin
Getsym; ParseProc;
T0 := SEMICOLON; TestToken;
end;
end;

Procedure Read_data;
{ 1780 '********** Read Data }
var
temp : integer;
t_str : anystring;
data : text;

Function GetInt(var work : anystring): integer;
var
W,X,Y : integer;
begin
W := pos(',',work);
if (W=1) or (work='') then
X := 0
else if W=0 then begin
val(work,X,Y); W := length(work)
end
else begin
val(copy(work,1,W-1),X,Y);
if Y<>0 then X := 0;
end;
GetInt := X;
delete(work,1,W);
end;

begin
Sym_str := ' '; CH := ' '; TT := ' '; ID := ' '; Buf := ' ';
B_ptr := 0; T := 0; T0 := 0; SP := 0; TSP := 0; OFST := 0;
CP := 0; CB := 0; W := 0; R1 := 0; R2 := 0; T3 := 0;
LOC1 := 0; LOC2 := 0; TN := 0; HASH := 0; T1 := 0; T2 := 0;
SSP := 1; s_str[ssp] := '';

for I:=1 to 128 do D[I] := ' ';
FOR I:=0 TO MB do begin
buffer[I] := D; B[I] := 0;
end;

assign(data,'keywords.txt'); reset(data);
Lp_Str := '';
readln(data); readln(data,t_str);
WHILE T_str>'0' do begin
while t_str>'' do begin
if t_str[1]=',' then begin
LP_str := LP_str + chr(temp); temp := 0; end
else
temp := temp * 10 + ord(t_str[1]) - 48;
delete(t_str,1,1);
end;
lp_str := lp_str + chr(temp); temp := 0;
readln(data,t_str);
end;
for I:=1 to 5 do readln(data);
FOR I:=1 TO 26 do begin
readln(data,t_str); val(t_str,MAP[I],temp);
end;
I := 1;
repeat
readln(data,t_str);
temp := pos(',',t_str); ID := copy(t_str,1,temp-1); delete(t_str,1,temp);
IF ID<>'*END*' THEN begin
ID := ID + copy(SPACEs,1,8-LENgth(ID));
pTYPE := GetInt(t_str);
KIND := GetInt(t_str);
PINFO := GetInt(t_str);
pCONST := GetInt(t_str);
OBJSZ := GetInt(t_str);
ADDR := GetInt(t_str);
LL := GetInt(t_str);
AddID;
END
until ID='*END*';
while not EOF(DATA) do BEGIN
READln(DATA,t_str);
IF LENGTH(T_str)>8 THEN T_str := copy(t_str,1,8);
T_str := T_str + copy(spaces,1,8-LENgth(T_str));
KEYWD[I] := T_str; I := I + 1;
end;
CLOSE(data);
KEYWD[0] := ' '; KEYWD[NKEY] := ' ';
end;

BEGIN
lexch := Alf + Dig + ' @*+=-<>/:;' + #39 + ')(,".#!' + #3 + #96 + #9;
spaces := ''; for I:=1 to 51 do spaces := spaces + ' ';{255 spaces}
for I:=2 to 4 do isopen[I] := false;
for I:=1 to 128 do null_rec[i] := #0;

clst := true; plst := false; clrscr;
writeln('Augusta(tm) Compiler v1.1A');
writeln('(C) Copyright 1983 by Computer Linguistics');
writeln('All rights reserved.');
writeln(CrLf,'Initializing ...'); Read_Data;
SI := 1; LN := 0; EOI := false;
LL := 0; CPROC := 0; PROC := 0; GC := 1920; LPFLG := 0;
write(CrLf,'Source file ? '); readln(Sym_str);
Open_Source;
write('Code file ? '); readln(C_str);
assign(One,C_str); rewrite(One);
R0 := 16; M0 := R0;
write('Listing (Y,)? '); readln(sym_str); sym_str := sym_str + ' ';
IF upcase(sym_str[1])='Y' THEN begin
PLST := true; write(Lst,LP_str);
end;
GetLine; Getsym; Compilation;
seek(One,R0-1); write(One,D);

sym_str := mki(GC) + mki(M0) + MKI(PROC) + mki(0) + MKI(1113);
D := null_rec;
for I:=1 to 10 do D[I] := sym_str[i];
seek(One,0); write(One,D);
FOR I:=1 TO MB do
IF (B[I]<>0) AND (B[I]<>R0) THEN begin
seek(one,B[I]-1); write(one,buffer[i]);
end;
CLOSE(one);
writeln(CrLf,'Compiled OK');
writeln(LN,' lines. ',GC-1920,' bytes.');
END.