Скачиваний:
12
Добавлен:
01.05.2014
Размер:
39.46 Кб
Скачать
unit uMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ToolWin, StdCtrls, ExtCtrls, Grids, ImgList, Menus;

const sep: char = ' ';
comptab: array[1..8, 1..8] of byte = ((1, 1, 5, 1, 5, 0, 0, 5), //integer
(1, 2, 3, 1, 5, 0, 0, 5), //shortint
(5, 3, 3, 5, 5, 0, 0, 5), //byte
(1, 1, 5, 4, 5, 0, 0, 5), //word
(5, 5, 5, 5, 5, 0, 0, 5), //longint
(0, 0, 0, 0, 0, 6, 0, 0), //boolean
(0, 0, 0, 0, 0, 0, 7, 0), //boolmatr
(5, 5, 5, 5, 5, 0, 0, 5)); //Диапазон
type
TSect = (sBegin, sLabel, sType, sVar, sConst, sBody, sComment, sUnknown);
TLexType = (ltResWord, ltOper, ltArifm, ltRel, ltConst, ltVar, ltType, ltLabel, ltError, ltNone);

TfmMain = class(TForm)
pnTable: TPanel;
Splitter1: TSplitter;
pnWind: TPanel;
mmOutput: TMemo;
ToolBar1: TToolBar;
tbGo: TToolButton;
ToolButton2: TToolButton;
StaticText1: TStaticText;
sgType: TStringGrid;
Splitter3: TSplitter;
StaticText2: TStaticText;
sgConst: TStringGrid;
Splitter4: TSplitter;
StaticText3: TStaticText;
sgLabel: TStringGrid;
StaticText4: TStaticText;
sgConstStr: TStringGrid;
PageControl1: TPageControl;
tsDynamic: TTabSheet;
tsStatic: TTabSheet;
sgResWord: TStringGrid;
StaticText5: TStaticText;
StaticText6: TStaticText;
sgOp: TStringGrid;
StaticText7: TStaticText;
sgArifm: TStringGrid;
StaticText8: TStaticText;
sgRel: TStringGrid;
Splitter5: TSplitter;
Splitter6: TSplitter;
Splitter7: TSplitter;
Splitter8: TSplitter;
ToolButton3: TToolButton;
tbLoad: TToolButton;
tbSave: TToolButton;
OpenDialog: TOpenDialog;
SaveDialog: TSaveDialog;
ToolButton1: TToolButton;
tbNew: TToolButton;
ImageList1: TImageList;
tbAnalys: TToolButton;
tbTables: TToolButton;
pmTables: TPopupMenu;
mnMain: TMenuItem;
mnOper: TMenuItem;
mnExpr: TMenuItem;
stStrConst: TStaticText;
sgVar: TStringGrid;
Splitter9: TSplitter;
ToolButton4: TToolButton;
tbTest: TToolButton;
MainMenu1: TMainMenu;
MFile: TMenuItem;
MFOpen: TMenuItem;
MFNew: TMenuItem;
MFSave: TMenuItem;
MFExit: TMenuItem;
MHelp: TMenuItem;
MHHelp: TMenuItem;
MRun: TMenuItem;
MRLex: TMenuItem;
MRSyntax: TMenuItem;
mmInput: TMemo;
tbAssembly: TToolButton;
tbRun: TToolButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure tbGoClick(Sender: TObject);
procedure tbLoadClick(Sender: TObject);
procedure tbNewClick(Sender: TObject);
procedure tbAnalysClick(Sender: TObject);
procedure mnMainClick(Sender: TObject);
procedure mnOperClick(Sender: TObject);
procedure mnExprClick(Sender: TObject);
procedure tbTablesClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure tbTestClick(Sender: TObject);
procedure MHHelpClick(Sender: TObject);
procedure tbSaveClick(Sender: TObject);
procedure tbRunClick(Sender: TObject);
procedure tbAssemblyClick(Sender: TObject);
{ procedure ToolButton6Click(Sender: TObject);}
private
{ Private declarations }
public
{ Public declarations }
ResWord, //Список зарезервированных строк
Arifm,
Oper,
Rel,
_Const,
_var,
_label, //Метки
_labelBody, //Метки в теле программы
_labelBodyG, //Метки после оператора goto
_type: TstringList;
separ: array[1..255] of char;
end;

var
fmMain: TfmMain;
CurDir: string; // Каталог запуска
PredCurSect: TSect; // Тип предыдущей секции
CurSect: TSect; // Тип текущей секции
ErrorStr: string; // Строка сообщения об ошибке
Error: boolean; // Признак ошибки
Comment: boolean; // Признак коментария
MarkLabel: boolean; // Признак проаерки меток
LWGoto: boolean; // Последнее зарезервированое слово - goto

function digit(ch: char): boolean;
procedure AddToGrid(var sg: TStringGrid; Val: string);

implementation

uses uTable, contnrs, uOutput, uAssembly, TetCompUnit;
var wvir: boolean = false; // Признак того что текущий поток выражение в операторе write
vir: boolean = false; // Признак того что текущий поток выражение
virindex: boolean = false; //Признак того, что это выражение в индексе
analyses: boolean = false;
_write: boolean = false; // Признак того, что текущее выражение оператор write
intype: byte = 0; //Тип при входе в выражение;
outtype: byte = 0; //Тип при выходе из выражения
{$R *.dfm}
//Процедуры для работы с сетками

