Добавил:
Studfiles2
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Предмет:
Файл:
(*
* Grams.pas - модуль Синтаксического Анализа, Семантического Анализа и генерации Промежуточного кода
* ver. 0.37
* 21.05.2007 serg
*)
(* Список Fix-ов
* 1) в readRul() - путь до файлов таблиц => подкаталог DMP
* 2) в readFG() - путь до файлов таблиц => подкаталог DMP
* 3) proc_EXP() - изменение в readFG() размеров таблиц EXP_ga.txt и EXP_fa.txt
* 4) proc_EXP() - изменение в not action('Exp') размеров таблиц EXP_ga.txt и EXP_fa.txt
*
* BigFix
* 5) furl() - весь блок "Exp" - переписан под новую txt-таблицу ДМП
*
* 6) in Big Fix 5 - исправление ошибки <Одиночный идентификатор> [в стек: 'k' => '_401']
* 7) furl() - исправление ошибки <Унарный минус> [добавление минуса в таблицу констант]
* 8) furl() - исправление ошибки <Присвоение Константе>
*
* 9##) добавление операции WRTS(_STR)
*
* 10##) "HTABLE" - исправление работы с временной таблицей hTable (типы)
*
* 11##) "SBT" - исправление проверки границ в описании диапазонов
*
* 12##) "SUBS" - исправление генерации триад довтупа к элементу матрицы
*
* 13##) "STRT" - переписана грамматика STRT - "хвост" [_NUM,_NUM]
*
* 14) оператор EQ в грамматике OP: если слева ячейка, то триада EQA
*
* 15) in Fix 12## - в грамматике OP: если слева ячейка то SUBS ==> ADDR
*
* 16) в грамматике OP: добавление правила 23 (WRITEM)
*
* 17) в грамматике OP: изменение правила 11 (CON вместо SIZE)
*)
unit Grams;
interface
uses Crt, uStack, Lex, Outtriad;
const
f_name = 'input.txt';
f_output = 'output.txt';
type
(* Fix 9## 1 edit*)
(*
Table = array [0..62, 0..29] of Tokens;
Rules = array [0..1, 1..21] of Tokens;
*)
Table = array [0..70, 0..32] of Tokens;
Rules = array [0..1, 1..23] of Tokens;
(* end Fix 9## 1*)
Ends = array [1..7] of Tokens;
var
f_in: Text;
f_out: Text;
stack: tList;
fa, ga: Table;
rul: Rules;
eps: Ends;
c: Char;
w: Boolean;
procedure setF_in;
function proc_MC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_SBT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_STRT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_CSEC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_VLT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_VSEC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_PROG(var c: Char; var w: Boolean; num: Byte; var eps: Ends; var line: Integer): Boolean;
function proc_LOP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_OP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_IFOP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_EXP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
function proc_LV(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
implementation
procedure setF_in;
var filename: string;
begin
stack := CreateList;
initTriads;
lines := 1;
typeTable := CreateTable(0);
constTable := CreateTable(200);
varTable := CreateTable(400);
labelTable := CreateTable(600);
matrTable := CreateTable(800);
hTable := CreateTable(1200);
(*Fix 9## 2 add*)
StrCount := 0;
(*end Fix 9## 2*)
filename := paramStr(1);
if filename='' then begin
write('input file ("Enter" for default "input.txt") ->');
readln(filename);
if filename = '' then filename := f_name;
end;
Assign(f_in, filename);
Reset (f_in);
Assign(f_out, f_output);
ReWrite (f_out);
end;
procedure readRul(f_name: String; var rul: Rules);
var
f_in: Text;
i, j: Byte;
c: Char;
begin
{$I-}
(* FIX 1 *)
(* Assign(f_in, f_name); *) (* было *)
Assign(f_in, 'DMP\'+f_name); (* стало *)
(* end FIX 1 *)
Reset (f_in);
{$I+}
if IOResult <> 0 then begin
Write('Can not read file');
end
else begin
i := 0;
j := 1;
rul[i, j] := '';
While not Eof(f_in) do begin
Read(f_in, c);
if Ord(c) in [10, 13, 32] then begin
i := (i + 1) mod 2;
if i = 0 then j := j + 1;
rul[i, j] := '';
repeat Read(f_in, c) until not (Ord(c) in [10, 13, 32]) or Eof(f_in);
end;
rul[i, j] := rul[i, j] + c;
end;
Close(f_in);
end;
end;
procedure readFG(f_name: String; var fg: Table; x, y: Byte);
var
f_in: Text;
c: Char;
i, j: Byte;
begin
{$I-}
(* FIX 2 *)
(* Assign(f_in, f_name); *) (* было *)
Assign(f_in, 'DMP\'+f_name); (* стало *)
(* end FIX 2 *)
Reset (f_in);
{$I+}
if IOResult <> 0 then begin
Write('Can not read file');
end
else begin
i := 0;
j := 0;
fg[i, j] := '';
Read(f_in, c);
While not Eof(f_in) do begin
if Ord(c) in [10, 13, 32] then begin
j := (j + 1) mod (y + 1);
if j = 0 then i := i + 1;
fg[i, j] := '';
repeat Read(f_in, c) until not (Ord(c) in [10, 13, 32]) or Eof(f_in);
end
else begin
fg[i, j] := fg[i, j] + c;
Read(f_in, c);
end;
end;
fg[i, j] := fg[i, j] + c;
Close(f_in);
end;
end;
procedure ReadHTable;
var
p: tTable;
begin
p := hTable;
hTable := hTable^.next;
Dispose(p);
while hTable^.num <> 1200 do begin
p := hTable;
hTable := hTable^.next;
(*Fix 10## "HTABLE" *)
(*
AddRow(varTable,p^.id,varTable^.col1,'','','');
*)
if (SearchId(varTable,p^.id) = nil ) then AddRow(varTable,p^.id,toUpperCase(varTable^.col1),'','','');
(*end Fix 10## *)
Dispose(p);
end
end;
function Conv(v: Tokens): Tokens;
var
p: tTable;
begin
if v = 'INTEGER' then Conv := '4'
else
if v = 'BOOLEAN' then Conv := '1'
else begin
p := SearchId(typeTable,v);
if (p^.col1 = '4')and(p^.col4 = '') then Conv := '4'
else
Conv := 'MATR'
end
end;
function search(var fg: Table; x, y: Byte; ex, ey: Tokens): Tokens;
var
i, j, x0, y0: Byte;
begin
y0 := 0;
x0 := 0;
for j := 1 to x do
if ex = fg[j,0] then
x0 := j;
for j := 1 to y do
if ey = fg[0,j] then
y0 := j;
{ Write('(*) ',ex,' ',y0, '(*) ');
for i := 0 to 0 do begin
for j := 0 to y do
write(fg[i,j], ' ');
writeln('');
end;
ReadLn;}
if (x0 = 0)or(y0 = 0) then
search := 'U'
else
search := fg[x0,y0];
end;
function furl(nm: Tokens; mx, mg, num: Byte): Boolean;
var
q: Boolean;
p: tTable;
t: Tokens;
i,k,m,j: Byte;
e, tmp1: Integer;
v1,v2,s1,s2,p1,p2,str1,str2, typeName: String;
begin
furl := true;
Val(rul[1, num],j,e);
if e = 0 then begin
if nm = 'PROG' then begin
case num of
18,19: getValue(v1,v2,stack,1);
16,17: begin
getValue(v1,v2,stack,1);
if isExist(v1) <> nil then begin
WriteLn(f_out,'ERROR: LABEL: Duplicate identifier "',v1,'"(line ',lines,')');
furl := false
end
else
AddRow(labelTable,v1,'','','','');
end;
14: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
if isExist(s1) <> nil then begin
WriteLn(f_out,'ERROR: TYPE: Duplicate identifier "',s1,'"(line ',lines,')');
furl := false
end
else
if v1 = 'INTEGER' then
AddRow(varTable,s1,'4','','','')
else
if v1 = 'BOOLEAN' then
AddRow(typeTable,s1,'1','','','')
else
if v2 = 'SUB' then begin
p := isExist(v1);
AddRow(typeTable,s1,'4',p^.col2,p^.col3,'');
DelHRow;
end;
if v2 = 'MATR' then begin
p := isExist(v1);
AddRow(typeTable,s1,'5',p^.col1,p^.col2,'');
DelHRow;
end
else begin (*old MATR*)
p := isExist(v1);
AddRow(typeTable,s1,toUpperCase(p^.col1),p^.col2,p^.col3,p^.col4);
DelHRow;
end
end
end
end;
(*Fix 13## STRT *)
if nm = 'STRT' then begin
case num of
2: begin
getValue(v1,v2,stack,1);
if (SearchId(constTable,v1) <> nil) then begin
p := isExist(v1);
v1 := p^.col2;
Val(v1,tmp1,e);
if e = 0 then
if (tmp1<=0)or(tmp1>16) then begin
WriteLn(f_out,'ERROR: STRT: index not in [1..16] (line ',lines,')');
close(f_out);
halt;
furl := false
end;
end;
if (v2 <> 'INTEGER') then begin
WriteLn(f_out,'ERROR: STRT: index not Integer (line ',lines,')');
close(f_out);
halt;
furl := false
end;
end;
3: begin
getValue(v1,v2,stack,1);
Val(v1,tmp1,e);
if e = 0 then
if (tmp1<=0)or(tmp1>16) then begin
WriteLn(f_out,'ERROR: STRT: index not in [1..16] (line ',lines,')');
close(f_out);
halt;
furl := false
end;
end;
1: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
Str(hTable^.num+1,p1);
AddRow(hTable,'_'+p1,s1,v1,'','');
v1 := '_'+p1
end;
end; (*case*)
end; (*if nm = 'STRT'*)
{ if nm = 'STRT' then begin
getValue(v1,v2,stack,4);
getValue(s1,s2,stack,6);
p := isExist(v1);
if (p = nil)or(isExist(s1) = nil) then begin
WriteLn(f_out,'ERROR: STRT: Unknown identifier (line ',lines,')');
furl := false
end
else
if (p^.num > 200)and(p^.num < 1200)or(p^.col2 = '')and(p^.num < 200) then begin
WriteLn(f_out,'ERROR: STRT: Error in type (line ',lines,')');
furl := false
end
else begin
v1 := p^.col2;
v2 := p^.col3;
p := isExist(s1);
if (p^.num > 200)and(p^.num < 1200)or(p^.col2 = '')and(p^.num < 200) then begin
WriteLn(f_out,'ERROR: STRT: Error in type (line ',lines,')');
furl := false
end
else begin
Str(hTable^.num+1,p1);
(*Fix tmp 2*)
(* it's my bad code
s1 := p^.col2;
s2 := p^.col3;
DelHRow;
AddRow(hTable,'_'+p1,s1,s2,v1,v2);
*)
AddRow(hTable,'_'+p1,p^.col2,p^.col3,v1,v2);
(*end Fix tmp 2*)
(*Fix tmp 1*)
(*
AddRow(typeTable,'_'+p1,p^.col2,p^.col3,v1,v2);
*)
v1 := '_'+p1
end
end
end;
}
(*end Fix 13## STRT *)
if nm = 'SBT' then begin
case num of
5..6: getValue(v1,v2,stack,1);
7: begin getValue(v1,v2,stack,1); v1 := '-' + v1 end;
1..4: begin
q := true;
getValue(v1,v2,stack,1);
getValue(s1,s2,stack,3);
p := isExist(v1);
if (p = nil)and(v2 <> 'INTEGER') then begin
WriteLn(f_out,'ERROR: SBT: Unknown identifier (line ',lines,')');
q := false;
furl := false
end
else
if v2 <> 'INTEGER' then begin
if (p^.num < 200)and(p^.num > 400)
or(p^.col1 <> 'INTEGER') then begin
WriteLn(f_out,'ERROR: SBT: Error in type (line ',lines,')');
q := false;
furl := false
end
else
v1 := p^.col2;
end;
p := isExist(s1);
if (p = nil)and(s2 <> 'INTEGER') then begin
WriteLn(f_out,'ERROR: SBT: Unknown identifier (line ',lines,')');
q := false;
furl := false
end
else
if s2 <> 'INTEGER' then begin
if (p^.num < 200)and(p^.num > 400)
or(p^.col1 <> 'INTEGER') then begin
WriteLn(f_out,'ERROR: SBT: Error in type');
q := false;
furl := false
end
else
s1 := p^.col2;
end;
if q then begin
Val(s1,i,e);
if e = 0 then
Val(v1,k,e);
if e = 0 then begin
if i > k then begin
WriteLn(f_out,'ERROR: SBT: Lower bound greater than upper bound (line ',lines,')');
furl := false
end
else begin
Str(hTable^.num+1,p1);
AddRow(hTable,'_'+p1,'4',s1,v1,'');
(*Fix 10## "HTABLE" *)
(*
AddRow(typeTable,'_'+p1,'4',s1,v1,'');
*)
v1 := '_'+p1;
end
end
end
end
end
end;
if nm = 'OP' then begin
case num of
11: begin
getValue(v1,v2,stack,6);
getValue(s1,s2,stack,4);
getValue(p1,p2,stack,2);
if (Conv(v2) <> 'MATR')or(Conv(s2) <> 'MATR')or(Conv(p2) <> 'MATR') then begin
(* тут - не матрицы *)
WriteLn(f_out,'ERROR: OP: Matrix expected (line ',lines,')');
furl := false
end else begin
(* тут - матрицы *)
(* проверим размерности *)
p := SearchId(varTable,v1);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',v1,'not found in varTable');
Str(p^.num,v1);
v1 := '_'+v1;
typeName := p^.col1;
p := SearchId(typeTable,typeName);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',v1,': ',typeName,' not found in typeTable');
v2 := 'M_'+p^.col2+'_'+p^.col3;
p := SearchId(varTable,s1);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',s1,'not found in varTable');
Str(p^.num,s1);
s1 := '_'+s1;
typeName := p^.col1;
p := SearchId(typeTable,typeName);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',s1,': ',typeName,' not found in typeTable');
s2 := 'M_'+p^.col2+'_'+p^.col3;
p := SearchId(varTable,p1);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',p1,'not found in varTable');
Str(p^.num,p1);
p1 := '_'+p1;
typeName := p^.col1;
p := SearchId(typeTable,typeName);
if (p=nil) then writeln(f_out, ' ERROR: Matrix ',p1,': ',typeName,' not found in typeTable');
p2 := 'M_'+p^.col2+'_'+p^.col3;
if (v2 = s2)and(v2 = p2) then begin
getValue(str1,str2,stack,8);
out_triad(f_out,toUpperCase(str1),v1,s1,''); (*'DIS' или 'CON'*)
out_triad(f_out,'LDM',p1,'','');
end else begin
WriteLn(f_out,'ERROR: OP: Matrix type mismatch (line ',lines,')');
furl := false;
end;
end;
end;
(*Fix 16 (CON вместо SIZE) *)
(*
11: begin
getValue(v1,v2,stack,6);
getValue(s1,s2,stack,4);
getValue(p1,p2,stack,2);
p2 := Conv(p2);
s2 := Conv(s2);
if (p2 <> '4')or(s2 <> '4') then begin
WriteLn(f_out,'ERROR: OP: Integer expected (line ',lines,')');
furl := false
end
else begin
v2 := Conv(v2);
if (v2 = '4')or(v2 = '1') then begin
WriteLn(f_out,'ERROR: OP: Matrix expected (line ',lines,')');
furl := false
end
else begin
if SearchId(varTable,p1) <> nil then begin
p := isExist(p1);
Str(p^.num,p1);
p1 := '_' + p1;
end;
if SearchId(varTable,s1) <> nil then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
if (SearchId(varTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
out_triad(f_out,'SIZE',v1,s1,p1);
end
end
end;
*)
(*end Fix 16 (CON вместо SIZE) *)
(*Fix 16 add*)
23: begin
getValue(v1,v2,stack,2);
if (SearchId(varTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
if Conv(p^.col1) <> 'MATR' then begin
WriteLn(f_out,'ERROR: OP: Matrix expected (line ',lines,')');
furl := false
end else begin
Str(p^.num,v1);
v1 := '_' + v1;
out_triad(f_out,'WRTM',v1,'','');
end;
end;
end;
(*end Fix 16 *)
(*Fix 9## 3 add*)
22: begin
getValue(v1,v2,stack,2);
out_triad(f_out,'WRTS',v1,'','');
end;
(*end Fix 9## 3 *)
6: begin
getValue(v1,v2,stack,1);
getValue(s1,s2,stack,4);
if v2 <> 'BOOLEAN' then begin
WriteLn(f_out,'ERROR: OP: Boolean expresion expected (line ',lines,')');
furl := false
end
else
out_triad(f_out,'BF',v1,s1,'');
end;
20,21: begin
getValue(v1,v2,stack,1);
out_triad(f_out,'WRT',v1,'','');
end;
7,8: begin
getValue(v1,v2,stack,1);
if SearchId(labelTable,v1) = nil then begin
WriteLn(f_out,'ERROR: OP: Unknown label-identifier (line ',lines,')');
furl := false
end
else
out_triad(f_out,'BRL',v1,'','');
end;
13,14,19: begin v1 := stack^.value1; v2 := 'INTEGER' end;
15..18: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
getValue(p1,p2,stack,6);
p := isExist(p1);
if p = nil then begin
WriteLn(f_out,'ERROR: OP: Unknown identifier (line ',lines,')');
furl := false
end
else begin
p := SearchId(typeTable,p2);
if p = nil then p := SearchId(matrTable,p1);
(*old Fix tmp if (p = nil)or(p^.col4 = '') then begin *)
if (p = nil) then begin
WriteLn(f_out,'ERROR: OP: Invalid qualifier (line ',lines,')');
furl := false
end
else begin
v2 := Conv(v2);
s2 := Conv(s2);
if (v2 <> '4')or(s2 <> '4') then begin
WriteLn(f_out,'ERROR: OP: Type mismatch (line ',lines,')');
furl := false
end
else begin
(*Fix tmp (SBT ==> NM)*)
Val(p^.col2,k,e);
Val(s1,m,e);
if (e = 0)and((1>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: OP: Constant out of rang (1line ',lines,')');
furl := false
end
else begin
(*Fix tmp (SBT ==> NM)*)
Val(p^.col3,k,e);
Val(v1,m,e);
if (e = 0)and((1>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: OP: Constant out of rang (2line ',lines,')');
furl := false
end
else begin
(*Fix 12## "SUBS" *)
(*
v1 := out_triad(f_out,'SUBS',p1,s1,v1);
*)
if (SearchId(varTable,p1) <> nil)or(SearchId(matrTable,p1) <> nil) then begin
p := isExist(p1);
Str(p^.num,p1);
p1 := '_' + p1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil)
or(SearchId(constTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
if (SearchId(varTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil)
or(SearchId(constTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
str1 := out_triad(f_out,'ROW',p1,s1,'');
str2 := out_triad(f_out,'COL',p1,v1,'');
str1 := out_triad(f_out,'ADD',str2,str1,'');
(* Fix 15 in Fix 12## *)
(* v1 := out_triad(f_out,'SUBS',p1,str1,''); *)
v1 := out_triad(f_out,'ADDR',p1,str1,'');
(* end Fix 15 in Fix 12## *)
(*end Fix 12## "SUBS" *)
v2 := 'BOOLEAN'
end
end
end
end
end
end;
4: begin
getValue(v1,v2,stack,1);
getValue(s1,s2,stack,3);
p := isExist(s1);
if p = nil then begin
(*Fix 14 *)
(* оператор EQ в грамматике OP: если слева ячейка, то триада EQA *)
if s1[1]='(' then begin
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: OP: Type mismatch (line ',lines,')');
furl := false
end else
out_triad(f_out,'EQA',v1,s1,'');
end else begin
WriteLn(f_out,'ERROR: OP: Unknown idetifier (line ',lines,')');
furl := false
end
(*
WriteLn(f_out,'ERROR: Unknown idetifier (line ',lines,')');
furl := false
*)
(*end Fix 14 *)
end
else begin
v2 := Conv(v2);
s2 := Conv(p^.col1);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: OP: Type mismatch (line ',lines,')');
furl := false
end
(* FIX 8 edit - исправление ошибки <Присвоение Константе> *)
(* было *)
(*
else
Str(p^.num,s1);
s1 := '_' + s1;
out_triad(f_out,'EQ',v1,s1,'');
*)
(* стало *)
else begin
if SearchId(constTable,s1) <> nil then begin
WriteLn(f_out,'ERROR: OP: Const EQ (line ',lines,')');
furl := false;
end else begin
Str(p^.num,s1);
s1 := '_' + s1;
out_triad(f_out,'EQ',v1,s1,'');
end;
end;
(* end FIX 7 *)
end;
end;
end
end;
if nm = 'MC' then begin
case num of
6: begin
getValue(v1,v2,stack,1);
p := SearchId(constTable,v1);
if p = nil then begin
WriteLn(f_out,'ERROR: MC: Unknown identifier (line ',lines,')');
furl := false
end
else
if p^.col1 <> 'BOOLEAN' then begin
WriteLn(f_out,'ERROR: MC: Type mismatch (line ',lines,')');
furl := false
end
end;
end
end;
if nm = 'CSEC' then begin
case num of
(* FIX 7 edit - исправление ошибки <Унарный минус> [добавление минуса в таблицу констант] *)
(* было *)
(* 6,7,9,10: getValue(v1,v2,stack,1); *)
(* стало *)
6,9,10: getValue(v1,v2,stack,1);
7: begin
getValue(v1,v2,stack,1);
v1 := '-'+v1;
end;
(* end FIX 7 *)
8: begin
getValue(v1,v2,stack,1);
if SearchId(typeTable,v1) = nil then begin
WriteLn(f_out,'ERROR: CSEC: Unknown type-identifier "',v1,'" (line ',lines,')');
furl := false
end;
end;
3: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
if isExist(s1) <> nil then begin
WriteLn(f_out,'ERROR: CSEC: Duplicate identifier "',s1,'" (line ',lines,')');
furl := false
end
else
AddRow(constTable,s1,v2,v1,'','');
end;
5: begin
getValue(p1,s2,stack,6);
getValue(v1,v2,stack,4);
getValue(s1,s2,stack,2);
if isExist(p1) <> nil then begin
WriteLn(f_out,'ERROR: CSEC: Duplicate identifier "',s1,'" (line ',lines,')');
furl := false
end
else
if SearchId(typeTable,v1) = nil then begin
WriteLn(f_out,'ERROR: CSEC: Unknown identifier "',v1,'" (line ',lines,')');
furl := false
end
else
AddRow(matrTable,p1,v1,'','','');
end;
4: begin
getValue(p1,s2,stack,7);
getValue(v1,v2,stack,4);
getValue(s1,s2,stack,2);
if isExist(p1) <> nil then begin
WriteLn(f_out,'ERROR: CSEC: Duplicate identifier "',s1,'" (line ',lines,')');
furl := false
end
else begin
p := SearchId(hTable,v1);
AddRow(matrTable,p1,p^.col1,p^.col2,p^.col3,p^.col4);
DelHRow;
end
end
end
end;
if nm = 'VSEC' then begin
case num of
3: begin
getValue(v1,v2,stack,2);
s1 := hTable^.id;
if v1 = 'INTEGER' then begin
AddRow(varTable,s1,'INTEGER','','','');
ReadHTable
end
else
if v1 = 'BOOLEAN' then begin
AddRow(varTable,s1,'BOOLEAN','','','');
ReadHTable;
end
else
(*fix 10## "HTABLE" *)
if SearchId(typeTable,v1) = nil then
if true(*hTtable^.id[1]='_'*) then begin
(*занести тип в таблицу типов*)
p := isExist(v1);
AddRow(typeTable,v1,toUpperCase(p^.col1),p^.col2,p^.col3,p^.col4);
(*занести переменную в таблицу переменных*)
s1 := hTable^.next^.id;
AddRow(varTable,s1,toUpperCase(v1),'','','');
ReadHTable;
end else begin
WriteLn(f_out,'ERROR: VSEC: Unknown identifier "',v1,'" (line ',lines,')');
furl := false
end
else begin
AddRow(varTable,s1,toUpperCase(v1),'','','');
ReadHTable;
end;
(*
if SearchId(typeTable,v1) = nil then begin
WriteLn(f_out,'ERROR: Unknown identifier (line ',lines,')');
furl := false
end
else begin
AddRow(varTable,s1,v1,'','','');
ReadHTable;
end;
*)
(*end fix 10## "HTABLE" *)
end;
4,5: begin
getValue(v1,v2,stack,1);
if isExist(v1) <> nil then begin
WriteLn(f_out,'ERROR: VSEC: Duplicate identifier "',v1,'" (line ',lines,')');
furl := false
end
else
AddRow(hTable,v1,'','','','');
end
end
end;
if nm = 'LV' then begin
getValue(v1,v2,stack,1);
if IsExist(v1) = nil then begin
WriteLn(f_out,'ERROR: LV: Unknown identifier "',v1,'" (line ',lines,')');
furl := false
end
else
if Conv(v2) <> '4' then begin
WriteLn(f_out,'ERROR: LV: Only interger expresion (line ',lines,')');
furl := false
end
else
(* Fix 13 *)
(*
out_triad(f_out,'RD',v1,'','')
*)
begin
if (SearchId(varTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
out_triad(f_out,'RD',v1,'','')
end else begin
WriteLn(f_out,'ERROR: LV: RD: "v1" is not lvalue (line ',lines,')');
furl := false
end;
end;
(* end Fix 13 *)
end;
(* Big Fix5 edit furl() - весь блок "Exp" - переписан под новую txt-таблицу ДМП *)
if nm = 'EXP' then begin
case num of
(* 2,4,6,8,9: getValue(v1,v2,stack,1); *)
(* Fix 6 in Big Fix 5 edit - исправление ошибки <Одиночный идентификатор>*)
(* было *)
(* 2,6,8,11: getValue(v1,v2,stack,1); *)
(* стало *)
6,8,11: getValue(v1,v2,stack,1);
2: begin
getValue(v1,v2,stack,1);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
end;
(* end Fix 6 in Big Fix 5 *)
(* 18,19: begin v1 := stack^.value1; v2 := 'INTEGER' end; *)
12: begin v1 := stack^.value1; v2 := 'INTEGER' end;
(* 10,11: begin v1 := stack^.value1; v2 := 'BOOLEAN' end; *)
13,14: begin v1 := stack^.value1; v2 := 'BOOLEAN' end;
(* 12: getValue(v1,v2,stack,2); *)
15: getValue(v1,v2,stack,2);
(* 13: begin *)
16: begin
getValue(v1,v2,stack,1);
p := isExist(v1);
if p = nil then begin
WriteLn(f_out,'ERROR: EXP: Unknown identifier "',v1,'" (line ',lines,')');
furl := false
end
end;
(* 14..17: begin *)
17..20: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
getValue(p1,p2,stack,6);
p := isExist(p1);
if p = nil then begin
WriteLn(f_out,'ERROR: EXP: Unknown identifier "',v1,'" (line ',lines,')');
furl := false
end
else begin
p := SearchId(typeTable,p2);
if p = nil then p := SearchId(matrTable,p1);
(*old Fix tmp
if (p = nil)or(p^.col3 = '') then begin
*)
if (p = nil) then begin
WriteLn(f_out,'ERROR: EXP: Invalid qualifier (line ',lines,')');
furl := false
end
else begin
v2 := Conv(v2);
s2 := Conv(s2);
if (v2 <> '4')or(s2 <> '4') then begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,')');
furl := false
end
else begin
(*Fix tmp (SBT ==> NM)*)
Val(p^.col2,k,e);
Val(s1,m,e);
if (e = 0)and((1>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: EXP: Constant out of rang (3line ',lines,')');
furl := false
end
else begin
(*Fix tmp (SBT ==> NM)*)
Val(p^.col3,k,e);
Val(v1,m,e);
if (e = 0)and((1>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: EXP: Constant out of rang (4line ',lines,')');
furl := false
end
else begin
(*Fix 12## "SUBS" *)
(*
v1 := out_triad(f_out,'SUBS',p1,s1,v1);
*)
if (SearchId(varTable,p1) <> nil)or(SearchId(matrTable,p1) <> nil) then begin
p := isExist(p1);
Str(p^.num,p1);
p1 := '_' + p1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil)
or(SearchId(constTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
if (SearchId(varTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil)
or(SearchId(constTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
v2 := out_triad(f_out,'ROW',p1,s1,'');
v1 := out_triad(f_out,'COL',p1,v1,'');
v1 := out_triad(f_out,'ADD',v2,v1,'');
v1 := out_triad(f_out,'SUBS',p1,v1,'');
(*end Fix 12## "SUBS" *)
v2 := 'BOOLEAN'
end
end
end
end
end
end;
(*
7: begin
getValue(v1,v2,stack,1);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
p2 := v2;
v2 := Conv(v2);
if v2 = '4' then begin
v1 := out_triad(f_out,'NEG',v1,'','');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'NOT',v1,'','');
v2 := p2
end
end;
*)
9: begin
getValue(v1,v2,stack,1);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
p2 := v2;
v2 := Conv(v2);
if v2 = '1' then begin (*boolean*)
v1 := out_triad(f_out,'NOT',v1,'','');
v2 := p2
end
else begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,') - NOT (for not Boolean)');
furl := false
end;
end;
10: begin
getValue(v1,v2,stack,1);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
p2 := v2;
v2 := Conv(v2);
if v2 = '4' then begin (*integer*)
v1 := out_triad(f_out,'NEG',v1,'','');
v2 := 'INTEGER'
end
else begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,') - "-" (for not Integer)');
furl := false
end;
end;
(* 5: begin *)
7: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
p2 := v2;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,')');
furl := false
end
else
if v2 = '4' then begin
p1 := toUpperCase(p1);
if p1 = '*' then p1 := 'MUL';
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'AND',v1,s1,'');
v2 := p2;
end
end;
(* 3: begin *)
3..5: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
p2 := v2;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,')');
furl := false
end
else
if v2 = '4' then begin
if p1 = '+' then p1 := 'ADD';
if p1 = '-' then p1 := 'SUB';
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'OR',v1,s1,'');
v2 := p2
end
end;
1: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: EXP: Type mismatch (line ',lines,')');
furl := false
end
else begin
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'BOOLEAN';
end;
{ end
else begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end }
end;
end;
end;
(* Big Fix5 - так было *)
(*
if nm = 'EXP' then begin
case num of
2,4,6,8,9: getValue(v1,v2,stack,1);
18,19: begin v1 := stack^.value1; v2 := 'INTEGER' end;
10,11: begin v1 := stack^.value1; v2 := 'BOOLEAN' end;
12: getValue(v1,v2,stack,2);
13: begin
getValue(v1,v2,stack,1);
p := isExist(v1);
if p = nil then begin
WriteLn(f_out,'ERROR: Unknown identifier (line ',lines,')');
furl := false
end
end;
14..17: begin
getValue(v1,v2,stack,2);
getValue(s1,s2,stack,4);
getValue(p1,p2,stack,6);
p := isExist(p1);
if p = nil then begin
WriteLn(f_out,'ERROR: Unknown identifier (line ',lines,')');
furl := false
end
else begin
p := SearchId(typeTable,p2);
if p = nil then p := SearchId(matrTable,p1);
if (p = nil)or(p^.col3 = '') then begin
WriteLn(f_out,'ERROR: Invalid qualifier (line ',lines,')');
furl := false
end
else begin
v2 := Conv(v2);
s2 := Conv(s2);
if (v2 <> '4')or(s2 <> '4') then begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end
else begin
Val(p^.id,i,e);
Val(p^.col1,k,e);
Val(s1,m,e);
if (e = 0)and((i>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: Constant out of rang (line ',lines,')');
furl := false
end
else begin
Val(p^.col2,i,e);
Val(p^.col3,k,e);
Val(v1,m,e);
if (e = 0)and((i>m)or(m>k)) then begin
WriteLn(f_out,'ERROR: Constant out of rang (line ',lines,')');
furl := false
end
else begin
v1 := out_triad(f_out,'SUBS',p1,s1,v1);
v2 := 'BOOLEAN'
end
end
end
end
end
end;
7: begin
getValue(v1,v2,stack,1);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
p2 := v2;
v2 := Conv(v2);
if v2 = '4' then begin
v1 := out_triad(f_out,'NEG',v1,'','');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'NOT',v1,'','');
v2 := p2
end
end;
5: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
p2 := v2;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end
else
if v2 = '4' then begin
p1 := toUpperCase(p1);
if p1 = '*' then p1 := 'MUL';
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'AND',v1,s1,'');
v2 := p2;
end
end;
3: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
p2 := v2;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end
else
if v2 = '4' then begin
if p1 = '+' then p1 := 'ADD';
if p1 = '-' then p1 := 'SUB';
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'INTEGER'
end
else begin
v1 := out_triad(f_out,'OR',v1,s1,'');
v2 := p2
end
end;
1: begin
getValue(v1,v2,stack,1);
getValue(p1,s2,stack,2);
getValue(s1,s2,stack,3);
if (SearchId(varTable,v1) <> nil)or(SearchId(constTable,v1) <> nil)or(SearchId(matrTable,v1) <> nil) then begin
p := isExist(v1);
Str(p^.num,v1);
v1 := '_' + v1;
end;
if (SearchId(varTable,s1) <> nil)or(SearchId(constTable,s1) <> nil)or(SearchId(matrTable,s1) <> nil) then begin
p := isExist(s1);
Str(p^.num,s1);
s1 := '_' + s1;
end;
v2 := Conv(v2);
s2 := Conv(s2);
if v2 <> s2 then begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end
else begin
v1 := out_triad(f_out,p1,v1,s1,'');
v2 := 'BOOLEAN';
end;
{ end
else begin
WriteLn(f_out,'ERROR: Type mismatch (line ',lines,')');
furl := false
end }
end;
end;
end;
*)
(* end Big Fix5 *)
if nm = 'IFOP' then begin
case num of
2: begin
getValue(v1,v2,stack,3);
out_triad(f_out,'DEFL',v1,'','');
end;
1: begin
getValue(v1,v2,stack,2);
out_triad(f_out,'DEFL',v1,'','');
end;
end
end;
DelElems(stack, j);
t := stack^.token;
AddElem(stack, v1,v2, search(ga,mx,mg,t,rul[0, num]));
end;
end;
function action(nm: Tokens; mx,mf,mg: Byte; ey,v1,v2: Tokens; var q: Boolean): Boolean;
var
elem, ex: Tokens;
num: Byte;
e: Integer;
begin
ex := stack^.token;
elem := search(fa,mx,mf,ex,ey);
if elem = 'T' then begin
AddElem(stack, v1,v2, search(ga,mx,mg,ex,ey));
q := true
end
else begin
Val(elem,num,e);
q := false;
if e = 0 then
if not furl(nm,mx,mg,num) then
elem := 'E';
end;
{ WritelN(elem, ' ',ey,' ',ex, '|| '); WriteStack(stack);}
if (elem = 'E')or(elem = 'U') then action := false else action := true;
if elem = 'A' then begin q := true; action := false end;
end;
function isEnds(var eps: Ends; num: Byte; sym: Tokens): Boolean;
var
j: Byte;
begin
isEnds := false;
for j := 1 to num do
if eps[j] = sym then begin
eps[j] := eps[1];
eps[1] := sym;
isEnds := true
end
end;
function proc_LOP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('LOP.txt', rul);
readFG('LOP_ga.txt', ga, 6, 4);
readFG('LOP_fa.txt', fa, 6, 3);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
if (stack^.token = 'Z')or(stack^.token = '*_2') then begin
eps1[1] := '_END';
eps1[2] := '_UNTIL';
eps1[3] := ';';
if proc_OP(c,w,3,eps1) then begin
if eps1[2] = '' then
DelElems(stack, 1)
else
DelElems(stack, 2);
readRul('LOP.txt', rul);
readFG('LOP_ga.txt', ga, 6, 4);
readFG('LOP_fa.txt', fa, 6, 3);
q := false;
t := 'op';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps'
end
end
until not action('',6,3,4, t,value1,value2,q);
proc_LOP := q;
end;
function proc_OP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
sumUntil, sumEnd: Byte;
q: Boolean;
t,s: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
sumUntil := 0;
sumEnd := 0;
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('OP.txt', rul);
(* Fix 9## 4 edit*)
(*
readFG('OP_ga.txt', ga, 62, 29);
readFG('OP_fa.txt', fa, 62, 25);
*)
readFG('OP_ga.txt', ga, 70, 32);
readFG('OP_fa.txt', fa, 70, 28);
(* end Fix 9## 4 *)
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then begin
if (sumEnd <> 0)and(t = '_END') then
Dec(sumEnd)
else
if (sumUntil <> 0)and(t = '_UNTIL') then
Dec(sumUntil)
else
t := 'Eps';
end;
eps1[1] := '';
end;
if (stack^.token = '1_2')or(stack^.token = '2_2') then begin
getValue(value1,value2,stack,2);
if SearchId(labelTable,value1) = nil then begin
WriteLn(f_out,'ERROR: Unknown label identifier (line ',lines,')');
end
else begin
out_triad(f_out,'DEFL',value1,'','');
end
end;
if (stack^.token = '4_2')or(stack^.token = '6_3')
or(stack^.token = '10_2')or(stack^.token = '5_1')
or(stack^.token = '20_2') then begin
eps1[1] := '_END';
eps1[2] := '_UNTIL';
eps1[3] := ';';
eps1[4] := '_THEN';
eps1[5] := '_ELSE';
eps1[6] := ',';
eps1[7] := ')';
if proc_EXP(c,w,7,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 2);
readRul('OP.txt', rul);
(* Fix 9## 5 edit*)
(*
readFG('OP_ga.txt', ga, 62, 29);
readFG('OP_fa.txt', fa, 62, 25);
*)
readFG('OP_ga.txt', ga, 70, 32);
readFG('OP_fa.txt', fa, 70, 28);
(* end Fix 9## 5 *)
q := false;
t := 'exp';
end
else
w := true
end;
if (stack^.token = '5_3') then begin
getValue(value1,value2,stack,2);
if value2 = 'BOOLEAN' then begin
Str(labelTable^.num+1,s);
s := '_' + s;
AddRow(labelTable,s,'','','','');
stack^.value1 := s;
out_triad(f_out,'BF',value1,s,'');
end
else begin
WriteLn(f_out,'ERROR: Boolean expresion expected (line ',lines,')');
end;
eps1[1] := '_END';
eps1[2] := '_UNTIL';
eps1[3] := ';';
if proc_IFOP(c,w,3,eps1) then begin
DelElems(stack, 2);
readRul('OP.txt', rul);
(* Fix 9##6 edit*)
(*
readFG('OP_ga.txt', ga, 62, 29);
readFG('OP_fa.txt', fa, 62, 25);
*)
readFG('OP_ga.txt', ga, 70, 32);
readFG('OP_fa.txt', fa, 70, 28);
(* end Fix 9## 6 *)
q := false;
t := 'ifop';
end
else
w := true
end;
if (stack^.token = '9_2') then begin
eps1[1] := ')';
if proc_LV(c,w,1,eps1) then begin
DelElems(stack, 2);
readRul('OP.txt', rul);
(* Fix 9## 7 edit*)
(*
readFG('OP_ga.txt', ga, 62, 29);
readFG('OP_fa.txt', fa, 62, 25);
*)
readFG('OP_ga.txt', ga, 70, 32);
readFG('OP_fa.txt', fa, 70, 28);
(* end Fix 9## 7 *)
q := false;
t := 'lv';
end
else
w := true
end;
if (stack^.token = '12_1')or(stack^.token = '6_1') then begin
if stack^.token = '6_1' then begin
Str(labelTable^.num+1,s);
s := '_' + s;
AddRow(labelTable,s,'','','','');
stack^.value1 := s;
out_triad(f_out,'DEFL',s,'','');
end;
out_triad(f_out,'BLBEG','','','');
eps1[1] := '_END';
eps1[2] := '_UNTIL';
if proc_LOP(c,w,2,eps1) then begin
out_triad(f_out,'BLEND','','','');
DelElems(stack, 2);
readRul('OP.txt', rul);
(* Fix 9## 8 edit*)
(*
readFG('OP_ga.txt', ga, 62, 29);
readFG('OP_fa.txt', fa, 62, 25);
*)
readFG('OP_ga.txt', ga, 70, 32);
readFG('OP_fa.txt', fa, 70, 28);
(* end Fix 9## 8 *)
q := false;
t := 'lop';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if t = '_REPEAT' then Inc(sumUntil);
if t = '_BEGIN' then Inc(sumEnd);
if isEnds(eps,num,t) then
t := 'Eps'
end
end;
(* Fix 9## 9 edit*)
(*
until not action('OP',62,25,29, t,value1,value2,q);
*)
until not action('OP',70,28,32, t,value1,value2,q);
(* end Fix 9## 9*)
if stack^.token = 'Z' then eps[2] := '';
proc_OP := q;
end;
function proc_IFOP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t, s: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('IFOP.txt', rul);
readFG('IFOP_ga.txt', ga, 5, 3);
readFG('IFOP_fa.txt', fa, 5, 3);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if(stack^.token = '1_3') then begin
eps[1] := t;
t := 'Eps'
end
else
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
if (stack^.token = 'Z')or(stack^.token = '1_2') then begin
if stack^.token = '1_2' then begin
getValue(value1,value2,stack,4);
Str(labelTable^.num+1,s);
s := '_' + s;
AddRow(labelTable,s,'','','','');
stack^.value1 := s;
out_triad(f_out,'BRL',s,'','');
out_triad(f_out,'DEFL',value1,'','');
end;
eps1[1] := '_END';
eps1[2] := ';';
eps1[3] := '_ELSE';
eps1[4] := '_UNTIL';
if proc_OP(c,w,4,eps1) then begin
DelElems(stack, 2);
readRul('IFOP.txt', rul);
readFG('IFOP_ga.txt', ga, 5, 3);
readFG('IFOP_fa.txt', fa, 5, 3);
q := false;
t := 'op';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else
t := get_token(f_in,value1,value2, c, w);
end;
until not action('IFOP',5,3,3, t,value1,value2,q);
proc_IFOP := q;
end;
function proc_EXP(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j,sumBr,sumFl: Byte;
value1, value2: String;
begin
sumBr := 0;
sumFl := 0;
q := true;
AddElem(stack,'','','Z');
readRul('EXP.txt', rul);
(* Fix 3 edit *)
(* Изменение в readFG() размеров таблиц EXP_ga.txt и EXP_fa.txt*)
(* было *)
(*
readFG('EXP_ga.txt', ga, 37, 20);
readFG('EXP_fa.txt', fa, 37, 15);
*)
(* стало *)
readFG('EXP_ga.txt', ga, 40, 20);
readFG('EXP_fa.txt', fa, 40, 16);
(* end Fix 3 *)
repeat
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if t = '(' then Inc(sumBr);
if t = '[' then sumFl := 1;
if t = ']' then sumFl := 0;
if isEnds(eps,num,t) then
if (sumBr = 0)or(t <> ')') then begin
if (sumFl = 0)or(t <> ',') then
t := 'Eps';
end
else
Dec(sumBr)
end
end;
(* Fix 4 edit *)
(* Изменение в not action('Exp') размеров таблиц EXP_ga.txt и EXP_fa.txt*)
(* было *)
(*
until not action('EXP',37,15,20, t,value1,value2,q);
*)
(* стало *)
until not action('EXP',40,16,20, t,value1,value2,q);
(* end Fix 4 *)
proc_EXP := q;
end;
function proc_LV(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
begin
q := true;
t := '';
AddElem(stack,'','','Z');
readRul('LV.txt', rul);
readFG('LV_ga.txt', ga, 5, 3);
readFG('LV_fa.txt', fa, 5, 3);
repeat
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps'
end
end;
until not action('LV',5,3,3, t,value1,value2,q);
proc_LV := q;
end;
function proc_MC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
begin
q := true;
AddElem(stack,'','','Z');
readRul('MC.txt', rul);
readFG('MC_ga.txt', ga, 18, 10);
readFG('MC_fa.txt', fa, 18, 7);
repeat
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('MC',18,7,10, t,value1,value2,q);
proc_MC := q;
end;
function proc_SBT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j, sum: Byte;
value1, value2: String;
begin
sum := 0;
q := true;
AddElem(stack,'','','Z');
readRul('SBT.txt', rul);
readFG('SBT_ga.txt', ga, 13, 6);
readFG('SBT_fa.txt', fa, 13, 5);
repeat
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
Inc(sum);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('SBT',13,5,6, t,value1,value2,q);
if not q then
if sum > 1 then
eps[1] := '.'
else
eps[1] := t;
proc_SBT := q;
end;
function proc_STRT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('STRT.txt', rul);
readFG('STRT_ga.txt', ga, 9, 7);
readFG('STRT_fa.txt', fa, 9, 6);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
(*
if (stack^.token = '1_1')or(stack^.token = '1_3') then begin
eps1[1] := ']';
eps1[2] := ',';
if proc_SBT(c,w,2,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 2);
readRul('STRT.txt', rul);
readFG('STRT_ga.txt', ga, 9, 7);
readFG('STRT_fa.txt', fa, 9, 7);
q := false;
t := 'sbt';
end
else
w := true
end;
*)
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('STRT',9,6,7, t,value1,value2,q);
proc_STRT := q;
end;
function proc_CSEC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('CSEC.txt', rul);
readFG('CSEC_ga.txt', ga, 24, 14);
readFG('CSEC_fa.txt', fa, 24, 12);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
if stack^.token = '4_3' then begin
eps1[1] := '=';
if proc_STRT(c,w,1,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 2);
readRul('CSEC.txt', rul);
readFG('CSEC_ga.txt', ga, 24, 14);
readFG('CSEC_fa.txt', fa, 24, 12);
q := false;
t := 'str';
end
else
w := true
end;
if (stack^.token = '4_5')or(stack^.token = '5_4') then begin
eps1[1] := ';';
if proc_MC(c,w,1,eps1) then begin
DelElems(stack, 2);
readRul('CSEC.txt', rul);
readFG('CSEC_ga.txt', ga, 20, 14);
readFG('CSEC_fa.txt', fa, 20, 12);
q := false;
t := 'mc';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('CSEC',24,12,14, t,value1,value2,q);
proc_CSEC := q;
end;
function proc_VLT(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
if w then
proc_VLT := false
else begin
eps1[1] := ';';
if proc_SBT(c,w,1,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 2);
AddElem(stack,value1,'SUB','Z');
eps[1] := eps1[1];
proc_VLT := true
end
else begin
DelElems(stack, 1);
if (eps1[1] = '_INTEGER')or(eps1[1] = '_BOOLEAN') then begin
if eps1[1] = '_INTEGER' then
AddElem(stack,'INTEGER','0','Z')
else
AddElem(stack,'BOOLEAN','0','Z');
if w then
eps[1] := 'Eps'
else
eps[1] := get_token(f_in,value1,value2, c, w);
proc_VLT := true
end
else
if eps1[1] = '_ARRAY' then
if w then
proc_VLT := false
else begin
eps1[1] := ';';
if proc_STRT(c,w,1,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 2);
AddElem(stack,value1,'MATR','Z');
eps[1] := eps1[1];
proc_VLT := true
end
else
proc_VLT := false
end
else
proc_VLT := false
end
end
end;
function proc_VSEC(var c: Char; var w: Boolean; num: Byte; var eps: Ends): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('VSEC.txt', rul);
readFG('VSEC_ga.txt', ga, 11, 8);
readFG('VSEC_fa.txt', fa, 11, 6);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
if stack^.token = '3_2' then begin
eps1[1] := ';';
if proc_VLT(c,w,1,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 1);
readRul('VSEC.txt', rul);
readFG('VSEC_ga.txt', ga, 11, 8);
readFG('VSEC_fa.txt', fa, 11, 6);
q := false;
t := 'vlt';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('VSEC',11,6,8, t,value1,value2,q);
proc_VSEC := q;
end;
function proc_PROG(var c: Char; var w: Boolean; num: Byte; var eps: Ends; var line: Integer): Boolean;
var
q: Boolean;
t: Tokens;
i,j: Byte;
value1, value2: String;
eps1: Ends;
begin
eps1[1] := '';
q := true;
AddElem(stack,'','','Z');
readRul('PROG.txt', rul);
readFG('PROG_ga.txt', ga, 38, 26);
readFG('PROG_fa.txt', fa, 38, 18);
repeat
if eps1[1] <> '' then begin
q := false;
t := eps1[1];
if isEnds(eps,num,t) then
t := 'Eps';
eps1[1] := '';
end;
if stack^.token = '7_1' then begin
out_triad(f_out,'BLBEG','','','');
eps1[1] := '_END';
if proc_LOP(c,w,1,eps1) then begin
out_triad(f_out,'BLEND','','','');
DelElems(stack, 2);
readRul('PROG.txt', rul);
readFG('PROG_ga.txt', ga, 38, 26);
readFG('PROG_fa.txt', fa, 38, 18);
q := false;
t := 'lop';
end
else
w := true
end;
if stack^.token = '9_1' then begin
eps1[1] := '_BEGIN';
eps1[2] := '_TYPE';
eps1[3] := '_VAR';
eps1[4] := '_LABEL';
if proc_CSEC(c,w,4,eps1) then begin
DelElems(stack, 2);
readRul('PROG.txt', rul);
readFG('PROG_ga.txt', ga, 38, 26);
readFG('PROG_fa.txt', fa, 38, 18);
q := false;
t := 'csc';
end
else
w := true
end;
if stack^.token = '10_1' then begin
eps1[1] := '_BEGIN';
eps1[2] := '_TYPE';
eps1[3] := '_CONST';
eps1[4] := '_LABEL';
if proc_VSEC(c,w,4,eps1) then begin
DelElems(stack, 2);
readRul('PROG.txt', rul);
readFG('PROG_ga.txt', ga, 38, 26);
readFG('PROG_fa.txt', fa, 38, 18);
q := false;
t := 'vsc';
end
else
w := true
end;
if stack^.token = '14_2' then begin
if proc_VLT(c,w,4,eps1) then begin
getValue(value1,value2,stack,1);
DelElems(stack, 1);
readRul('PROG.txt', rul);
readFG('PROG_ga.txt', ga, 38, 26);
readFG('PROG_fa.txt', fa, 38, 18);
q := false;
t := 'vlt';
end
else
w := true
end;
if q then begin
if w then
t := 'Eps'
else begin
t := get_token(f_in,value1,value2, c, w);
if isEnds(eps,num,t) then
t := 'Eps';
end
end;
until not action('PROG',38,18,26, t,value1,value2,q);
line := lines;
proc_PROG := q;
end;
end.