home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / ADA.ZIP / AUGUSTA.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-01-04  |  42.2 KB  |  1,466 lines
  1. Program Augusta;
  2. { A public domain subset of the US Deptartment of Defense }
  3. { computer language Ada. }
  4.  
  5. {$U+,R+}
  6.  
  7. const
  8.   CrLf = #13#10; FF = #12;
  9.  
  10.   quote     = '"';
  11.   alf       = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  12.   lc        = 'abcdefghijklmnopqrstuvwxyz';
  13.   dig       = '0123456789';
  14.   hdig      = '0123456789ABCDEF';
  15.   an        = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_';
  16.  
  17.   PLDCI = 1; PLDL = 2; PLLA = 3; PLDB = 4; PLDO = 5; PLAO = 6; PDUP = 7;
  18.   PLOD = 8; PLDA = 9; PPOP = 10; PSTO = 11; PSINDO = 12; PLCA = 13;
  19.   PSAS = 14; PAND = 16; POR = 17; PNOT = 18; PADI = 19; PNGI = 20;
  20.   PSBI = 21; PMPI = 22; PDVI = 23; PIND = 24; PEQUI = 25; PNEQI = 26;
  21.   PLEQI = 27; PSLDC = 61; PINCL = 80; PDECL = 81; PLESI = 28; PGEQI = 29;
  22.   PGTRI = 30; PEQUSTR = 31; PNEQSTR = 32; PLEQSTR = 33; PLESSTR = 34;
  23.   PGEQSTR = 35; PGTRSTR = 36; PUJP = 37; PFJP = 38; PXJP = 39; PCLP = 40;
  24.   PCGP = 41; PCSP = 42; PRET = 43; PMODI = 45; PCIP = 46; PRNP = 47;
  25.   PEOP = 15; PSLDCN1 = 63; PIXA = 48; PSLDO = 57; PSLAO = 58; PSLLA = 59;
  26.   PSLDLO = 49; PSLDL = 60;
  27.  
  28.   squote = 0; eol = 1; c = 2; lp = 3; rp = 4;
  29.   mul = 5; kdiv = 6; add = 7; subt = 8; les = 9; leq = 10; gt = 11;
  30.   geq = 12; eq = 13; neq = 14; bar = 15; kid = 16;
  31.   sc = 17; comma = 18; semicolon = 19; colon = 20; eqgt = 21;
  32.   coloneq = 22; dot = 23; dotdot = 24; kch = 25; at = 26;
  33.   kand = 27; karray = 28; kbegin = 29; kcase = 30; kconst = 31;
  34.   kdeclare = 32; kelse = 33; kelseif = 34; kend = 35; kexit = 36;
  35.   kfor = 37; kfunc = 38; kif = 39; kin = 40; kis = 41; kloop = 42;
  36.   klast = 43; klen = 44; kmod = 45; knot = 46; knull = 47; kof = 48;
  37.   kor = 49; kothers = 50; kout = 51; kpragma = 52; kproc = 53;
  38.   kret = 54; kreverse = 55; kthen = 56; kwhen = 57; kwhile = 58;
  39.  
  40.   TSTR = 0; TINT = 1; TCHR = 2; TBOL = 4; FMSZ = 14; NKEY = 33; MB = 3;
  41.  
  42.   { Define sets of token numbers as character strings }
  43.   addop     = #7#8;              { ADD,SUBT }
  44.   mulop     = #5#6#45;           { MUL,KDIV,KMOD }
  45.   logicalop = #27#49;            { KAND,KOR }
  46.   unaryop   = #7#8#46;           { ADD,SUBT,KNOT }
  47.   relop     = #9#10#11#12#13#14; { LES,LEQ,GT,GEQ,EQ,NEQ }
  48.   declpartx = #16#53#38#52;      { ID,KPROC,KFUNC,KPRAGMA }
  49.   stmtx     = #58#37#42#32#29#36#54#39#30#47#16#52;
  50.    { KWHILE,KFOR,KLOOP,KDECLARE,KBEGIN,KEXIT,KRET,KIF,KCASE,KNULL,ID,KPRAGMA }
  51.  
  52. type
  53.   anystring       = string[255];
  54.   string2         = string[2];
  55.   string8         = string[8];
  56.   proc_entry_type = record
  57.                       T1 : array[1..2] of char;
  58.                       T2 : array[1..2] of char;
  59.                       T3 : array[1..2] of char;
  60.                       D  : array[1..2] of char;
  61.                       S  : array[1..2] of char;
  62.                     end;
  63.   buffer_type     = array[1..128] of char;
  64.  
  65. var
  66.   spaces,lexch    : anystring;  { constant strings too long to declare }
  67.   null_rec        : buffer_type;
  68.   Plst,Clst       : boolean;    { true if print or crt listing are on }
  69.   LP_Str          : anystring;  { printer init string, read from datafile }
  70.   C_Str           : anystring;
  71.  
  72.   MAP             : array[0..26] of integer;
  73.   KEYWD           : array[0..33] of string8;
  74.   S_str           : array[0..100] of anystring;
  75.   TY              : array[0..20] of integer;
  76.   buffer          : array[0..Mb] of buffer_type;
  77.   B               : array[0..Mb] of integer;
  78.   D               : buffer_type;
  79.   S               : array[0..500] of integer;
  80.   buf             : anystring; { holds the current line }
  81.   B_ptr,Oldb      : integer;   { indexes into buf }
  82.   Ch              : char;      { the most recent char out of buf }
  83.   sym_str         : anystring;
  84.   Id              : string8; { formatted symbol string }
  85.   infile          : array[2..4] of text; { input file variables }
  86.   isopen          : array[2..4] of boolean;
  87.   One             : file of buffer_type; { code output file }
  88.   Ln              : integer;   { line number being proceesed }
  89.   Eoi             : boolean;   { true for end of input }
  90.   LL,L1,P1,C1     : integer;
  91.   Cproc,proc      : integer;   { proc # being compiled, proc count }
  92.   M0              : integer;   { maximum code record }
  93.   TSP,SSP         : integer;   { internal type and symbol stack counter }
  94.   GC,CP,CB,SP     : integer;   { various code pointers }
  95.   SI              : integer;   { input file number (changes with includes) }
  96.   pType,Kind,
  97.   Pinfo,pConst,
  98.   Ofst,MxOf,Addr,
  99.   ObjSz,Lex       : integer;   { procedure descriptors }
  100.   I,J,X,W,Hash    : integer;
  101.   R0,R1,R2        : integer;   { record numbers }
  102.   T1,T2,T3,T4,
  103.   T5,T6,T7,T8     : integer;
  104.   T1_Str,T2_Str   : anystring;
  105.   LOC1,LOC2       : integer;
  106.   T,T0,TN         : integer;   { token numbers and values }
  107.   TT              : char;      {  and character equivalents for search }
  108.   XitJp,LFjp,LUjp : integer;   { heads of lists of jumps to be patched }
  109.   lpflg           : integer; { non-zero when inside a LOOP-END structure }
  110.   cases           : integer;
  111.  
  112. Procedure ShowErr(E : integer);
  113. begin
  114.   writeln(CrLf,'*** Error ',E,' in line ',LN,CrLf,BUF);
  115.   writeln(copy(spaces,1,B_ptr-1),'*');
  116.   if PLST then writeln(Lst,'*** Error ',E,' in line ',LN);
  117. end;
  118.  
  119. Procedure Error(E : integer);
  120. begin
  121.   showerr(E);
  122.   for SI:=2 to 4 do if isopen[SI] then close(infile[SI]);
  123.   close(One);
  124.   halt;
  125. end;
  126.  
  127. Procedure Expected(E : integer);
  128. begin
  129.   writeln(CrLf,T0,' expected'); ShowErr(E);
  130. end;
  131.  
  132. Function MKI(I : integer): string2;
  133. begin
  134.   mki := chr(lo(I)) + chr(hi(I));
  135. end;
  136.  
  137. Procedure Push(X : integer);
  138. { 4280 '********** Push }
  139. begin
  140.   S[SP] := X; SP := SP + 1;
  141. end;
  142.  
  143. Procedure Pop(var X : integer);
  144. { 4300 '********** Pop }
  145. begin
  146.   SP := SP - 1; X := S[SP];
  147. end;
  148.  
  149. Procedure PushSyms;
  150. { 5400 '********** Push Syms }
  151. begin
  152.   X := LENgth(S_str[SSP]);
  153.   IF X=255 THEN begin
  154.     SSP := SSP + 1; s_str[SSP] := '';
  155.     X := 0;
  156.   end;
  157.   Push(X); X := SSP; Push(X);
  158. end;
  159.  
  160. Procedure PopSyms;
  161. { 5500 '********** Pop Syms }
  162. begin
  163.   Pop(X);
  164.   FOR I:=X+1 TO SSP do S_str[I] := '';
  165.   SSP := X; Pop(X); LOC2 := X;
  166. end;
  167.  
  168. Procedure GetBuf;
  169. { 4140 '********** GetBuf }
  170. var
  171.   temp : integer;
  172. begin
  173.   R1 := (CP + CB) div 128 + 1; R2 := (CP + CB) and 127;
  174.   IF R1<>R0 THEN begin
  175.     J := 0;
  176.     for temp:=1 to MB do
  177.       if (B[temp]=R0) or (B[temp]=0) then J := temp;
  178.     IF J<>0 THEN begin
  179.       Buffer[J] := D; B[J] := R0; END
  180.     else begin
  181.       Buffer[0] := D;
  182.       J := trunc(Random*MB) + 1;
  183.       D := Buffer[J];
  184.       while filesize(One)<(B[J]-1) do begin
  185.         seek(One,filesize(One)); write(One,null_rec);
  186.       end;
  187.       Seek(One,B[J]-1); write(One,D);
  188.       Buffer[J] := Buffer[0]; B[J] := R0;
  189.     end;
  190.     J := 0;
  191.     for temp:=1 to MB do
  192.       if B[temp]=R1 then J := temp;
  193.     IF J<>0 THEN begin
  194.       D := Buffer[J]; R0 := R1;
  195.       IF R1>M0 THEN M0 := R1; end
  196.     else begin
  197.       if R1>filesize(One) then
  198.         D := null_rec
  199.       else begin
  200.         seek(One,R1-1); Read(One,D);
  201.       end;
  202.       R0 := R1;
  203.       IF R1>M0 THEN M0 := R1;
  204.     end;
  205.   end;
  206. end;
  207.  
  208. Procedure ReadByte;
  209. { 4260 '********** ReadByte }
  210. begin
  211.   GetBuf;
  212.   W := ord(D[R2+1]);
  213. end;
  214.  
  215. Procedure ReadWrd;
  216. { 4010 '********** read wrd }
  217. begin
  218.   ReadByte; T1 := W;
  219.   CP := CP + 1;
  220.   ReadByte; W := (W shl 8) + T1;
  221.   CP := CP - 1;
  222. end;
  223.  
  224. Procedure GenByte;
  225. { 3990 '********** GenByte }
  226. begin
  227.   GetBuf;
  228.   D[R2+1] := CHR(W);
  229.   CP := CP + 1;
  230. end;
  231.  
  232. Procedure GenWord;
  233. { 4030 '********** GenWord W }
  234. var
  235.   temp    : integer;
  236.   tmp_str : string[2];
  237. begin
  238.   GetBuf;
  239.   IF R2<127 THEN begin
  240.     tmp_str := MKI(W);
  241.     D[R2+1] := tmp_str[1]; D[R2+2] := tmp_str[2];
  242.     CP := CP + 2; end
  243.   else begin
  244.     temp := W;
  245.     W := W and 255;  GenByte;
  246.     W := temp shr 8; GenByte;
  247.   end;
  248. end;
  249.  
  250. Procedure Open_source;
  251. {1230 }
  252. begin
  253.   SI := SI + 1;
  254.   if SI in[2..4] then begin
  255.     assign(infile[SI],sym_str); reset(infile[SI]); isopen[SI] := true;
  256.     end
  257.   else begin
  258.     writeln('Bad file number :',SI); halt;
  259.   end;
  260. end;
  261.  
  262. Procedure Getline;
  263. { 1280 }
  264. begin
  265.   repeat
  266.     LN := LN + 1;
  267.     IF EOF(infile[SI]) THEN begin
  268.       CLOSE(infile[SI]);
  269.       SI := SI - 1;
  270.       IF (SI>1) AND PLST THEN writeln(lst,'* End of INCLUDE');
  271.     end;
  272.     IF SI=1 THEN
  273.       EOI := true
  274.     else begin
  275.       readln(infile[SI],BUF);
  276.       IF PLST THEN begin
  277.         writeln(lst,ln:5,' ',cproc:4,' ',cp:6,' ',ofst:6,' ',copy(BUF,1,54));
  278.         if (LN MOD 60)=0 THEN writeln(lst,ff,LP_Str);
  279.       end;
  280.       IF CLST THEN
  281.         writeln(BUF)
  282.       else IF (LN AND 63)=63 THEN
  283.         writeln(LN,'...');
  284.     end;
  285.   until (buf>'') or EOI;
  286.   if not EOI then begin
  287.     BUF := BUF + CHR(3); B_ptr := 1;
  288.     WHILE BUF[B_ptr]=' ' do B_ptr := B_ptr + 1;
  289.     CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
  290.   end;
  291. end;
  292.  
  293. Procedure Getch;
  294. { 1360 '********** GetCh }
  295. begin
  296.   CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
  297. end;
  298.  
  299. Procedure LookupKeyword;
  300. begin
  301.   HASH := MAP[pos(id[1],ALF)];
  302.   while keywd[hash]<ID do HASH := HASH + 1;
  303.   if keywd[hash]=id then
  304.     T := hash + 26
  305.   else
  306.     T := kID;
  307. end;
  308.  
  309. Procedure GetSStr;
  310. { 1930 '********** Get S$ }
  311. begin
  312.   Sym_str := copy(BUF,OLDB-1,B_ptr-OLDB); {1940}
  313. end;
  314.  
  315. Procedure Getsym;
  316. { 1400 '********** GetSym }
  317. var
  318.   flag : boolean;
  319.   I1   : integer;
  320. begin
  321.   repeat
  322.     oldb := b_ptr; Ch := upcase(Ch);
  323.     I := pos(ch,LEXCH);
  324.     IF I=0 THEN Error(1);
  325.     IF I<27 THEN begin
  326.       sym_str := '';
  327.       while pos(ch,an)<>0 do begin
  328.         IF CH<>'_' THEN Sym_str := Sym_str + CH;
  329.         GetCh; Ch := upcase(Ch);
  330.       end;
  331.       IF LENgth(Sym_str)>8 THEN Sym_str := copy(Sym_str,1,8);
  332.       ID := Sym_str + copy(SPACEs,1,8-LENgth(Sym_str));
  333.       LookupKeyword;
  334.       end
  335.     else begin
  336.       case I of
  337.       27..36: begin
  338.                 TN := 0; I1 := 10;
  339.                 repeat
  340.                   flag := true;
  341.                   WHILE pos(ch,HDIG)<>0 do begin
  342.                     TN := TN * I1 + pos(ch,HDIG) - 1;
  343.                     Getch;
  344.                   end;
  345.                   IF CH='#' THEN begin
  346.                     flag := false; I1 := TN; TN := 0; Getch;
  347.                   end;
  348.                 until flag;
  349.                 T := C;
  350.               end;
  351.           37: begin
  352.                 WHILE CH=' ' do begin
  353.                   CH := BUF[B_ptr]; B_ptr := B_ptr + 1;
  354.                 end;
  355.                 OLDB := B_ptr;
  356.               end;
  357.           38: begin
  358.                 T := AT; Getch;
  359.               end;
  360.           39: begin
  361.                 T := MUL; Getch;
  362.               end;
  363.           40: begin
  364.                 T := ADD; Getch;
  365.               end;
  366.           41: begin
  367.                 Getch;
  368.                 IF CH='>' THEN begin
  369.                   T := EQGT; Getch;
  370.                   end
  371.                 ELSE T := EQ;
  372.               end;
  373.           42: begin
  374.                 T := SUBT; Getch;
  375.                 IF CH='-' THEN begin
  376.                   Getline; OLDB := B_ptr;
  377.                 end;
  378.               end;
  379.           43: begin
  380.                 Getch;
  381.                 IF CH='=' THEN begin
  382.                   T := LEQ; Getch;
  383.                   end
  384.                 ELSE T := LES;
  385.               end;
  386.           44: begin
  387.                 Getch;
  388.                 IF CH='=' THEN begin
  389.                   T := GEQ; Getch;
  390.                   end
  391.                 ELSE T := GT;
  392.               end;
  393.           45: begin
  394.                 Getch;
  395.                 IF CH='=' THEN begin
  396.                   T := NEQ; Getch;
  397.                   end
  398.                 ELSE T := kDIV;
  399.               end;
  400.           46: begin
  401.                 Getch;
  402.                 IF CH='=' THEN begin
  403.                   T := COLONEQ; Getch;
  404.                   end
  405.                 ELSE T := COLON;
  406.               end;
  407.           47: begin
  408.                 T := SEMICOLON; Getch;
  409.               end;
  410.           48: begin
  411.                 Getch; Getch;
  412.                 IF CH<>#39 THEN error(11);
  413.                 Getch; GetSStr;
  414.                 TN := ord(Sym_str[2]); T := kCH;
  415.               end;
  416.           49: begin
  417.                 T := RP; Getch;
  418.               end;
  419.           50: begin
  420.                 T := LP; Getch;
  421.               end;
  422.           51: begin
  423.                 T := COMMA; Getch;
  424.               end;
  425.           52: begin
  426.                 I1 := pos('"',copy(buf,b_ptr,255));
  427.                 IF I1=0 THEN error(10);
  428.                 Sym_str := copy(BUF,B_ptr,I1-1);
  429.                 T := SC; B_ptr := B_ptr + I1; Getch;
  430.               end;
  431.           53: begin
  432.                 T := DOT; Getch;
  433.                 IF CH='.' THEN begin
  434.                   T := DOTDOT; Getch;
  435.                 end;
  436.               end;
  437.           54: begin
  438.                 T := BAR; Getch;
  439.               end;
  440.           55: begin
  441.                 T := BAR; Getch;
  442.               end;
  443.           56: begin
  444.                 GetLine; OLDB := B_ptr;
  445.               end;
  446.           57: begin
  447.                 T := SQUOTE; Getch;
  448.               end;
  449.           58: begin
  450.                 Getch;
  451.                 OLDB := B_ptr;
  452.               end;
  453.         end;
  454.     end;
  455.     IF EOI THEN error(12);
  456.   until oldb<>b_ptr;
  457.   TT := CHR(T);
  458. end;
  459.  
  460. Procedure AddID;
  461. { 3850 '********** Add ID }
  462. begin
  463.   IF (LENgth(S_str[SSP])+17)>255 THEN begin
  464.     SSP := SSP + 1; s_str[ssp] := '';
  465.   end;
  466.   insert(ID+CHR(pTYPE)+CHR(KIND)+CHR(PINFO)+MKI(pCONST)+CHR(OBJSZ)
  467.     +MKI(ADDR)+CHR(LL),s_str[SSP],1);
  468. end;
  469.  
  470. Procedure LookupID;
  471. { 3890 '********** Lookup ID }
  472. var
  473.   work : anystring;
  474. begin
  475.   LOC1 := SSP; Loc2 := 0;
  476.   while (loc1>0) and (Loc2=0) do begin
  477.     LOC2 := pos(ID,S_str[LOC1]);
  478.     IF LOC2=0 THEN LOC1 := LOC1 - 1;
  479.   end;
  480.   IF LOC1<1 THEN Error(2);
  481.   work := s_str[loc1];
  482.   pTYPE := ord(work[loc2+8]); KIND := ord(work[loc2+9]);
  483.   PINFO := ord(work[loc2+10]);
  484.   pCONST := ord(work[loc2+11]) + (ord(work[loc2+12]) shl 8);
  485.   OBJSZ := ord(work[loc2+13]);
  486.   ADDR := ord(work[loc2+14]) + (ord(work[loc2+15]) shl 8);
  487.   LEX := ord(work[loc2+16]);
  488. end;
  489.  
  490. Procedure TestToken;
  491. var
  492.   T_Str : anystring;
  493. begin
  494.   while T0<>T do begin {1950}
  495.     expected(4);
  496.     write('Reenter+ ');
  497.     readln(T_str); BUF := copy(BUF,1,B_ptr-1) + T_str + CHR(3);
  498.     Getch; Getsym;
  499.   end;
  500. end;
  501.  
  502. Procedure TstToken_GetNext;
  503. begin
  504.   IF T0<>T THEN TestToken;
  505.   Getsym;
  506. end;
  507.  
  508. Procedure Get_C;
  509. { 2290 '********** Get C }
  510. var
  511.   v1,v2,v3,v4,v5,v6 : integer; { temp variables to preserve the id }
  512. begin
  513.   IF T=kID THEN begin
  514.     V1 := pTYPE;    V2 := KIND;    V3 := PINFO;
  515.     V4 := pCONST;   V5 := OBJSZ;   V6 := LL;
  516.     LookupID;
  517.     IF (KIND=0) AND (pTYPE=1) THEN begin
  518.       T := C; T2 := pCONST;
  519.     end;
  520.     pTYPE := V1; KIND := V2; PINFO := V3; pCONST := V4; OBJSZ := V5; LL := V6;
  521.   end;
  522.   T0 := C; TstToken_GetNext;
  523. end;
  524.  
  525. Procedure Pragma;
  526. { 2770 '********** Pragma }
  527. var
  528.   t_str : string8;
  529. begin
  530.   while T=KPRAGMA do begin
  531.     Getsym;
  532.     if sym_str='CRT' then begin
  533.       Getsym; T0 := LP; TstToken_GetNext; T_str := Sym_str;
  534.       Getsym; T0 := RP; TstToken_GetNext;
  535.       IF T_str='ON' THEN
  536.         CLST := true
  537.       ELSE
  538.         CLST := false;
  539.       end
  540.     else if sym_str='INCLUDE' then begin
  541.       Getsym; T0 := LP; TstToken_GetNext;
  542.       IF T<>SC THEN Error(9) ELSE begin
  543.         Open_Source; Getsym; T0 := RP; TstToken_GetNext;
  544.       end; end
  545.     else if sym_str='LIST' then begin
  546.       Getsym; T0 := LP; TstToken_GetNext; T_str := Sym_str;
  547.       Getsym; T0 := RP; TstToken_GetNext;
  548.       IF T_str='ON' THEN begin
  549.         PLST := true; write(lst,lp_str); end
  550.       ELSE IF T_str='OFF' THEN
  551.         PLST := false;
  552.     end;
  553.     Getline; Getsym;
  554.   end;
  555. end;
  556.  
  557. Procedure SubTIDUnit;
  558. { 2250 '********** SubtypeIdentificationUnit }
  559. begin
  560.   LookupID;
  561.   IF KIND<>4 THEN error(8);
  562.   IF PINFO=0 THEN KIND := 1 ELSE KIND := 5;
  563.   IF pTYPE<>0 THEN
  564.     Getsym
  565.   else begin
  566.     Getsym;
  567.     IF T=LP THEN begin
  568.       Getsym; Get_C; OBJSZ := TN + 1; T0 := RP; TstToken_GetNext;
  569.     end;
  570.     IF OBJSZ>255 THEN error(15);
  571.   end;
  572. end;
  573.  
  574. Procedure ProcDef;
  575. { 5200 '********** Proc DEF }
  576. begin
  577.   LL := LL + 1; Push(cproc); Push(OFST); Push(MXOF); T0 := kID; TestToken;
  578.   PushSyms;
  579. end;
  580.  
  581. Procedure ProcFormalPart;
  582. { 2100 '********** ProcFormalPart }
  583. var
  584.   flag : boolean;
  585.  
  586.   Procedure ProcParamDecl;
  587.   { 2160 '********** ProcParamDecl }
  588.   var
  589.     flag : boolean;
  590.   begin
  591.     T1_str := '';
  592.     repeat
  593.       flag := true; T0 := kID; TestToken;
  594.       T1_str := T1_str + ID; Getsym;
  595.       IF T=COMMA THEN begin
  596.         Getsym; flag := false;
  597.       end;
  598.     until flag;
  599.     T0 := COLON; TstToken_GetNext; P1 := 1;
  600.     IF T=KOUT THEN begin
  601.       P1 := 2; Getsym; end
  602.     else IF T=KIN THEN Getsym;
  603.     SubTIDUnit; PINFO := P1;
  604.     WHILE LENgth(T1_str)>0 do begin
  605.       T2_str := T2_str + copy(T1_str,1,8) + CHR(pTYPE) + CHR(KIND) + CHR(PINFO)
  606.             + MKI(pCONST) + CHR(OBJSZ) + MKI(0) + CHR(LL);
  607.       delete(T1_str,1,9);
  608.       OFST := OFST-2;
  609.     end;
  610.   end;
  611.  
  612. begin
  613.   T2_str := ''; T0 := LP; TstToken_GetNext;
  614.   repeat
  615.     flag := true;
  616.     ProcParamDecl;
  617.     IF T=SEMICOLON THEN begin
  618.       Getsym; flag := false;
  619.     end;
  620.   until flag;
  621.   T0 := RP; TstToken_GetNext;
  622.   I := OFST;
  623.   repeat
  624.     T1_str := copy(T2_str,1,17); delete(T2_str,1,17);
  625.     IF (LENgth(S_str[SSP])+17)>255 THEN begin
  626.       SSP := SSP + 1; s_str[SSP] := '';
  627.     end;
  628.     insert(copy(T1_str,1,14)+MKI(I)+T1_str[length(T1_str)],S_str[SSP],1);
  629.     I := I + 2;
  630.   until I>(-FMSZ-2);
  631. end;
  632.  
  633. Procedure ProcEndDef;
  634. { 5300 '********** Proc END DEF }
  635.  
  636.   Procedure WriteProc;
  637.   { 4910 '********** WriteProc }
  638.   begin
  639.     T2 := CP; T3 := CB; CB := 0; CP := (ADDR-1)*7 + 128;
  640.     W := C1 - 1920; GenWord; W := L1; GenWord; W := P1; GenWord;
  641.     W := LL; GenByte; CP := T2; CB := T3;
  642.   end;
  643.  
  644. begin
  645.   W := PEOP; GenByte; Pop(P1); Pop(ADDR); CPROC := ADDR; L1 := MXOF;
  646.   C1 := GC; WriteProc; GC := GC + CP;
  647.   LL := LL - 1;
  648.   PopSyms; Delete(S_str[SSP],1,length(s_str[ssp])-LOC2-17);
  649.   Pop(MXOF); Pop(OFST); Pop(X); CPROC := X;
  650. end;
  651.  
  652. Procedure BodyPart; forward;
  653. { parseproc -> bodypart -> declpart -> parseproc or parsefunc. }
  654. { One has to be Forwarded }
  655.  
  656. Procedure ParseProc;
  657. { 2010 '********** Parse Proc }
  658. begin
  659.   ProcDef;
  660.   KIND := 2; PROC := PROC + 1; CPROC := PROC; ADDR := PROC;
  661.   X := ADDR; Push(X); AddID; Getsym;
  662.   OFST := -FMSZ;
  663.   IF T<>KIS THEN begin
  664.     ProcFormalPart;
  665.     T0 := KIS; TestToken;
  666.   end;
  667.   X := -(OFST+FMSZ); Push(X);
  668.   Getsym;OFST := 0; MXOF := 0; BodyPart;
  669.   W := PRET; GenByte;
  670.   ProcEndDef;
  671. end;
  672.  
  673. Procedure ParseFunc;
  674. { 2340 '********** ParseFunc }
  675. begin
  676.   ProcDef;
  677.   KIND := 3; PROC := PROC + 1; CPROC := PROC; ADDR := PROC;
  678.   X := ADDR; Push(X); AddID;
  679.   Push(SSP); X := LENgth(S_str[SSP]); Push(X);
  680.   Getsym; OFST := -FMSZ;
  681.   IF T=LP THEN ProcFormalPart;
  682.   T0 := KRET; TstToken_GetNext; SubTIDUnit; Pop(T2);
  683.   Pop(X); T1 := X; T3 := LENgth(S_str[T1]);
  684.   IF (KIND<>5) OR (OBJSZ<>2) THEN error(16);
  685.   S_str[T1][T3-T2+9] := CHR(pTYPE);
  686.   T0 := KIS; TstToken_GetNext;
  687.   X := -(OFST+FMSZ); Push(X);
  688.   OFST := 0; MXOF := 0; BodyPart; ProcEndDef;
  689. end;
  690.  
  691. Procedure DeclPart;
  692. { 2480 '********** DeclPart }
  693. var
  694.   K1   : integer;
  695.  
  696.   Procedure ObjDecl;
  697.   { 2560 '********** ObjDecl }
  698.   var
  699.     objsize : integer;
  700.   begin
  701.     Getsym;
  702.     while T=COMMA do begin
  703.       Getsym; T0 := kID; TestToken;
  704.       T1_str := T1_str + ID;
  705.       GetSym;
  706.     end;
  707.     T0 := COLON; TstToken_GetNext;
  708.     IF T=KCONST THEN begin
  709.       K1 := 0; OBJSIZE := 0; Getsym; T0 := COLONEQ; TstToken_GetNext;
  710.       IF T=kID THEN
  711.         LookupID
  712.       ELSE begin
  713.         IF T=SUBT THEN begin
  714.           T1 := -1; Getsym; end
  715.         ELSE T1 := 1;
  716.         pCONST := TN*T1;
  717.         IF T=C THEN pTYPE := 1 ELSE pTYPE := 2;
  718.       end;
  719.       Getsym;
  720.       end
  721.     else IF T=KARRAY THEN begin
  722.       K1 := 1; Getsym; T0 := LP; TstToken_GetNext; T2 := TN; Get_C;
  723.       T0:= RP; TstToken_GetNext; T0 := KOF; TstToken_GetNext;
  724.       SubTIDUnit; pCONST := T2; OBJSIZE := (T2+1)*OBJSZ;
  725.       IF (T2<0) OR (T2>16383) THEN error(15);
  726.       end
  727.     else begin
  728.       SubTIDUnit; OBJSIZE := OBJSZ;
  729.     end;
  730.     PINFO := 0; KIND := K1;
  731.     WHILE LENgth(T1_str)>0 do begin
  732.       ID := copy(T1_str,1,8); delete(T1_str,1,8);
  733.       ADDR := OFST; OFST := OFST + OBJSIZE;
  734.       AddID;
  735.     end;
  736.   end;
  737.  
  738. begin
  739.   case T of
  740.         kID: begin
  741.                T1_str := ID; K1 := 5; ObjDecl;
  742.                IF T=SEMICOLON THEN Getsym ELSE expected(13);
  743.              end;
  744.       KPROC: begin
  745.                Getsym; ParseProc;
  746.                IF T=SEMICOLON THEN Getsym ELSE expected(13);
  747.              end;
  748.       KFUNC: begin
  749.                Getsym; ParseFunc;
  750.                IF T=SEMICOLON THEN Getsym ELSE expected(13);
  751.              end;
  752.     KPRAGMA: Pragma
  753.         else error(3);
  754.   end;
  755.   IF pos(TT,DECLPARTx)<>0 THEN
  756.     declpart
  757.   ELSE IF OFST>MXOF THEN MXOF := OFST;
  758. end;
  759.  
  760. Procedure B_B;
  761. begin
  762.   GenByte; W := ADDR; GenByte;
  763. end;
  764.  
  765. Procedure B_W;
  766. begin
  767.   GenByte; W := ADDR; GenWord;
  768. end;
  769.  
  770. Procedure LDCons;
  771. { 3635 '********** LD Cons }
  772. begin
  773.   case TN of
  774.          -1 : begin
  775.                 W := PSLDCN1; Genbyte
  776.               end;
  777.       0..15 : begin
  778.                 W := 64 + TN; Genbyte;
  779.               end;
  780.     16..255 : begin
  781.                 W := PSLDC; GenByte; W := TN; GenByte;
  782.               end;
  783.         else  begin
  784.                 W := PLDCI; GenByte; W := TN; GenWord;
  785.               end;
  786.   end;
  787. end;
  788.  
  789. Procedure LDVal;
  790. { 3820 '********** LD Val }
  791. begin
  792.   IF LEX=1 THEN
  793.     IF ADDR<256 THEN begin
  794.       W := PSLDO; B_B; end
  795.     ELSE begin
  796.       W := PLDO; B_W;
  797.     end
  798.   ELSE IF LEX=LL THEN
  799.     IF (ADDR>=0) AND (ADDR<8) THEN begin
  800.       W := PSLDLO + ADDR; GenByte; end
  801.     else IF (ADDR>7) AND (ADDR<256) THEN begin
  802.       W := PSLDL; B_B; end
  803.     ELSE begin
  804.       W := PLDL; B_W;
  805.     end
  806.   ELSE begin
  807.     W := PLOD; GenByte; W := LL - LEX; B_W;
  808.   end;
  809. end;
  810.  
  811. Procedure LDAdr;
  812. { 4060 '********** LD Adr }
  813. begin
  814.   IF PINFO=2 THEN
  815.     LDVal
  816.   else IF LEX=1 THEN
  817.     IF ADDR<256 THEN begin
  818.       W := PSLAO; B_B; end
  819.     ELSE begin
  820.       W := PLAO; B_W;
  821.     end
  822.   ELSE IF LEX=LL THEN
  823.     IF (ADDR>=0) AND (ADDR<256) THEN begin
  824.       W := PSLLA; B_B; end
  825.     ELSE begin
  826.       W := PLLA; B_W;
  827.     end
  828.   ELSE begin
  829.     W := PLDA; GenByte; W := LL - LEX; B_W;
  830.   end;
  831. end;
  832.  
  833. Procedure CheckBool;
  834. { 4930 '********** Check Bool }
  835. begin
  836.   IF TY[TSP]<>TBOL THEN Error(9);
  837.   TSP := TSP - 1;
  838. end;
  839.  
  840. Procedure CheckInt;
  841. { 4960 '********** Check Int }
  842. begin
  843.   IF TY[TSP]<>TINT THEN Error(9);
  844.   TSP := TSP - 1;
  845. end;
  846.  
  847. Procedure Expr; forward;
  848. { primary -> actualparam -> expr -> se -> primary. One has to be forwarded }
  849.  
  850. Procedure ActualParam;
  851. { 3570 '********** ActualParam }
  852. begin
  853.   IF T=AT THEN begin
  854.     Getsym; T0 := kID; TestToken; LookupID;
  855.     LDAdr; Getsym;
  856.     IF KIND=1 THEN begin
  857.       X := OBJSZ; Push(X);
  858.       T0 := LP; TstToken_GetNext; Expr; CheckInt; Pop(X);
  859.       IF X=2 THEN
  860.         W := PIND
  861.       ELSE begin
  862.         W := PIXA; GenByte; W := X;
  863.       end;
  864.       GenByte; T0 := RP; TstToken_GetNext;
  865.       end;
  866.     end
  867.   ELSE begin
  868.     Expr; TSP := TSP - 1;
  869.   end;
  870.   IF T=COMMA THEN begin
  871.     Getsym; ActualParam;
  872.   end;
  873. end;
  874.  
  875. Procedure CallProc;
  876. { 4100 '********** Call Proc }
  877. begin
  878.   Pop(LEX); Pop(X); ADDR := X;
  879.   if Lex=0 then
  880.     W := PCSP
  881.   else if Lex=2 then
  882.     W := PCGP
  883.   else if LEX=(LL+1) then
  884.     W := PCLP
  885.   else W := PCIP;
  886.   GenByte; W := ADDR; GenByte;
  887. end;
  888.  
  889. Procedure Se;
  890.  
  891.   Procedure Term;
  892.   { 3350 '********** Term }
  893.  
  894.     Procedure Primary;
  895.     { 3610 '********** Primary }
  896.     begin
  897.       case T of
  898.         LP  : begin
  899.                 Getsym; Expr; T0 := RP; TstToken_GetNext;
  900.               end;
  901.         C   : begin
  902.                 TSP := TSP + 1; TY[TSP] := TINT; LDCons; Getsym;
  903.               end;
  904.         kCH : begin
  905.                 TSP := TSP + 1; TY[TSP] := TCHR; LDCons; Getsym;
  906.               end;
  907.         SC  : begin
  908.                 TSP := TSP + 1; TY[TSP] := TSTR;
  909.                 W := PLCA; GenByte; W := LENgth(Sym_str); GenByte;
  910.                 FOR I:=1 TO LENgth(Sym_str) do begin
  911.                   W := ord(Sym_str[I]); GenByte;
  912.                 end;
  913.                 Getsym;
  914.               end;
  915.          else begin
  916.            T0 := kID; TestToken; LookupID;
  917.            IF KIND=0 THEN begin
  918.              TSP := TSP + 1; TY[TSP] := pTYPE; TN := pCONST; LDCons;
  919.              Getsym; end
  920.            else begin
  921.              Getsym;
  922.              IF T=SQUOTE THEN begin
  923.                TSP := TSP + 1; TY[TSP] := TINT; Getsym;
  924.                IF T=KLAST THEN begin
  925.                  W := PLDCI; GenByte; W := pCONST; GenWord; Getsym; end
  926.                else IF T=KLEN THEN begin
  927.                  LDAdr; W := PLDB; GenByte; end
  928.                ELSE Error(7); end
  929.              else IF KIND=4 THEN begin
  930.                X := pTYPE; Push(X); T0:=LP; TstToken_GetNext;
  931.                Expr; T0:=RP; TstToken_GetNext;
  932.                Pop(X); TY[TSP] := X; end
  933.              else begin
  934.                TSP := TSP + 1; TY[TSP] := pTYPE;
  935.                IF pTYPE=0 THEN
  936.                  IF KIND=1 THEN begin
  937.                    LDAdr; X := OBJSZ; Push(X); T0 := LP; TstToken_GetNext;
  938.                    Expr;
  939.                    IF TY[TSP]<>TINT THEN Error(9);
  940.                    TSP := TSP - 1; Pop(X); W := PIXA; GenByte;
  941.                    W := X; GenByte; T0 := RP; TstToken_GetNext; end
  942.                  else LDAdr
  943.                else IF KIND=1 THEN begin
  944.                  LDAdr; T0 := LP; TstToken_GetNext; Expr;
  945.                  IF TY[TSP]<>TINT THEN Error(9);
  946.                  TSP := TSP - 1; W := PIND; GenByte;
  947.                  W := PSINDO; GenByte; T0 := RP; TstToken_GetNext; end
  948.                else IF KIND=3 THEN begin
  949.                  Push(ADDR); X := LEX; Push(X);
  950.                  IF T=LP THEN begin
  951.                    Getsym; ActualParam; T0 := RP; TstToken_GetNext;
  952.                  end;
  953.                  CallProc; end
  954.                else begin
  955.                  LDVal;
  956.                  IF PINFO=2 THEN begin
  957.                    W := PSINDO; GenByte;
  958.                  end;
  959.                end;
  960.              end;
  961.            end;
  962.          end;
  963.       end;
  964.     end;
  965.  
  966.   begin
  967.     Primary;
  968.     while pos(TT,MULOP)<>0 do begin
  969.       X := T; Push(X); Getsym; Primary;
  970.       IF (TY[TSP]<>TY[TSP-1]) OR (TY[TSP]<>TINT) THEN Error(9);
  971.       TSP := TSP - 1;
  972.       Pop(X);
  973.       IF X=MUL THEN
  974.         W := PMPI
  975.       ELSE IF X=kDIV THEN
  976.         W := PDVI
  977.       ELSE W := PMODI;
  978.       GenByte;
  979.     end;
  980.   end;
  981.  
  982. begin
  983.   IF pos(TT,UNARYOP)<>0 THEN begin
  984.     Push(T); X := 1; Push(1); Getsym; end
  985.   ELSE begin
  986.     X := 0; Push(0);
  987.   end;
  988.   Term; Pop(X);
  989.   IF X=1 THEN begin
  990.     Pop(X);
  991.     IF X=SUBT THEN begin
  992.       W := PNGI; GenByte; end
  993.     ELSE begin
  994.       W := PNOT; GenByte;
  995.     end;
  996.   end;
  997.   while pos(TT,ADDOP)<>0 do begin
  998.     X := T; Push(X); Getsym; Term; Pop(X);
  999.     IF X=ADD THEN W := PADI ELSE W := PSBI;
  1000.     IF TY[TSP]<>TINT THEN error(9);
  1001.     TSP := TSP - 1; GenByte;
  1002.   end;
  1003. end;
  1004.  
  1005. Procedure Expr;
  1006. { 3100 '********** Expr }
  1007. var
  1008.   Prev : integer;
  1009.  
  1010.   Procedure Relation;
  1011.   { 3190 '********** Relation }
  1012.   begin
  1013.     Se;
  1014.     IF pos(TT,RELOP)<>0 THEN begin
  1015.       X := T; Push(X); Getsym; Se;
  1016.       IF (TY[TSP]=TINT) or (TY[TSP]=TCHR) or (TY[TSP]=TBOL) THEN begin
  1017.         IF TY[TSP]<>TY[TSP-1] THEN Error(9) ELSE begin
  1018.           TSP := TSP - 1; TY[TSP] := TBOL;
  1019.         end;
  1020.         Pop(X);
  1021.         case X of
  1022.           LES : w := PLESI;
  1023.           LEQ : W := PLEQI;
  1024.            GT : W := PGTRI;
  1025.           GEQ : W := PGEQI;
  1026.            EQ : W := PEQUI;
  1027.           NEQ : W := PNEQI;
  1028.         end; end
  1029.       else begin
  1030.         IF (TY[TSP]<>TSTR) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9) else begin
  1031.           TSP := TSP - 1; TY[TSP] := TBOL;
  1032.         end;
  1033.         Pop(X);
  1034.         case X of
  1035.           LES : W := PLESSTR;
  1036.           LEQ : W := PLEQSTR;
  1037.            GT : W := PGTRSTR;
  1038.           GEQ : W := PGEQSTR;
  1039.            EQ : W := PEQUSTR;
  1040.           NEQ : W := PNEQSTR;
  1041.         end;
  1042.       end;
  1043.       GenByte;
  1044.     end;
  1045.   end;
  1046.  
  1047. begin
  1048.   Relation; LFJP := 0; PREV := 0;
  1049.   while pos(TT,Logicalop)<>0 do begin
  1050.     X := T; GetSym;
  1051.     IF (X=KAND) AND (T=KTHEN) THEN
  1052.       X := KAND + KTHEN
  1053.     ELSE IF (X=KOR) AND (T=KELSE) THEN
  1054.       X := KOR + KELSE;
  1055.     IF (PREV<>0) AND (PREV<>X) THEN Error(10);
  1056.     if (X=KAND) or (X=KOR) then begin
  1057.       Push(X); Relation;
  1058.       IF (TY[TSP]<>TBOL) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9);
  1059.       TSP := TSP - 1; Pop(X); PREV := X;
  1060.       IF X=KAND THEN W := PAND ELSE W := POR;
  1061.       end
  1062.     else begin
  1063.       Push(X); T1 := X; W := PDUP; GenByte;
  1064.       IF T1=(KAND+KTHEN) THEN W := PFJP ELSE W := PNOT; GenByte;
  1065.       W := PFJP; GenByte;
  1066.       W := LFJP; LFJP := CP; GenWord;
  1067.       GetSym; X := LFJP; Push(X); Relation;
  1068.       IF (TY[TSP]<>TBOL) OR (TY[TSP]<>TY[TSP-1]) THEN Error(9);
  1069.       TSP := TSP - 1; Pop(LFJP); Pop(X); PREV := X;
  1070.       IF PREV=(KAND+KTHEN) THEN W := PAND ELSE W := POR;
  1071.     end;
  1072.     genbyte;
  1073.   end;
  1074.   if prev<>0 then begin
  1075.     T2 := CP;
  1076.     WHILE LFJP<>0 do begin
  1077.       CP := LFJP;
  1078.       ReadWrd; LFJP := W;
  1079.       W := T2 - CP - 2; GenWord;
  1080.     end;
  1081.     CP := T2;
  1082.   end;
  1083. end;
  1084.  
  1085. Procedure Stmt; forward;
  1086. { stmt -> seqofstmts -> stmt. one has to be forwarded }
  1087.  
  1088. Procedure SeqOfStmts;
  1089. { 2810 '********** SeqOfStmts }
  1090. var
  1091.   flag  : boolean;
  1092.  
  1093.   Procedure Loop1; {4590}
  1094.   begin
  1095.     T0 := KLOOP; TstToken_GetNext; Push(XITJP); XITJP := 0; X := LPFLG; Push(X);
  1096.     LPFLG := -1; SeqOfStmts; T0 := KEND; TstToken_GetNext;
  1097.     T0 := KLOOP; TstToken_GetNext; Pop(T5); Pop(X); T6 := X;
  1098.     IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1099.   end;
  1100.  
  1101.   Procedure Loop2; {4620}
  1102.   begin
  1103.     T2 := CP;
  1104.     WHILE XITJP<>0 do begin
  1105.       CP := XITJP; ReadWrd; XITJP := W; W := T2 - CP - 2; GenWord;
  1106.     end;
  1107.     CP := T2; LPFLG := T5; XITJP := T6;
  1108.   end;
  1109.  
  1110.   Procedure FixFJP;
  1111.   begin
  1112.     T1 := CP; Pop(CP); W := T1-CP-2; GenWord; CP := T1;
  1113.   end;
  1114.  
  1115.   Procedure GenUJP;
  1116.   { 3060 '********** Gen UJP }
  1117.   begin
  1118.     W := PUJP; GenByte; W := LUJP; LUJP := CP; GenWord;
  1119.   end;
  1120.  
  1121.   Procedure Four780;
  1122.   begin
  1123.     T0 := EQGT; TstToken_GetNext; Push(CP); Push(T1); Push(LUJP);
  1124.     CASES := CASES + 1; X := CASES; Push(X); SeqOfStmts; W:= PUJP; GenByte;
  1125.     Pop(CASES); Pop(X); W := X; LUJP := CP; GenWord;
  1126.   end;
  1127.  
  1128. begin
  1129.   I := pos(TT,STMTx);
  1130.   while I<>0 do begin
  1131.     I := pos(TT,STMTx);
  1132.       case I of
  1133.         1..3: begin
  1134.                 if T=KWHILE then begin
  1135.                   Getsym; X := CP; Push(X); Expr; CheckBool;
  1136.                   W := PFJP; GenByte; X := CP; Push(X); W := 0; GenWord;
  1137.                   Loop1; Pop(X); T1 := CP; CP := X; W := T1 - CP + 1; GenWord;
  1138.                   CP := T1; W := PUJP; GenByte; Pop(X);
  1139.                   W := X - CP - 2; GenWord; Loop2; end
  1140.                 else if T=KFOR then begin
  1141.                   Getsym; T0 := kID; TestToken; X := OFST; Push(X); PushSyms;
  1142.                   ADDR := OFST; pTYPE := 1; KIND := 5; PINFO := 0; AddID;
  1143.                   Getsym; T0 := KIN; TstToken_GetNext;
  1144.                   IF T=KREVERSE THEN begin
  1145.                     X := -1; Getsym; end
  1146.                   ELSE X := 1;
  1147.                   Push(X); W := PLLA; GenByte; W := OFST; GenWord;
  1148.                   Se; CheckInt; W := PSTO; GenByte;
  1149.                   X := CP; Push(X); W := PLDL; GenByte; W := OFST; GenWord;
  1150.                   T0 := DOTDOT; TstToken_GetNext; Se; CheckInt;
  1151.                   Pop(T1); Pop(X); IF X<0 THEN W := PGEQI ELSE W := PLEQI;
  1152.                   GenByte; W := PFJP; GenByte; Push(X); Push(T1);
  1153.                   Push(CP); W := 0; GenWord; Push(OFST); OFST := OFST + 2;
  1154.                   IF OFST>MXOF THEN MXOF := OFST;
  1155.                   Loop1; Pop(T3); Pop(T1); Pop(T2); Pop(X);
  1156.                   IF X<0 THEN W := PDECL ELSE W := PINCL;
  1157.                   GenByte; W := T3; GenWord; W := PUJP; GenByte;
  1158.                   W := T2 - CP - 2; GenWord; T2 := CP; CP := T1;
  1159.                   W := T2 - T1 - 2; GenWord; CP := T2; PopSyms;
  1160.                   Delete(S_str[SSP],1,length(s_str[ssp])-LOC2);
  1161.                   Pop(X); OFST := X; Loop2; end
  1162.                 else begin
  1163.                   X := CP; Push(X); Loop1; W := PUJP; GenByte;
  1164.                   Pop(X); W := X - CP - 2; GenWord; Loop2;
  1165.                 end;
  1166.               end;
  1167.         4..5: begin
  1168.                 Push(OFST); OFST := OFST + 2; PushSyms;
  1169.                 IF T=KDECLARE THEN begin
  1170.                   Getsym; DeclPart;
  1171.                 end;
  1172.                 Stmt; PopSyms;
  1173.                 Delete(S_str[SSP],1,length(s_str[ssp])-LOC2);
  1174.                 Pop(X); OFST := X;
  1175.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1176.               end;
  1177.            6: begin
  1178.                 IF LPFLG=0 THEN error(14);
  1179.                 Getsym;
  1180.                 IF T=SEMICOLON THEN begin
  1181.                   W := PUJP; GenByte; end
  1182.                 else begin
  1183.                   T0 := KWHEN; TstToken_GetNext; Expr; CheckBool;
  1184.                   W := PNOT; GenByte; W := PFJP; GenByte;
  1185.                 end;
  1186.                 W := XITJP; XITJP := CP; GenWord;
  1187.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1188.               end;
  1189.            7: begin
  1190.                 Getsym;
  1191.                 IF T<>SEMICOLON THEN begin
  1192.                   Expr; TSP := TSP - 1; W := PRNP; end
  1193.                 ELSE W := PRET;
  1194.                 GenByte;
  1195.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1196.               end;
  1197.            8: begin
  1198.                 LUJP := 0; flag := true;
  1199.                 repeat
  1200.                   Getsym; Expr; CheckBool; W := PFJP; GenByte;
  1201.                   Push(CP); GenWord; X := LUJP; Push(X);
  1202.                   T0 := KTHEN; TstToken_GetNext; SeqOfStmts;
  1203.                   Pop(X); LUJP := X;
  1204.                   IF T=KEND THEN
  1205.                     FixFJP
  1206.                   else IF T=KELSEIF THEN begin
  1207.                     GenUJP; FixFJP; flag := false; end
  1208.                   else begin
  1209.                     T0 := KELSE; TstToken_GetNext; GenUJP; FixFJP;
  1210.                     Push(LUJP); SeqOfStmts; Pop(LUJP);
  1211.                   end;
  1212.                 until flag;
  1213.                 T0 := KEND; TstToken_GetNext;
  1214.                 T0 := KIF; TstToken_GetNext; T2 := CP;
  1215.                 WHILE LUJP<>0 do begin
  1216.                   CP := LUJP; ReadWrd; LUJP := W; W := T2-CP-2; GenWord;
  1217.                 end;
  1218.                 CP := T2;
  1219.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1220.               end;
  1221.            9: begin
  1222.                 Getsym; Expr;
  1223.                 IF (TY[TSP]<>TINT) AND (TY[TSP]<>TCHR) THEN Error(9);
  1224.                 TSP := TSP - 1; W := PXJP; GenByte; X := CP; Push(X);
  1225.                 GenWord; GenWord; GenWord;
  1226.                 CASES := 0; LUJP := 0; T0 := KIS; TstToken_GetNext;
  1227.                 repeat
  1228.                   T0 := KWHEN; TstToken_GetNext;
  1229.                   IF T=KOTHERS THEN begin
  1230.                     flag := true; Getsym; X := -1; Push(X);
  1231.                     T1 := 1; Four780; end
  1232.                   ELSE begin
  1233.                     T1 := 0;
  1234.                     repeat
  1235.                       flag := false;
  1236.                       if T=kID then begin
  1237.                         LookupID; TN := pCONST;
  1238.                         IF (pTYPE=1) OR (pTYPE=2) THEN T := C;
  1239.                       end;
  1240.                       IF (T<>kCH) AND (T<>C) THEN Error(5);
  1241.                       X := TN; Push(X); T1 := T1 + 1; Getsym;
  1242.                       IF T=BAR THEN begin
  1243.                         Getsym; flag := true;
  1244.                       end;
  1245.                     until not flag;
  1246.                     Four780;
  1247.                   end;
  1248.                 until (T<>KWHEN) or flag;
  1249.                 if not flag then begin
  1250.                   Push(0); Push(0); X := 1; Push(X); CASES := CASES + 1;
  1251.                 end;
  1252.                 T0 := KEND; TstToken_GetNext; T0 := KCASE; TstToken_GetNext;
  1253.                 T1 := SP - 4; T3 := 32767; T4 := -32767;
  1254.                 FOR I:=1 TO CASES-1 do begin
  1255.                   T2 := S[T1]; T1 := T1 - 2;
  1256.                   FOR J:=1 TO T2 do begin
  1257.                     IF S[T1]<T3 THEN T3 := S[T1];
  1258.                     IF S[T1]>T4 THEN T4 := S[T1];
  1259.                     T1 := T1 - 1;
  1260.                   end;
  1261.                 end;
  1262.                 W := PUJP; GenByte; T5 := CP; Pop(X); Pop(T1); Pop(X);
  1263.                 IF X=-1 THEN begin
  1264.                   W := T1 - CP - 2; GenWord; end
  1265.                 ELSE begin
  1266.                   W := LUJP; LUJP := CP; GenWord;
  1267.                 end;
  1268.                 FOR I:=T3 TO T4 do begin     { *** build table }
  1269.                   W := T5 - CP - 3; GenWord;
  1270.                 end;
  1271.                 T7 := CP;
  1272.                 FOR I:=1 TO CASES-1 do begin
  1273.                   Pop(T2); Pop(T6);
  1274.                   FOR T8:=1 TO T2 do begin
  1275.                     Pop(X); CP := T5 + (X-T3)*2 + 2; W := T6 - CP - 2; GenWord;
  1276.                   end;
  1277.                 end;
  1278.                 CP := T7; Pop(X); T2 := CP; CP := X;
  1279.                 W := T3; GenWord; W := T4; GenWord; W := T5 - CP - 2; GenWord;
  1280.                 WHILE LUJP<>0 do begin
  1281.                   CP := LUJP; ReadWrd; LUJP := W; W := T2 - CP - 2; GenWord;
  1282.                 end;
  1283.                 CP := T2;
  1284.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1285.               end;
  1286.           10: begin
  1287.                 GetSym;
  1288.                 IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1289.               end;
  1290.           11: begin
  1291.                 LookupID;
  1292.                 IF KIND<>2 THEN begin
  1293.                   X := pTYPE; Push(X); LDAdr; Getsym;
  1294.                   if KIND=1 then begin
  1295.                     X := OBJSZ; Push(X); T0 := LP; TstToken_GetNext;
  1296.                     Expr; CheckInt; Pop(X);
  1297.                     if X=2 then W := PIND else begin
  1298.                       W := PIXA; GenByte; W := X;
  1299.                     end;
  1300.                     GenByte; T0 := RP; TstToken_GetNext;
  1301.                   end;
  1302.                   T0 := COLONEQ; TstToken_GetNext; Expr; Pop(X);
  1303.                   IF (X<>TY[TSP]) and ((X<>TINT) or (TY[TSP]<>TBOL)) and
  1304.                      ((X<>TBOL) or (TY[TSP]<>TINT)) THEN Error(9);
  1305.                   IF X=TSTR THEN W := PSAS ELSE W := PSTO;
  1306.                   TSP := TSP - 1; GenByte;
  1307.                   IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1308.                   end
  1309.                 ELSE begin
  1310.                   Push(ADDR); X := LEX; Push(X);
  1311.                   Getsym;
  1312.                   IF T<>SEMICOLON THEN begin
  1313.                     T0 :=LP; TstToken_GetNext; ActualParam;
  1314.                     T0 := RP; TstToken_GetNext;
  1315.                   end;
  1316.                   CallProc;
  1317.                   IF T=SEMICOLON THEN Getsym ELSE expected(13);
  1318.                 end;
  1319.               end;
  1320.           12: Pragma;
  1321.       end;
  1322.   end;
  1323. end;
  1324.  
  1325. Procedure Stmt;
  1326. begin
  1327.   T0 := KBEGIN; TstToken_GetNext; SeqOfStmts; T0 := KEND; TstToken_GetNext;
  1328. end;
  1329.  
  1330. Procedure BodyPart;
  1331. { 2440 '********** BodyPart }
  1332. begin
  1333.   IF pos(TT,DECLPARTx)<>0 THEN declpart;
  1334.   CB := GC; CP := 0; Stmt;
  1335. end;
  1336.  
  1337. Procedure Compilation;
  1338. { 1970 '********** Compilation }
  1339. begin
  1340.   Pragma;
  1341.   IF T=KPROC THEN begin
  1342.     Getsym; ParseProc;
  1343.     T0 := SEMICOLON; TestToken;
  1344.   end;
  1345. end;
  1346.  
  1347. Procedure Read_data;
  1348. { 1780 '********** Read Data }
  1349. var
  1350.   temp  : integer;
  1351.   t_str : anystring;
  1352.   data  : text;
  1353.  
  1354.   Function GetInt(var work : anystring): integer;
  1355.   var
  1356.     W,X,Y : integer;
  1357.   begin
  1358.     W := pos(',',work);
  1359.     if (W=1) or (work='') then
  1360.       X := 0
  1361.     else if W=0 then begin
  1362.       val(work,X,Y); W := length(work)
  1363.       end
  1364.     else begin
  1365.       val(copy(work,1,W-1),X,Y);
  1366.       if Y<>0 then X := 0;
  1367.     end;
  1368.     GetInt := X;
  1369.     delete(work,1,W);
  1370.   end;
  1371.  
  1372. begin
  1373.   Sym_str := ' '; CH := ' '; TT := ' '; ID := ' '; Buf := ' ';
  1374.   B_ptr := 0;    T := 0; T0 := 0;   SP := 0; TSP := 0; OFST := 0;
  1375.      CP := 0;   CB := 0;  W := 0;   R1 := 0;  R2 := 0;   T3 := 0;
  1376.    LOC1 := 0; LOC2 := 0; TN := 0; HASH := 0;  T1 := 0;   T2 := 0;
  1377.     SSP := 1; s_str[ssp] := '';
  1378.  
  1379.   for I:=1 to 128 do D[I] := ' ';
  1380.   FOR I:=0 TO MB do begin
  1381.     buffer[I] := D; B[I] := 0;
  1382.   end;
  1383.  
  1384.   assign(data,'keywords.txt'); reset(data);
  1385.   Lp_Str := '';
  1386.   readln(data); readln(data,t_str);
  1387.   WHILE T_str>'0' do begin
  1388.     while t_str>'' do begin
  1389.       if t_str[1]=',' then begin
  1390.         LP_str := LP_str + chr(temp); temp := 0; end
  1391.       else
  1392.         temp := temp * 10 + ord(t_str[1]) - 48;
  1393.       delete(t_str,1,1);
  1394.     end;
  1395.     lp_str := lp_str + chr(temp); temp := 0;
  1396.     readln(data,t_str);
  1397.   end;
  1398.   for I:=1 to 5 do readln(data);
  1399.   FOR I:=1 TO 26 do begin
  1400.     readln(data,t_str); val(t_str,MAP[I],temp);
  1401.   end;
  1402.   I := 1;
  1403.   repeat
  1404.     readln(data,t_str);
  1405.     temp := pos(',',t_str); ID := copy(t_str,1,temp-1); delete(t_str,1,temp);
  1406.     IF ID<>'*END*' THEN begin
  1407.       ID := ID + copy(SPACEs,1,8-LENgth(ID));
  1408.       pTYPE := GetInt(t_str);
  1409.       KIND := GetInt(t_str);
  1410.       PINFO := GetInt(t_str);
  1411.       pCONST := GetInt(t_str);
  1412.       OBJSZ := GetInt(t_str);
  1413.       ADDR := GetInt(t_str);
  1414.       LL := GetInt(t_str);
  1415.       AddID;
  1416.     END
  1417.   until ID='*END*';
  1418.   while not EOF(DATA) do BEGIN
  1419.     READln(DATA,t_str);
  1420.     IF LENGTH(T_str)>8 THEN T_str := copy(t_str,1,8);
  1421.     T_str := T_str + copy(spaces,1,8-LENgth(T_str));
  1422.     KEYWD[I] := T_str; I := I + 1;
  1423.   end;
  1424.   CLOSE(data);
  1425.   KEYWD[0] := ' '; KEYWD[NKEY] := ' ';
  1426. end;
  1427.  
  1428. BEGIN
  1429.   lexch  := Alf + Dig + ' @*+=-<>/:;' + #39 + ')(,".#!' + #3 + #96 + #9;
  1430.   spaces := ''; for I:=1 to 51 do spaces := spaces + '     ';{255 spaces}
  1431.   for I:=2 to 4 do isopen[I] := false;
  1432.   for I:=1 to 128 do null_rec[i] := #0;
  1433.  
  1434.   clst := true; plst := false; clrscr;
  1435.   writeln('Augusta(tm) Compiler v1.1A');
  1436.   writeln('(C) Copyright 1983 by Computer Linguistics');
  1437.   writeln('All rights reserved.');
  1438.   writeln(CrLf,'Initializing ...'); Read_Data;
  1439.   SI := 1; LN := 0; EOI := false;
  1440.   LL := 0; CPROC := 0; PROC := 0; GC := 1920; LPFLG := 0;
  1441.   write(CrLf,'Source file ? '); readln(Sym_str);
  1442.   Open_Source;
  1443.   write('Code file ? '); readln(C_str);
  1444.   assign(One,C_str); rewrite(One);
  1445.   R0 := 16; M0 := R0;
  1446.   write('Listing (Y,<N>)? '); readln(sym_str); sym_str := sym_str + ' ';
  1447.   IF upcase(sym_str[1])='Y' THEN begin
  1448.     PLST := true; write(Lst,LP_str);
  1449.   end;
  1450.   GetLine; Getsym; Compilation;
  1451.   seek(One,R0-1); write(One,D);
  1452.  
  1453.   sym_str := mki(GC) + mki(M0) + MKI(PROC) + mki(0) + MKI(1113);
  1454.   D := null_rec;
  1455.   for I:=1 to 10 do D[I] := sym_str[i];
  1456.   seek(One,0); write(One,D);
  1457.   FOR I:=1 TO MB do
  1458.     IF (B[I]<>0) AND (B[I]<>R0) THEN begin
  1459.       seek(one,B[I]-1); write(one,buffer[i]);
  1460.     end;
  1461.   CLOSE(one);
  1462.   writeln(CrLf,'Compiled OK');
  1463.   writeln(LN,' lines. ',GC-1920,' bytes.');
  1464. END.
  1465.  
  1466.