Курсовая работа. / РЯП_Ксю / Our_compiler / sinan / uTable

unit uTable;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Grids, Contnrs, StdCtrls;

const tDop = 'ДОП';
tErr = ' ';
tPer = 'ПЕР';
tSvert: char = 'C';
tZ = 'Z'; // Символ пустого стека в таблице
tZ1 = ' Б '; //Символ пустого стека в файле
type
TStringStack = class(TStack)
Empty: boolean;
constructor Create;
function UpperStr: string;
function Upperint: integer;
function Popstr: string;
procedure Push(s: string); overload;
function Popint: integer;
procedure Push(s: integer); overload;
procedure Clear;
function Listingint: string;
function Listingstr: string;
end;

TfmTable = class(TForm)
sgF: TStringGrid;
sgG: TStringGrid;
Splitter1: TSplitter;
mmRules: TMemo;
Splitter2: TSplitter;
sgMF: TStringGrid;
sgMG: TStringGrid;
sgOF: TStringGrid;
sgOG: TStringGrid;
sgVF: TStringGrid;
sgVG: TStringGrid;
mmRulesM: TMemo;
mmRulesO: TMemo;
mmRulesV: TMemo;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
// Stack:TStringStack;
Rules,
RulesM,
RulesO,
RulesV: TStringList;
CountOfRule,
CountOfRuleM,
CountOfRuleO,
CountOfRuleV: word;
Triads, //Список триад
SeqExec: TStringList; //Последовательность выполнения
procedure LoadTable(var sgF1, sgG1: TStringGrid; var mmRules1: TMemo; var Rules1: TStringList; CountOfRule1: word; FN: string);
procedure ChangeTables(n: byte);
function Analys(s: string; var i: integer): boolean;
end;

var
fmTable: TfmTable;
attrs: TStringStack; // Стек атрибутов
numvar: byte; // Номер переменной в таблице, если текущий символ - переменная
numconst: byte; // Номер константы в таблице, если текущий символ - константа
numtype: byte; // Номер типа в таблице, если текущий символ - тип
numlabel: byte; // Номер метки в таблице, если текущий символ - метка
numstr:byte; // Номер строки в таблице, если текущий символ - строка
number: longint; // Номер
curtab: byte; // Номер текущей таблицы
implementation

uses uMain, uRules, uOutput;
{$R *.dfm}

procedure assignsg(var sgF1, sgG1: TStringGrid);
var i, j: byte;
begin
with fmTable do
begin
sgF.ColCount := sgF1.ColCount;
sgG.ColCount := sgG1.ColCount;
sgF.RowCount := sgF1.RowCount;
sgG.RowCount := sgG1.RowCount;
for j := 0 to sgF1.RowCount - 1 do
begin
for i := 0 to sgF1.ColCount - 1 do
begin
sgF.Cells[i, j] := sgF1.Cells[i, j];
end;
for i := 0 to sgG1.ColCount - 1 do
begin
sgG.Cells[i, j] := sgG1.Cells[i, j];
end;
end; //for;
end; //with
end;

procedure TfmTable.ChangeTables(n: byte); // загрузить соответствующую управляющую таблицу
//n=0 основную
//n=1 оператор
//n=2 выражение
begin
case n of
0: begin
assignsg(sgMF, sgMG);
CountOfRule := CountOfRuleM;
Rules.Assign(RulesM);
mmRules.Text := mmRulesM.Text;
end;
1: begin
assignsg(sgOF, sgOG);
CountOfRule := CountOfRuleO;
Rules.Assign(RulesO);
mmRules.Text := mmRulesO.Text;
end;
2: begin
assignsg(sgVF, sgVG);
CountOfRule := CountOfRuleV;
Rules.Assign(RulesV);
mmRules.Text := mmRulesV.Text;
end;
end; //case

end;