procedure InitSGrids(var sg: TStringGrid);
begin
sg.ColWidths[1] := 300;
sg.Cells[0, 0] := 'Код';
sg.Cells[1, 0] := 'Имя';
sg.Cells[0, 1] := '1';
sg.Cells[1, 1] := '';
if (sg.Name = 'sgVar') or (sg.Name = 'sgType') or (sg.Name = 'sgConst') then
begin
sg.ColWidths[2] := 100;
sg.Cells[2, 0] := 'Тип';
sg.Cells[2, 1] := '';
end;
if (sg.Name = 'sgConst') then
begin
sg.ColWidths[3] := 100;
sg.Cells[3, 0] := 'Значение';
sg.Cells[3, 1] := '';
end;

sg.RowCount := 2;
end;

//Заполнение

procedure AddToGrid(var sg: TStringGrid; Val: string);
var i: word;
begin
i := sg.RowCount;
sg.RowCount := i + 1;
sg.Cells[0, i - 1] := intToStr(i - 1);
sg.Cells[1, i - 1] := val;
if sg.Name = 'sgVar' then sg.Cells[2, i - 1] := 'none' else
if (sg.Name = 'sgType') and (i > 8) then sg.Cells[2, i - 1] := 'none'
else sg.Cells[2, i - 1] := inttostr(i - 1);
if (sg.Name = 'sgConst') then
begin
if (i <= 3) then sg.Cells[2, i - 1] := inttostr(fmMain._type.IndexOf('boolean') + 1)
else sg.Cells[2, i - 1] := inttostr(fmMain._type.IndexOf('longint') + 1);
if i=3 then sg.Cells[3, i - 1] := inttostr(1)
else sg.Cells[3, i - 1] := inttostr(0);
end;
end;

// Вывод из списка в сетку

procedure FillGrid(var sg: TstringGrid; var sl: TstringList);
var i: word;
begin
for i := 0 to sl.Count - 1 do
begin
AddToGrid(sg, sl[i]);
end;
end;

// загрузка из файла в список

procedure LoadToList(var sl: TStringList; FN: string);
var f: textfile;
s: string;
begin
assignfile(f, FN);
try
reset(f);
while not eof(f) do
begin
readln(f, s);
sl.Add(s);
end;
except
showmessage('Файл ' + FN + ' не найден или поврежден');
end;
closefile(f);
end;

procedure loadSepar;
var f: textfile;
i: byte;
s: string;
begin
try
assignfile(f, curdir + '\separ.stt');
reset(f);
readln(f, s);
for i := 1 to length(s) do
begin
fmMain.separ[i] := s[i];
end;
fmMain.separ[length(s) + 1] := #0;
except
showmessage('Файл separ.stt не найден или поврежден');
end;
closefile(f);
end;

