Category : Miscellaneous Language Source Code
Archive   : ADA.ZIP
Filename : AUGUSTA.PAS
{ 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]
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]
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,
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.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/