procedure TfmTable.LoadTable; //Заполнение таблиц
var f: file of char;
ch: char;
i, j: byte;
s, RuleCode: string;
begin
curtab := 0;
assignfile(f, FN);
try
reset(f);
except
showmessage('Ошибка работы с файлом ' + FN);
Exit;
end;
read(f, ch); //Пропускаем 0
read(f, ch); // Читаем количество терминалов + Eps
sgF.RowCount := ord(ch) + 1;
sgG.RowCount := ord(ch) + 1;
read(f, ch); // Читаем количество строк
sgF.ColCount := ord(ch) + 1;
read(f, ch); // Читаем количество терминалов + количество нетерминалов
sgG.ColCount := ord(ch) + 1;
read(f, ch);
// Читаем заголовки столбцов таблицы F
for i := 1 to sgF.ColCount - 1 do
begin
s := '';
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
sgF.Cells[i, 0] := s;
end;
// Читаем заголовки столбцов таблицы G
for i := 1 to sgG.ColCount - 1 do
begin
s := '';
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
sgG.Cells[i, 0] := s;
end;
// Читаем заголовки Строк таблиц F,G
for i := 1 to sgG.RowCount - 1 do
begin
s := '';
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
read(f, ch); s := s + ch;
if s = tZ1 then s := tZ;
sgF.Cells[0, i] := s;
sgG.Cells[0, i] := s;
end;
// Читаем значения таблицы G
for i := 1 to sgG.RowCount - 1 do
for j := 1 to sgG.ColCount - 1 do
begin
read(f, ch);
if ord(ch) = 0 then sgG.Cells[j, i] := tErr
else sgG.Cells[j, i] := sgG.Cells[0, ord(ch)];
end;
// Читаем значения таблицы F
for i := 1 to sgF.RowCount - 1 do
for j := 1 to sgF.ColCount - 1 do
begin
read(f, ch);
case ord(ch) of
0: sgF.Cells[j, i] := tErr;
1: sgF.Cells[j, i] := tDop;
2: sgF.Cells[j, i] := tPer;
else sgF.Cells[j, i] := tSvert + ',' + intToStr(ord(ch) - 3);
end; //case
end; // for
read(f, ch);
read(f, ch);
read(f, ch);
read(f, ch);
//Добавляем нулевое правило
mmRules.Clear;
Rules.Clear;
mmRules.Lines.Add('(0) ###->' + sgG.Cells[ord(ch), 0]);
Rules.Add(#01 + ch);
//Добавляем остальные правила
i := 0;
repeat
inc(i);
s := '(' + intToStr(i) + ') ' + sgG.Cells[ord(ch), 0] + '->';
Rulecode := string(ch);
read(f, ch);
Rules.Add(Rulecode + ch);

j := ord(ch);
while (j > 0) do
begin
read(f, ch);
s := s + sgG.Cells[ord(ch), 0] + sep;
dec(j);
end; //while
mmRules.Lines.Add(s);
if not eof(f) then read(f, ch);
until eof(f);
CountOfRule := i + 1;
closefile(f);
//Сопоставление загруженных таблиц
// assignsg(sgF1,sgG1);
sgF1.ColCount := sgF.ColCount;
sgG1.ColCount := sgG.ColCount;
sgF1.RowCount := sgF.RowCount;
sgG1.RowCount := sgG.RowCount;

for j := 0 to sgF.RowCount - 1 do
begin
for i := 0 to sgF.ColCount - 1 do
begin
sgF1.Cells[i, j] := sgF.Cells[i, j];
end;
for i := 0 to sgG.ColCount - 1 do
begin
sgG1.Cells[i, j] := sgG.Cells[i, j];
end;
end; //for;

mmRules1.Text := mmRules.Text;
Rules1.Assign(Rules);
CountOfRule1 := CountOfRule;
end; {procedure}

function FindCol(var sg: TStringGrid; lex: string): byte; // Поиск элемента lex в таблице sg
var i: byte;
begin
i := 1;
while (Trim(sg.Cells[i, 0]) <> trim(lex)) and (i < sg.ColCount) do
inc(i);
if i = sg.ColCount then raise Exception.Create('Символ '+lex+' не соответствует управляющей таблице')
else FindCol := i;
end;

function FindRow(var sg: TStringGrid; slex: string): byte;
var i: integer;
begin
i := 1;
while (Trim(sg.Cells[0, i]) <> slex) and (i < sg.RowCount) do
inc(i);
if i = sg.RowCount then raise Exception.Create('Символ не соответствует управляющей таблице')
else FindRow := i;

end;

procedure passSep(s: string; var begi: integer);
begin
while (s[begi] = sep) or (s[begi] = #13) or (s[begi] = #10) or (s[begi] = #9) do inc(begi);
end;

function GetLex(s: string; var begi: integer): string; // Считывание очередной лексемы с входного потока
var res: string;
curtable: byte;
begin
res := '';
while (s[begi] <> sep) and (s[begi] <> #13) and (begi <= length(s)) do
begin
res := res + s[begi];
inc(begi);
end;
passsep(s, begi);
if (res <> '') then
begin
if res[1] = 'v' then
begin
delete(res, 1, 1);
numvar := strtoint(res);
res := 'idv';
end;
if res[1] = 'c' then
begin
delete(res, 1, 1);
numconst := strtoint(res);
res := 'idc';
end;
if res[1] = 't' then
begin
delete(res, 1, 1);
numtype := strtoint(res);
res := 'idt';
end;
if res[1] = 'l' then
begin
delete(res, 1, 1);
numlabel := strtoint(res);
res := 'idl';
end;
if res[1] = 's' then
begin
delete(res, 1, 1);
numstr := strtoint(res);
res := 'str';
end;
if digit(res[1]) then
begin
number := strtoint(res);
res := 'idn';
end;

end;
if res = '#' then
begin
{ curtable := curtab;
curtab := 1;
// fmTable.ChangeTables(1);
if fmTable.Analys(fmMain.mmOutPut.Text, begi) then
begin}
res := 'op';
{ fmTable.ChangeTables(curtable);
curtab := curtable;
end
else raise Exception.Create('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(begi) + ' символе');}
end;
if res = '$' then
begin
{ curtable := curtab;
curtab := 2;
// fmTable.ChangeTables(2);
if fmTable.Analys(fmMain.mmOutPut.Text, begi) then
begin}
res := 'exp';
{ fmTable.ChangeTables(curtable);
curtab := curtable;
end
else raise Exception.Create('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(begi) + ' символе');}
end;
{ if (begi>length(s)+1)and (res<>'') then
raise Exception.Create('Ошибка чтения лексемы, в конце строки');}
// if res='' then res:='Eps';
GetLex := res;
end;

function GetNum(Num: string): word; // Считывание номера правила из таблицы
var res: string;
i: byte;
begin
i := length(tSvert)+2;
res := '';
while i <= length(Num) do
begin
res := res + Num[i]; inc(i);
end;
try
GetNum := strToint(res);
except
raise Exception.Create('Ошибка в управляющей таблице');
end;
end;

{function GetTypeLex(Lex:string);
begin

end;}



function TfmTable.Analys(s: string; var i: integer): boolean;
var lex: string;
RulNum, j: integer;
R, C, curtable: byte;
Stack: TStringStack;
mes:string;
//label Exit1;
begin
ChangeTables(curtab);
Stack := TStringStack.Create;
Stack.Clear;
if (s = '') or (s = ' ') then //проверка на пустоту входного потока
begin
Analys := true;
Stack.Free;
Exit;
end;
try
lex := GetLex(s, i);
except
Analys := false;
showmessage('Ошибка входного потока');
Stack.Free;
Exit;
end;
while (i <= length(s) + 1) and (lex <> '') and (lex <> 'Eps') do
begin
Application.ProcessMessages;
try
C := FindCol(fmTable.sgF, lex);
R := FindRow(fmTable.sgF, Stack.UpperStr);
except
Analys := false;
Stack.Free;
Exit;
end;
if fmTable.sgF.Cells[C, R] = tPer then //Если перенос
begin
//Если встречен терминал op запустить грамматику оператора
if lex='op' then
begin
curtable := curtab;
curtab := 1;
if fmTable.Analys(fmMain.mmOutPut.Text, i) then
begin
fmTable.ChangeTables(curtable);
curtab := curtable;
end
else raise Exception.Create('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(i) + ' символе');
end
else
//Если встречен терминал exp запустить грамматику выражения
if lex='exp' then
begin
curtable := curtab;
curtab := 2;
if fmTable.Analys(fmMain.mmOutPut.Text, i) then
begin
fmTable.ChangeTables(curtable);
curtab := curtable;
end
else raise Exception.Create('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(i) + ' символе');
end;
C := FindCol(fmTable.sgG, lex);
if fmTable.sgG.Cells[C, R] <> tErr then
begin
Stack.Push(fmTable.sgG.Cells[C, R]);
ExecPer(lex);
if fmMain.tbtest.down then fmOutput.mmTest.Lines.Add('стек '+inttostr(curtab)+': '+stack.listingstr);
end
else begin Analys := false; Stack.Free; Exit; end;
try
lex := GetLex(s, i);
except
analys := false;
showmessage('Ошибка входной ленты');
Stack.Free; Exit;
end;
end
else
if fmTable.sgF.Cells[C, R] = tErr then //Если ошибка
begin analys := false; Stack.Free; Exit; end
else
if (fmTable.sgF.Cells[C, R][1] = tSvert) then //Если свертка
begin
RulNum := GetNum(fmTable.sgF.Cells[C, R]);
// showMessage('Свертка по правилу '+intToStr(RulNum));
for j := 1 to ord(Rules[RulNum][2]) do
Stack.Popstr;
R := FindRow(fmTable.sgG, Stack.UpperStr);
Stack.Push(fmTable.sgG.Cells[ord(Rules[RulNum][1]), R]);
try
mes:=ExecRule(RulNum, curtab);
if fmMain.tbTest.Down then fmOutput.mmTest.Lines.Add('стек '+inttostr(curtab)+': '+stack.listingstr);
except
showmessage(mes);
Stack.Free;
analys:=false;
exit;
end;
// Stack.Pop;
end
else showmessage('Ерунда');
end; //while
C := findCol(fmTable.sgF, 'Eps');
while not Stack.Empty do
begin
R := findRow(fmTable.sgF, Stack.UpperStr);
if fmTable.sgF.Cells[C, R] = tDop then begin Analys := true; Stack.Free; Exit; end
else
{ if fmTable.sgF.Cells[C,R]=tPer then
begin
C:=FindCol(fmTable.sgF, lex);
if fmTable.sgG.Cells[C,R]<>tErr then Stack.Push(fmTable.sgG.Cells[C,R])
else begin Analys:=false; Stack.Free ; Exit; end;
end
else}
if (length(fmTable.sgF.Cells[C, R]) > 0) and (fmTable.sgF.Cells[C, R][1] = tSvert) then
begin
RulNum := GetNum(fmTable.sgF.Cells[C, R]);
// showMessage('Свертка по правилу '+intToStr(RulNum));
for j := 1 to ord(Rules[RulNum][2]) do
Stack.Popstr;
R := FindRow(fmTable.sgF, Stack.UpperStr);
Stack.Push(fmTable.sgG.Cells[ord(Rules[RulNum][1]), R]);
//Применение правила перевода
try
mes:=ExecRule(RulNum, curtab);
if fmMain.tbtest.down then fmOutput.mmTest.Lines.Add('стек '+inttostr(curtab)+': '+stack.listingstr);
except
showmessage(mes);
Stack.Free;
analys:=false;
exit;
end;
end
else
begin analys := false; Stack.Free; Exit; end;
end;
R := findCol(fmTable.sgF, tZ);
if fmTable.sgF.Cells[C, R] = tDop then Analys := true else Analys := false;
//Унчтожение стека
Stack.Free;
end;


// Методы Стека

constructor TStringStack.Create;
begin
inherited Create;
Empty := true;
end;

function TStringStack.UpperStr: string;
var res: string;
begin
res := Popstr;
UpperStr := res;
Push(res);
end;

function TStringStack.Upperint: integer;
var res: integer;
begin
res := Popint;
Upperint := res;
Push(res);
end;


function TStringStack.Popstr: string;
var P: Pointer;
I: longint;
res: string[4];
begin
if Empty then Popstr := tZ
else
begin
P := inherited Pop;
I := longint(P);
res := '';
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I) + res;
Popstr := trim(res);
if Count = 0 then Empty := true else Empty := false;
end;
end;

procedure TStringStack.Push(s: string);
var I: Longint;
j: byte;
begin
j := 1;
I := 0;
while (j <= 4) and (j <= length(s)) do
begin
I := I * 256 + ord(s[j]);
inc(j);
end;
inherited Push(Pointer(I));
Empty := false;
end;

function TStringStack.Popint: integer;
var P: Pointer;
begin
if Empty then Popint := 0
else
begin
P := inherited Pop;
Popint := integer(P);
if Count = 0 then Empty := true else Empty := false;
end;
end;

procedure TStringStack.Push(s: integer);
begin
inherited Push(Pointer(s));
Empty := false;
end;

function TStringStack.Listingint: string;
var n:integer;
res: string;
begin
res:='';
for n:=0 to list.count-1 do
begin
res:=res+inttostr(integer(list[n]))+' ';
end;
Listingint:=res;
end;

function TStringStack.Listingstr: string;
var n:integer;i:longint;
res1,res: string;
begin
res1:='';
for n:=0 to list.count-1 do
begin
I := longint(list[n]);
res := '';
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I mod 256) + res;
I := I div 256;
res := chr(I) + res;

res1:=res1+trim(res)+' |';
end;
Listingstr:=res1;
end;


procedure TStringStack.Clear;
begin
while not Empty do Pop;
end;

procedure TfmTable.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Action <> caFree then Exit;
fmTable.Rules.Free;
fmTable.RulesM.Free;
fmTable.RulesO.Free;
fmTable.RulesV.Free;
end;

end.