function inSepar(ch: char): boolean;
var i: 1..256;
begin
i := 1;
while (fmMain.separ[i] <> #0) and (fmMain.separ[i] <> ch) and (i < 256) do inc(i);
if fmMain.separ[i] = ch then inSepar := true else inSepar := false
end;

procedure TfmMain.FormCreate(Sender: TObject);
begin
CurDir := GetCurrentDir;
InitSGrids(sgVar);
InitSGrids(sgConst);
InitSGrids(sgType);
InitSGrids(sgLabel);
InitSGrids(sgResWord);
InitSGrids(sgArifm);
InitSGrids(sgRel);
InitSGrids(sgOp);
InitSGrids(sgConstStr);
//Инициализация списков
ResWord := TStringList.Create;
Arifm := TStringList.Create;
Oper := TStringList.Create;
Rel := TStringList.Create;
_Const := TStringList.Create;
_var := TStringList.Create;
_label := TStringList.Create;
_labelBody := TStringList.Create;
_labelBodyG := TStringList.Create;
_type := TStringList.Create;
//Загрузка из файлов
LoadToList(ResWord, curdir + '\resword.stt');
FillGrid(sgResWord, ResWord);
LoadToList(Arifm, curdir + '\Arifm.stt');
FillGrid(sgArifm, Arifm);
LoadToList(Oper, curdir + '\Oper.stt');
FillGrid(sgOp, Oper);
LoadToList(Rel, curdir + '\Relation.stt');
FillGrid(sgRel, Rel);
LoadToList(_Type, curdir + '\Type.stt');
FillGrid(sgType, _Type);
LoadToList(_Const, curdir + '\const.stt');
FillGrid(sgConst, _Const);
PredCurSect:=sUnknown;
// Загрузка разделителей
loadSepar;
end;

procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ResWord.Free;
Arifm.Free;
Oper.Free;
Rel.Free;
_Const.Free;
_var.Free;
_label.Free;
_type.Free;
_labelBody.Free;
_labelBodyG.Free;
{ fmTable.Rules.Free;
fmTable.RulesM.Free;
fmTable.RulesO.Free;
fmTable.RulesV.Free;}
end;

// процедуры лексического анализатора

function Liter(ch: char): boolean;
begin
if (ch in ['a'..'z']) or (ch in ['A'..'Z']) then Liter := true
else Liter := false;
end;

function digit(ch: char): boolean;
begin
if (ch in ['0'..'9']) then digit := true
else digit := false;
end;

function LexChar(ch: char): boolean;
begin
if Liter(ch) or Digit(ch) or (ch = '_') then LexChar := true
else LexChar := false;
end;
//Пропуск пробелов

procedure PassSpace(s: string; var begi: integer);
begin
while (begi <= length(s)) and (s[begi] = ' ') do inc(begi);
end;
//Пропуск коментариев

procedure PassComment(s: string; var begi: integer);
begin
while (begi <= length(s)) and ((s[begi] <> '}') and not ((s[begi - 1] = '*') and (s[begi] = ')'))) do
inc(begi);
if begi <= length(s) then
begin
Comment := false;
inc(begi);
end;
end;
// пропуск строковой константы

procedure PassString(s: string; var begi: integer; var outs: string);
var res: string;
begin
res := '';
while (s[begi] <> '''') and (begi <= length(s)) do
begin
res := res + s[begi];
inc(begi);
end;
if begi > length(s) then
begin
ErrorStr := 'Ожидался символ ''';
Error := true;
end
else
begin
addToGrid(fmMain.sgConstStr, res);
outs := outs + 's' + inttostr(fmMain.sgConstStr.RowCount - 2) + sep;
end;
// outs:=outs+res+''''+sep;
end;

// Чтение лексемы-слова

function GetLexW(s: string; var begi: integer): string;
var res: string;
begin
res := '';
while (begi <= length(s)) and LexChar(s[begi]) and not inSepar(s[begi]) do
begin
res := res + s[begi];
inc(begi);
end;
if (begi > length(s)) or inSepar(s[begi]) then GetLexW := res
else GetLexW := '';
end;
// Чтение лексемы-знака

function GetLexS(s: string; var begi: integer): string;
var res: string;
begin
res := '';
if (s[begi] in ['а'..'я']) or ((ord(s[begi]) >= ord('А')) and (ord(s[begi]) <= ord('Я'))) then
begin
ErrorStr := 'Неверный идентификатор';
Error := true;
GetLexS := '';
Exit;
end; // if
if (begi < length(s)) and (LexChar(s[begi]) or (s[begi] = ' ')) then res := s[begi] else
if (begi = length(s)) or (s[begi] in [';', '=', ',', '[', ']', '+', '-', '/', '{', '}', ')', '''']) then res := s[begi]
else
begin
case s[begi] of
':': if s[begi + 1] = '=' then res := ':=' else res := ':';
'<': if s[begi + 1] = '=' then res := '<=' else
if s[begi + 1] = '>' then res := '<>' else res := '<';
'>': if s[begi + 1] = '=' then res := '>=' else res := '>';
'.': if s[begi + 1] = '.' then res := '..' else
if s[begi + 1] = ')' then res := ']' else res := '.';
'(': if s[begi + 1] = '.' then res := '[' else
if s[begi + 1] = '*' then res := '{' else res := '(';
'*': if s[begi + 1] = ')' then res := '}' else res := '*';
end; //case
end; //ifelse
inc(begi, length(res));
GetLexS := res;
end;

function InList(lex: string): boolean; // Проверка на наличие лексемы в любом списке
begin
if (fmMain.ResWord.IndexOf(Lex) = -1) and
(fmMain._Const.IndexOf(Lex) = -1) and
(fmMain._Type.IndexOf(Lex) = -1) and
(fmMain._var.IndexOf(Lex) = -1) and
(fmMain._Label.IndexOf(Lex) = -1) and
(fmMain.Oper.IndexOf(Lex) = -1) and
(fmMain.Arifm.IndexOf(Lex) = -1) then InList := false
else InList := true;
end;

function VerifyLabel(var i: word): boolean;
var j, k: integer;
begin
i := 0;
j := 0;
while (j <= fmMain._labelBodyG.Count - 1) and
(fmMain._labelBody.IndexOf(fmMain._labelBodyG[j]) <> -1) do
begin
inc(j);
end;
if j > fmMain._labelBodyG.Count - 1 then VerifyLabel := true
else
begin
ErrorStr := 'Необъявленная в теле программы, метка ' + fmMain._labelBodyG[j];
// Поиск строки с ошибкой
k := 0;
while (k <= fmMain.mmOutput.Lines.Count - 1) and
(pos('w' + intToStr(fmMain.ResWord.IndexOf('goto') + 1) + sep + 'l' + intToStr(fmMain._label.IndexOf(fmMain._labelBodyG[j]) + 1), fmMain.mmOutput.Lines[k]) = 0) do inc(k);
// i:=fmMain.mmOutput.Lines.IndexOf('w'+intToStr(fmMain.ResWord.IndexOf('goto'))+sep+'l'+intToStr(fmMain.ResWord.IndexOf(fmMain._labelBodyG[j])));
i := k + 1;
VerifyLabel := false;
end;
end;

function DefineTypeLex(var Lex: string): TLexType;
begin
//проверяем в списке зарезервированных слов
if Lex = '' then
begin
DefineTypeLex := ltNone;
exit;
end;
ErrorStr := 'Неопределенный идентификатор';
DefineTypeLex := ltError;
if fmMain.ResWord.IndexOf(Lex) <> -1 then DefineTypeLex := ltResWord else
if CurSect = sBody then
begin
// if fmMain.ResWord.IndexOf(Lex)<>-1 then DefineTypeLex:=ltResWord else
if fmMain._Const.IndexOf(Lex) <> -1 then DefineTypeLex := ltConst else
if fmMain._Type.IndexOf(Lex) <> -1 then DefineTypeLex := ltType else
if fmMain._var.IndexOf(Lex) <> -1 then DefineTypeLex := ltVar else
if fmMain._Label.IndexOf(Lex) <> -1 then DefineTypeLex := ltLabel else
if fmMain.Oper.IndexOf(Lex) <> -1 then DefineTypeLex := ltOper else
if fmMain.Arifm.IndexOf(Lex) <> -1 then DefineTypeLex := ltArifm else
DefineTypeLex := ltError
end
else
case CurSect of
sVar: DefineTypeLex := ltVar;
sConst: DefineTypeLex := ltConst;
sLabel: DefineTypeLex := ltLabel;
sType: DefineTypeLex := ltType;
sBegin: DefineTypeLex := ltConst;

end; //case
end;

procedure SetSym(Lex: string; var Outs: string);
begin
if Lex = '' then exit;
if (Lex = '[') and not vir then begin {intype:=5; outtype:=0;} virindex := true; outs := outs + lex + sep + '$' + sep end else
if (Lex = ',') and (wvir or virindex) then begin outs := outs + 'Eps' + sep + lex + sep + '$' + sep; {outtype:=0;} end else
if (Lex = ']') and virindex then begin virindex := false; {outtype:=0;} outs := outs + 'Eps' + sep + lex + sep end else
if Lex = '.' then outs := outs + 'Eps' + sep + lex + sep else
if (Lex = ':=') then begin vir := true; outs := outs + 'o' + intToStr(fmMain.Oper.IndexOf(Lex) + 1) + sep + '$' + sep end else
if (Lex = ';') and vir then begin vir := false; {outtype:=0;} outs := outs + 'Eps' + sep + lex + sep; end else
if (Lex = ';') and _write then begin _write := false; outs := outs + lex + sep; end else
if (Lex = ')') and _write and wvir then begin wvir := false; {outtype:=0;} outs := outs + 'Eps' + sep + lex + sep; end else
if (Lex = '=') and (CurSect<>sType) and not vir and not wvir then begin vir := true; outs := outs + 'r6' + sep + '$' + sep; end else
if lex = '..' then outs := outs + 'Eps' + sep + 'r' + intToStr(fmMain.rel.IndexOf(Lex) + 1) + sep + '$' + sep else
if fmMain.Oper.IndexOf(Lex) <> -1 then outs := outs + 'o' + intToStr(fmMain.Oper.IndexOf(Lex) + 1) + sep else
if fmMain.rel.IndexOf(Lex) <> -1 then outs := outs + 'r' + intToStr(fmMain.rel.IndexOf(Lex) + 1) + sep else
if fmMain.Arifm.IndexOf(Lex) <> -1 then outs := outs + 'a' + intToStr(fmMain.Arifm.IndexOf(Lex) + 1) + sep else
outs := outs + lex + sep;
end;

procedure ChangeSect(var Lex: string);
begin
case CurSect of
sConst: begin
if (Lex = '=') or (Lex = ':') then
begin
PredCurSect := CurSect;
CurSect := sBody;
end;
end; //sConst
sVar: begin
if (Lex = ':') then
begin
PredCurSect := CurSect;
CurSect := sBody;
end;
end; //sVar;
sType: begin
if (Lex = '=') then
begin
// Lex:=Lex+sep+'$';
PredCurSect := CurSect;
CurSect := sBody;
end;
end; //sVar;
sBody: begin
if (PredCurSect <> sUnknown) and (Lex = ';') then
begin
Cursect := PredCurSect;
PredCurSect := sUnknown;
end; //if
end; //sVar;

end; //case;
end;

procedure ResWord(Lex: string; var outs: string);
begin
if fmMain.ResWord.IndexOf(lex) = -1 then
begin
ErrorStr := 'Ожидалось зарезервированное слово';
Error := true;
Exit;
end;
// Обрабока переключений между грамматиками
if lex = 'then' then begin outs := outs + 'Eps' + sep + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep; vir := false; {outtype:=0;} end else
if lex = 'if' then begin outs := outs + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep + '$' + sep; vir := true; {intype:=fmMain._Type.IndexOf('Boolean');} end else
if lex = 'until' then begin outs := outs + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep + '$' + sep; vir := true; {intype:=fmMain._Type.IndexOf('Boolean');} end else
if (lex = 'else') and vir then begin outs := outs + 'Eps' + sep + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep; vir := false; {outtype:=0;} end else
if (lex = 'end') and vir then begin outs := outs + 'Eps' + sep + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep; vir := false; {outtype:=0;} end else
begin
// Обработка переключений между секциями
outs := outs + 'w' + inttostr(fmMain.ResWord.IndexOf(Lex) + 1) + sep;
if Lex = 'program' then CurSect := sConst else
if Lex = 'var' then CurSect := sVar else
if Lex = 'const' then CurSect := sConst else
if Lex = 'label' then CurSect := sLabel else
if Lex = 'type' then CurSect := sType else
if (CurSect <> sBody) and (Lex = 'begin') then
begin outs := '#' + sep + outs; CurSect := sBody end else
if Lex = 'begin' then CurSect := sBody else
if Lex = 'goto' then LWGoto := true else LWGoto := false;
end;
end;

{function defineTypeVar(lex: string): byte;
var j: byte;
begin
try
j := strtoint(fmMain.sgVar.Cells[2, fmMain._Var.IndexOf(Lex) + 1]);
except
defineTypeVar := 0;
exit;
end;
if j > 7 then
begin if fmMain.sgType.Cells[2, j] = 'none' then defineTypeVar := fmMain._type.IndexOf('longint') + 1; end
else defineTypeVar := strtoint(fmMain.sgType.Cells[2, j]);
end;}

procedure AnalysStr(s: string; var outs: string);
var i, j: integer;
Lex: string;
begin
i := 1;
passSpace(s, i);
if not LexChar(s[i]) then
begin
Lex := GetLexS(s, i);
if (Lex = '{') or Comment then //Если начало коментария, то пропустить
begin
Comment := true;
PassComment(s, i);
end
else
begin
if Lex = '''' then
begin
// SetSym(Lex,Outs);
// outs:=outs+'''';
PassString(s, i, outs);
inc(i);
end
else SetSym(Lex, Outs);
ChangeSect(Lex);
(* ErrorStr:='Неожидаемый символ';
Error:=true;*)

end;
end; //if

while (i <= length(s)) and not Error do
begin
PassSpace(s, i);
if LexChar(s[i]) then // Если текущий символ литера
if digit(s[i]) then // Если текущий символ цифра
begin
Lex := GetLexW(s, i);
try
StrToInt(lex);
if CurSect = sBody then // Если текущая секция тело программы
begin
j := i;
passSpace(s, i);
if not LexChar(s[i]) and (getLexS(s, i) = ':') then // Если текущий символ не литера и равна ':'
if fmMain._label.IndexOf(lex) = -1 then
begin
Error := true;
ErrorStr := 'Необъявленная метка';
end
else
begin
if MarkLabel then begin fmMain._LabelBodyG.Add(Lex); MarkLabel := false; end
else
if fmMain._LabelBody.IndexOf(lex) = -1 then fmMain._LabelBody.Add(Lex)
else
begin
ErrorStr := 'Метка ' + lex + ' необъявлена';
Error := true;
end;
outs := outs + 'l' + inttostr(fmMain._Label.IndexOf(Lex) + 1) + sep + ':' + sep;
end
else
begin
i := j;
if LWGoto then
if fmMain._label.IndexOf(lex) = -1 then
begin
Error := true;
ErrorStr := 'Необъявленная метка';
end
else
begin
if MarkLabel then begin fmMain._LabelBodyG.Add(Lex); MarkLabel := false; end
else
if fmMain._LabelBody.IndexOf(lex) = -1 then fmMain._LabelBody.Add(Lex)
else
begin
ErrorStr := 'Метка ' + lex + ' необъявлена';
Error := true;
end;
outs := outs + 'l' + inttostr(fmMain._Label.IndexOf(Lex) + 1) + sep;
LWGoto := false;
end
else
begin
if (CurSect=sBody) and (PredCurSect=sType) and not vir and not virindex then
begin
outs := outs + '$'+ sep +lex + sep;
vir:=true;
end
else outs := outs + lex + sep;

end
end
end else
if CurSect = sLabel then
begin
if (StrToInt(lex) < 10000) then
begin
if not InList(Lex) then
begin
fmMain._Label.Add(Lex);
AddToGrid(fmMain.sgLabel, Lex);
outs := outs + 'l' + inttostr(fmMain._Label.IndexOf(Lex) + 1) + sep;
end
else
begin
if (fmMain.ResWord.IndexOf(Lex) <> -1) or (fmMain.Arifm.IndexOf(Lex) <> -1) or (fmMain.Oper.IndexOf(Lex) <> -1) then ErrorStr := 'Зарезервированное слово не может быть использовано в качестве идентификатора'
else ErrorStr := 'Идентификатор объявлен повторно';
Error := true;
Exit;
end
end
else
begin
ErrorStr := 'Неверный идентификатор метки';
Error := true;
Exit;
end;
end // if then
else outs := outs + lex + sep;
except
errorstr := 'Неверный идентификатор';
error := true;
end;
end
else
begin
Lex := GetLexW(s, i);
case CurSect of
sBegin: begin
if Lex <> '' then ResWord(Lex, outs);
end; //sBegin
sConst: begin
case DefineTypeLex(Lex) of
ltResWord: ResWord(Lex, outs);
// ltArifm : outs:=outs+'a'+inttostr(fmMain.Arifm.IndexOf(Lex)+1)+sep;
ltConst: begin
if not InList(Lex) then
begin
fmMain._Const.Add(Lex);
AddToGrid(fmMain.sgConst, Lex);
outs := outs + 'c' + inttostr(fmMain._Const.IndexOf(Lex) + 1) + sep;
end
else
begin
// if fmMain._Const.IndexOf(Lex)<>-1 then outs:=outs+'c'+inttostr(fmMain._Const.IndexOf(Lex)+1)+sep
// else
// begin
if (fmMain.ResWord.IndexOf(Lex) <> -1) or (fmMain.Arifm.IndexOf(Lex) <> -1) or (fmMain.Oper.IndexOf(Lex) <> -1) then ErrorStr := 'Зарезервированное слово не может быть использовано в качестве идентификатора'
else ErrorStr := 'Идентификатор объявлен повторно';
Error := true;
Exit;
// end;//else
end;
end; //ltConst

end; //case

end; //sconst
sVar: begin
case DefineTypeLex(Lex) of
ltResWord: ResWord(Lex, outs);
// ltArifm : outs:=outs+'a'+inttostr(fmMain.Arifm.IndexOf(Lex)+1)+sep;
ltVar: begin
if not InList(Lex) then
begin
fmMain._Var.Add(Lex);
AddToGrid(fmMain.sgVar, Lex);
outs := outs + 'v' + inttostr(fmMain._Var.IndexOf(Lex) + 1) + sep;
end
else
begin
if (fmMain.ResWord.IndexOf(Lex) <> -1) or (fmMain.Arifm.IndexOf(Lex) <> -1) or (fmMain.Oper.IndexOf(Lex) <> -1) then ErrorStr := 'Зарезервированное слово не может быть использовано в качестве идентификатора'
else ErrorStr := 'Идентификатор объявлен повторно';
Error := true;
Exit;
end;
end; //ltVar

end; //case

end; //sVar
sLabel: begin
case DefineTypeLex(Lex) of
ltResWord: ResWord(Lex, outs);
ltLabel: begin
if not InList(Lex) then
begin
fmMain._Label.Add(Lex);
AddToGrid(fmMain.sgLabel, Lex);
outs := outs + 'l' + inttostr(fmMain._Label.IndexOf(Lex) + 1) + sep;
end
else
begin
if (fmMain.ResWord.IndexOf(Lex) <> -1) or (fmMain.Arifm.IndexOf(Lex) <> -1) or (fmMain.Oper.IndexOf(Lex) <> -1) then ErrorStr := 'Зарезервированное слово не может быть использовано в качестве идентификатора'
else ErrorStr := 'Идентификатор объявлен повторно';
Error := true;
Exit;
end;
end; //ltLabel

end; //case
end; //sLabel
sType: begin
case DefineTypeLex(Lex) of
ltResWord: ResWord(Lex, outs);
ltType: begin
if not InList(Lex) then
begin
fmMain._Type.Add(Lex);
AddToGrid(fmMain.sgType, Lex);
outs := outs + 't' + inttostr(fmMain._Type.IndexOf(Lex) + 1) + sep;
end
else
begin
if (fmMain.ResWord.IndexOf(Lex) <> -1) or (fmMain.Arifm.IndexOf(Lex) <> -1) or (fmMain.Oper.IndexOf(Lex) <> -1) then ErrorStr := 'Зарезервированное слово не может быть использовано в качестве идентификатора'
else ErrorStr := 'Идентификатор объявлен повторно';
Error := true;
Exit;
end;
end; //ltLabel

end; //case
end; //sLabel
sBody: begin
if DefineTypeLex(Lex) = ltError then
begin
Error := true;
exit;
end
else
begin
case DefineTypeLex(Lex) of
ltResWord: begin
if Lex = 'goto' then MarkLabel := true
else MarkLabel := false;
ResWord(Lex, outs);
end;
ltConst:
begin
if (CurSect=sBody) and (PredCurSect=sType) and not vir then
begin
outs := outs + '$'+ sep + 'c' + inttostr(fmMain._Const.IndexOf(Lex) + 1) + sep;
vir:=true;
end
else outs := outs + 'c' + inttostr(fmMain._Const.IndexOf(Lex) + 1) + sep;
end;
ltVar: if (PredCurSect = sConst) or (PredCurSect = sVar) or (PredCurSect = sType) then
begin
Error := true;
ErrorStr := 'Переменная в константном выражении';
exit;
end
else // Если предыдущая секция тело
{ begin // Проверка на соответствие типов
if not (vir or wvir) then intype:=defineTypeVar(Lex)
else // Если выражение
begin
if outtype=0 then outtype:=defineTypeVar(Lex)
else // Если outtype <> 0
begin
j:=defineTypeVar(Lex);
outtype:=comptab[j,outtype];
if outtype=0 then
begin
Error:=true;
ErrorStr:='Несоответствие типов';
Exit;
end; // if outtype=0
end; // ifelse outtype<>0
end; // ifelse Если выражение}
outs := outs + 'v' + inttostr(fmMain._Var.IndexOf(Lex) + 1) + sep;
// end;
ltLabel: begin
if MarkLabel then begin fmMain._LabelBodyG.Add(Lex); MarkLabel := false; end
else
if fmMain._LabelBody.IndexOf(lex) = -1 then fmMain._LabelBody.Add(Lex)
else
begin
ErrorStr := 'Метка ' + lex + ' объявлена повторно';
Error := true;
end;
outs := outs + 'l' + inttostr(fmMain._Label.IndexOf(Lex) + 1) + sep;
end;
ltType: begin
if PredCurSect = sVar then
begin
j := fmMain.sgVar.RowCount - 2;
while fmMain.sgVar.Cells[2, j] = 'none' do
begin
if fmMain._Type.IndexOf(Lex) + 1 < 7 then fmMain.sgVar.Cells[2, j] := fmMain.sgType.Cells[2, fmMain._Type.IndexOf(Lex) + 1]
else fmMain.sgVar.Cells[2, j] := inttostr(fmMain._Type.IndexOf(Lex) + 1);
dec(j);
end;
end else
if PredCurSect = sType then
begin
j := fmMain.sgType.RowCount - 2;
if fmMain.sgType.Cells[2, j] = 'none' then
fmMain.sgType.Cells[2, j] := inttostr(fmMain._Type.IndexOf(Lex) + 1);
end;
outs := outs + 't' + inttostr(fmMain._Type.IndexOf(Lex) + 1) + sep;
end;
ltOper: begin
if (lex = 'write') or (lex = 'writeln') then _write := true;
outs := outs + 'o' + inttostr(fmMain.Oper.IndexOf(Lex) + 1) + sep;
end;
ltArifm: outs := outs + 'a' + inttostr(fmMain.Arifm.IndexOf(Lex) + 1) + sep;
end; //case
end; //else

end; //sBody
end; //case
end //then
else
begin
Lex := GetLexS(s, i);
if Lex = '{' then PassComment(s, i)
else
if Lex = '''' then
begin
// outs:=outs+'''';
PassString(s, i, outs);
inc(i);
end
else
if (Lex = '(') and _write then
begin
passSpace(s, i);
if s[i] <> '''' then
begin
wvir := true;
outs := outs + '(' + sep + '$' + sep;
end
else outs := outs + '(' + sep;
end else
if _write and (Lex = ',') and not vir then
begin
if wvir then
begin
outs := outs + 'Eps' + sep;
wvir := false;
end;
if not wvir then
begin
passSpace(s, i);
if s[i] <> '''' then
begin
wvir := true;
outs := outs + ',' + sep + '$' + sep;
end
else outs := outs + ',' + sep;
end
end
else SetSym(Lex, Outs);
ChangeSect(Lex);
end; //else
end; //while
end;

procedure TfmMain.tbGoClick(Sender: TObject);
var i: word;
outstr: string;
begin
InitSGrids(sgVar);
InitSGrids(sgConst);
InitSGrids(sgType);
InitSGrids(sgLabel);
InitSGrids(sgConstStr);
_Var.Clear;
_Const.Clear;
_Type.Clear;
_Label.Clear;
_LabelBody.Clear;
_LabelBodyG.Clear;
LoadToList(_Type, curdir + '\Type.stt');
FillGrid(sgType, _Type);
LoadToList(_Const, curdir + '\const.stt');
FillGrid(sgConst, _Const);
vir:=false;
wvir:=false;
_write:=false;
virindex:=false;
mmOutPut.Clear;
Error := false;
CurSect := sBegin;
LWGoto := false;
i := 0;
while (i < mmInput.Lines.Count) and not Error do
begin
if length(mmInput.Lines[i]) <> 0 then AnalysStr(mmInput.Lines[i], outStr);
if OutStr <> '' then mmOutput.Lines.Add({inttostr(i+1)+') '+} outStr);
inc(i);
outStr := '';
end;
if not Error then Error := not VerifyLabel(i);
if Error then ShowMessage(ErrorStr + ' в строке ' + inttoStr(i));
end;

procedure TfmMain.tbLoadClick(Sender: TObject);
begin
if OpenDialog.Execute then
mmInput.Lines.LoadFromFile(OpenDialog.FileName);
end;

procedure TfmMain.tbNewClick(Sender: TObject);
begin
InitSGrids(sgVar);
InitSGrids(sgConst);
InitSGrids(sgType);
InitSGrids(sgLabel);
InitSGrids(sgConstStr);
_Var.Clear;
_Const.Clear;
_Type.Clear;
_Label.Clear;
_LabelBody.Clear;
_LabelBodyG.Clear;
LoadToList(_Type, curdir + '\Type.stt');
FillGrid(sgType, _Type);
LoadToList(_Const, curdir + '\const.stt');
FillGrid(sgConst, _Const);
mmInPut.Lines.Clear;
mmOutPut.Lines.Clear;
Error := false;
CurSect := sBegin;
end;

procedure TfmMain.tbAnalysClick(Sender: TObject);
var res: TStringList;
i: integer;
s: string;
begin
fmOutput.mmTest.Lines.Clear;
// fmTable.Show;
if analyses then Exit;
Analyses := true;
// fmTable.Rules:=TStringList.Create;
attrs := TStringStack.Create;
attrs.Push(0);
attrs.Popint;
// fmTable.ChangeTables(0);
curtab := 0;
res := TStringLIst.Create;
fmTable.SeqExec := TStringLIst.Create;
fmTable.Triads := TStringLIst.Create;
i := 1;

try
if fmTable.Analys(mmOutPut.Text, i) then
begin
showMessage('Входная цепочка успешно разобрана');
fmOutput.mmTriads.Lines.Assign(fmTable.Triads);
fmOutput.mmTriads.Lines.SaveToFile(CurDir+'\masm\kurs.tet');
fmOutput.mmTest.Lines.Add('end');
fmOutput.Show;
end
else
showMessage('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(i) + ' символе');
except
else

end;


{ if fmTable.Analys(mmOutPut.Text, i) then
begin
showMessage('Входная цепочка успешно разобрана');
end
else
begin
showMessage('Входная цепочка не принадлежит заданному языку, ошибка в ' + inttostr(i) + ' символе');
end;
{ fmOutput.mmTriads.Lines.Assign(fmTable.Triads);
fmOutput.Show;
}
fmTable.SeqExec.Free;
fmTable.Triads.Free;
attrs.Free;
res.Free;
Analyses := false;


end;

{procedure TfmMain.ToolButton6Click(Sender: TObject);
var S:TStringStack;
i:integer;
begin
try
S:=TStringStack.Create;
for i:=1 to mmOutPut.Lines.Count-1 do
S.Push(mmOutPut.Lines[i]);
for i:=1 to mmOutPut.Lines.Count-1 do
mmInPut.Lines.Add(S.Pop);
except
S.Free;
end;
end;}

procedure TfmMain.mnMainClick(Sender: TObject);
begin
if Analyses then exit;
fmTable.ChangeTables(0);
fmTable.Show;
end;

procedure TfmMain.mnOperClick(Sender: TObject);
begin
if Analyses then exit;
fmTable.ChangeTables(1);
fmTable.Show;
end;

procedure TfmMain.mnExprClick(Sender: TObject);
begin
if Analyses then exit;
fmTable.ChangeTables(2);
fmTable.Show;
end;

procedure TfmMain.tbTablesClick(Sender: TObject);
begin
if Analyses then exit;
fmTable.ChangeTables(0);
fmTable.Show;
end;

procedure TfmMain.FormShow(Sender: TObject);
begin
fmTable.Rules := TStringList.Create;
fmTable.RulesM := TStringList.Create;
fmTable.RulesO := TStringList.Create;
fmTable.RulesV := TStringList.Create;
with fmTable do
begin
LoadTable(sgMF, sgMG, mmRulesM, RulesM, CountOfRuleM, curdir + '\sinan\grammain.lrt');
LoadTable(sgOF, sgOG, mmRulesO, RulesO, CountOfRuleO, curdir + '\sinan\gramOPER.lrt');
LoadTable(sgVF, sgVG, mmRulesV, RulesV, CountOfRuleV, curdir + '\sinan\gramVIR1.lrt');
end;
end;

procedure TfmMain.tbTestClick(Sender: TObject);
begin
if Analyses then
begin
tbTest.Down:=not tbTest.Down;
Exit;
end;
fmOutput.mmTest.Visible:=not fmOutput.mmTest.Visible ;
fmOutput.Splitter1.Visible:=not fmOutput.Splitter1.Visible;
end;

procedure TfmMain.MHHelpClick(Sender: TObject);
begin
Application.helpjump(' ');
end;

procedure TfmMain.tbSaveClick(Sender: TObject);
begin
if savedialog.Execute then
mmOutput.Lines.SaveToFile(savedialog.FileName);
end;

procedure TfmMain.tbRunClick(Sender: TObject);
begin
winexec(pchar(CurDir+'\masm\kurs.exe'),1);
end;

procedure TfmMain.tbAssemblyClick(Sender: TObject);
begin
TetCompiler:=TTetCompiler.Create;
TetCompiler.Reset;
TetCompiler.LinesIn.AddStrings(fmOutput.mmTriads.Lines);
TetCompiler.Compile;
fmAssembly.mmAssembly.Clear;
fmAssembly.mmAssembly.Lines.AddStrings(TetCompiler.LinesOut);
fmAssembly.Show;
fmAssembly.mmAssembly.Lines.SaveToFile(CurDir+'\masm\kurs.asm');
SetCurrentDir(CurDir+'\masm');
winexec(pchar(CurDir+'\masm\make.bat'),1);

end;

end.

Соседние файлы в папке compiler
  • #
    01.05.2014700 б12uAssembly.~dfm
  • #
    01.05.2014365 б13uAssembly.~pas
  • #
    01.05.201436.88 Кб12uMain.dcu
  • #
    01.05.201451 б12uMain.ddp
  • #
    01.05.201453.52 Кб12uMain.dfm
  • #
    01.05.201439.46 Кб12uMain.pas
  • #
    01.05.201451 б13uMain.~ddp
  • #
    01.05.201453.5 Кб12uMain.~dfm
  • #
    01.05.201439.46 Кб12uMain.~pas