i,j,k,l,m,n,y,String_counter,constyes,termyes,hesh, // счетчики циклов и строк
NumLex,{Число лексем}NumId,{Число идентификаторов}NumTerm,{Число терминальных символов}NumConst,{Число различных констант}
NumErr{Число ошибочных лексем}: integer;
Error,Found,Flag,Scobka: boolean; // Флаги
str16: string;
k1,kod: integer;
implementation
uses lex2;
{$R *. dfm}
procedure TForm1. N2Click (Sender: TObject);
var i: integer;
begin
OpenDialog1. Filter: ='*. txt';
if opendialog1. Execute and fileExists (openDialog1. FileName)
then
begin
Assignfile (FA, OpenDialog1. FileName);
Reset (FA);
Memo1. Lines. clear;
i: =1;
while not EOF (FA) do
begin
readln (Fa,SA [i]);
Memo1. Lines. Add (SA [i]);
i: =i+1;
end;
Closefile (FA);
end;
end;
// процедура перевода констант в десятичную форму
procedure perevod (SS: string; var Str16: string);
var ch3,ch4,ch, i: integer;
zn: string;
begin
ch: =0; // для римских констант
if (SS [2] ='X') or (SS [2] ='V') or (SS [2] ='I') then
begin
zn: =SS [1] ;
delete (SS,1,1);
while Length (SS) <>0 do
begin
if SS [1] ='X' then begin ch: =ch+10; delete (SS,1,1); end
else begin
if SS [1] ='V'then begin ch: =ch+5; delete (SS,1,1); end
else begin
if ( (SS [1] ='I') and (SS [2] ='I')) or ( (SS [1] ='I') and (SS [2] ='')) then begin ch: =ch+1; delete (SS,1,1); end
else begin
if (SS [1] ='I') and (SS [2] ='X') then begin ch: =ch+9; delete (SS,1,2); end
else begin
if (SS [1] ='I') and (SS [2] ='V') then begin ch: =ch+4; delete (SS,1,2); end;
end; end; end; end; end;
str16: =zn+IntToStr (ch);
exit;
end;
// для 16-рич. констант
If SS [3] in ['0'. '9']
then
ch3: =StrToInt (SS [3]) *16
else
if SS [3] in ['A'. 'F']
then
begin
ch3: =ord (SS [3]);
case ch3 of
65: ch3: =10*16;
66: ch3: =11*16;
67: ch3: =12*16;
68: ch3: =13*16;
69: ch3: =14*16;
70: ch3: =15*16;
end;
end;
If SS [4] in ['0'. '9']
then
ch4: =StrToInt (SS [4])
else
if SS [4] in ['A'. 'F']
then
begin
ch4: =ord (SS [4]);
case ch4 of
65: ch4: =10;
66: ch4: =11;
67: ch4: =12;
68: ch4: =13;
69: ch4: =14;
70: ch4: =15;
end;
end;
ch: =ch3+ch4;
If (SS [3] ='0') and (SS [4] ='0')
then Str16: =IntToStr (ch)
else Str16: =SS [2] +IntToStr (ch);
end;
procedure TForm1. N3Click (Sender: TObject);
begin
close;
end;
function Select_Lex (S: string; {исх. строка} var Rez: string; {лексема}N: integer {текущая позиция}): integer;
label 1;
begin // функция выбора слов из строки
k: = Length (S);
Rez: ='';
i: =N; // точка продолжения в строке
while (S [i] =' ') and (i<= k) do i: =i+1; // пропуск ' '
while not (S [i] in deleter) and (i<= k) do // накопление лексемы
begin
if s [i] ='$' then
begin
Rez: =s [i] +s [i+1] ;
i: =i+2;
end
else begin
1: Rez: =Rez+s [i] ;
i: =i+1;
end;
end;
if Rez='' then
begin
if (s [i] =': ') then
begin
if (s [i+1] ='=') then // в случае операции из двух символов
begin
Rez: =s [i] +s [i+1] ;
Select_Lex: =i+2;
end
else
begin
Rez: =s [i] ;
Select_Lex: =i+1;
end;
end else
begin
if ( (s [i] ='+') or (s [i] ='-')) and (s [i-1] =' (')
then begin
Rez: =s [i] +s [i+1] ;
i: =i+2;
goto 1;
end
else begin
Rez: =s [i] ;
Select_Lex: =i+1;
end; end;
end else Select_Lex: =i;
end;
procedure Add_Const (Curr_term: integer; str_lex: string); // Процедура добавления идентификаторов в дерево
begin
if NumConst=1 then // Если корень дерева еще не создан, то создаем его.
begin
perevod (str_lex,str16);
Const_tab [NumConst]. value: =str_lex;
Const_tab [NumConst]. nomer: =NumConst;
Const_tab [NumConst]. Val10: =str16;
Const_tab [NumConst]. Left: =0;
Const_tab [NumConst]. Right: =0;
Const_tab [NumConst]. Way: ='V';
Exit;
end;
if (CompareStr (Const_tab [Curr_term]. value,str_lex) >0) then // Если значение текущего узла дерева больше добавляемого
if Const_tab [Curr_term]. Left=0 then // если у этого элемента дерева нет левого указателя, то
begin
perevod (str_lex,str16);
Const_tab [Curr_term]. Left: =NumConst; // Создание левого элемента.
Const_tab [NumConst]. value: =str_lex;
Const_tab [NumConst]. nomer: =NumConst;
Const_tab [NumConst]. Val10: =str16;
Const_tab [NumConst]. Left: =0;
Const_tab [NumConst]. Right: =0;
Const_tab [NumConst]. Way: =Const_tab [NumConst]. Way+'L';
end else begin
Const_tab [NumConst]. Way: =Const_tab [NumConst]. Way+'L';
Add_Const (Const_tab [Curr_term]. Left,str_lex); // Если левый указатель существует, то вызываем уже функцию для левого указателя.
end;
if (CompareStr (Const_tab [Curr_term]. value,str_lex) <0) then // если у этого элемента дерева нет правого указателя, то
if Const_tab [Curr_term]. Right=0 then
begin
perevod (str_lex,str16);
Const_tab [Curr_term]. Right: =NumConst; // Создаем правый элемент.
Const_tab [NumConst]. value: =str_lex;
Const_tab [NumConst]. nomer: =NumConst;
Const_tab [NumConst]. Val10: =str16;
Const_tab [NumConst]. Left: =0;
Const_tab [NumConst]. Right: =0;
Const_tab [NumConst]. Way: =Const_tab [NumConst]. Way+'R';
end else begin
Const_tab [NumConst]. Way: =Const_tab [NumConst]. Way+'R';
Add_Const (Const_tab [Curr_term]. Right,str_lex); // Если правый указатель существует, то вызываем уже функцию для правого указателя.
end;
end;
procedure Add_Term (Curr_term: integer; str_lex: string); // Процедура добавления идентификаторов в дерево
begin
if NumTerm=1 then // Если корень дерева еще не создан, то создаем его.
begin
Term_tab [NumTerm]. lex: =str_lex;
Term_tab [NumTerm]. nomer: =NumTerm;
Term_tab [NumTerm]. Left: =0;
Term_tab [NumTerm]. Right: =0;
Term_tab [NumTerm]. Way: ='V';
Exit;
end;
if (CompareStr (Term_tab [Curr_term]. lex,str_lex) >0) then // Если значение текущего узла дерева больше добавляемого
if Term_tab [Curr_term]. Left=0 then // если у этого элемента дерева нет левого указателя, то
begin
Term_tab [Curr_term]. Left: =NumTerm; // Создание левого элемента.
Term_tab [NumTerm]. lex: =str_lex;
Term_tab [NumTerm]. nomer: =NumTerm;
Term_tab [NumTerm]. Left: =0;
Term_tab [NumTerm]. Right: =0;
Term_tab [NumTerm]. Way: =Term_tab [NumTerm]. Way+'L';
end else begin
Term_tab [NumTerm]. Way: =Term_tab [NumTerm]. Way+'L';
Add_Term (Term_tab [Curr_term]. Left,str_lex); // Если левый указатель существует, то вызываем уже функцию для левого указателя.
end;
if (CompareStr (Term_tab [Curr_term]. lex,str_lex) <0) then // если у этого элемента дерева нет правого указателя, то
if Term_tab [Curr_term]. Right=0 then
begin
Term_tab [Curr_term]. Right: =NumTerm; // Создаем правый элемент.
Term_tab [NumTerm]. lex: =str_lex;
Term_tab [NumTerm]. nomer: =NumTerm;
Term_tab [NumTerm]. Left: =0;
Term_tab [NumTerm]. Right: =0;
Term_tab [NumTerm]. Way: =Term_tab [NumTerm]. Way+'R';
end else begin
Term_tab [NumTerm]. Way: =Term_tab [NumTerm]. Way+'R';
Add_Term (Term_tab [Curr_term]. Right,str_lex); // Если правый указатель существует, то вызываем уже функцию для правого указателя.
end;
end;
procedure Add_Ident (str: string); // процедура добавления константы
var i: integer;
begin
kod: =Length (str) +2;
hesh: =0;
for i: =1 to Length (str) do hesh: =hesh+ord (str [i]); // вычисление хэш
hesh: =round (hesh/kod); // метод деления
while (Id_tab [hesh]. lex<>'') and (hesh<maxnum) do // пока ячейка занята
begin
Id_tab [hesh]. ssylka: =hesh+1;
hesh: =hesh+1;
end;
Id_tab [hesh]. nomer: =Numid; // запись данных
Id_tab [hesh]. lex: =str;
end;
function Search_Ident (str: string): integer; // функция поиска терминала
var i: integer;
label 1;
begin
kod: =Length (str) +2;
hesh: =0;
for i: =1 to Length (str) do hesh: =hesh+ord (str [i]); // вычисление хэш
hesh: =round (hesh/kod);
1: if str=Id_tab [hesh]. lex then Search_Ident: =Id_tab [hesh]. nomer else // поиск идентификатора
begin
if Id_tab [hesh]. ssylka=0 then Search_Ident: =0 else
begin
hesh: =Id_tab [hesh]. ssylka;
goto 1;
end;
end;
end;
procedure Search_Const (Curr_term: integer; str_lex: string); // Процедура поиска лексем в дереве идентификаторов
begin
Constyes: =0; // флаг: найдена ли лексема
if (NumConst<>0) and (str_lex<>'') then
begin
if (CompareStr (Const_tab [Curr_term]. value,str_lex) >0) and (Const_tab [Curr_term]. Left<>0) then
Search_Const (Const_tab [Curr_term]. Left,str_lex); // рекурсивный "спуск по дереву"
if (CompareStr (Const_tab [Curr_term]. value,str_lex) <0) and (Const_tab [Curr_term]. Right<>0) then
Search_Const (Const_tab [Curr_term]. Right,str_lex);
if Const_tab [Curr_term]. value=str_lex then Constyes: =Const_tab [Curr_term]. nomer;
end;
end;
procedure Search_Term (Curr_term: integer; str_lex: string); // Процедура поиска лексем в дереве идентификаторов
begin
Termyes: =0; // флаг: найдена ли лексема
if (NumTerm<>0) and (str_lex<>'') then
begin
if (CompareStr (Term_tab [Curr_term]. lex,str_lex) >0) and (Term_tab [Curr_term]. Left<>0) then
Search_Term (Term_tab [Curr_term]. Left,str_lex); // рекурсивный "спуск по дереву"
if (CompareStr (Term_tab [Curr_term]. lex,str_lex) <0) and (Term_tab [Curr_term]. Right<>0) then
Search_Term (Term_tab [Curr_term]. Right,str_lex);
if Term_tab [Curr_term]. lex=str_lex then Termyes: =Term_tab [Curr_term]. nomer;
end;
end;
// функция распознавания 16-рич. констант
function FConst (str: string): integer;
var
sost: byte;
begin
sost: =0;
if str [1] ='$' then // распознаём символ '$'
begin
sost: =1;
delete (str,1,1);
end
else exit;
if (str [1] ='+') or (str [1] ='-') then // распознаём знак
begin
sost: =2;
delete (str,1,1)
end
else begin sost: =4; exit; end;
if str='' then exit;
while length (str) >0 do begin
if (str [1] in cifra) or (str [1] in bukva)
then sost: =2 // распознаём буквы или цифры
else begin sost: =4; exit;
end;
delete (str,1,1);
end;
sost: =3;
if sost=3 then FConst: =1 else FConst: =-1;
end;
function termin: integer; // распознаватель терминальных символов
begin
termin: =-1;
for k: =1 to 14 do if Words [k] =Lexem then termin: =3;
for k: =1 to 8 do if Razdel [k] =Lexem then termin: =1;
for k: =1 to 11 do if Operacii [k] =Lexem then termin: =2;
end;
function Rome (str: string): integer; // распознаватель римских констант
var sost: byte;
begin
sost: =0;
if (str [1] ='-') or (str [1] ='+')
then begin sost: =12; delete (str,1,1); end;
if str='' then exit;
if str [1] ='X'
then begin sost: =1; delete (str,1,1) end
else begin
if str [1] ='V' then begin sost: =2; delete (str,1,1) end
else begin
if str [1] ='I' then begin sost: =3; delete (str,1,1) end
else begin sost: =4; exit; end; end; end;
while Length (str) <>0 do begin
case sost of
1: if str [1] ='X'
then begin sost: =5; delete (str,1,1) end
else begin
if str [1] ='V' then begin sost: =2; delete (str,1,1) end
else begin
if str [1] ='I' then begin sost: =3; delete (str,1,1) end
else begin sost: =4; exit; end; end; end;
2: if str [1] ='I'
then begin sost: =7; delete (str,1,1) end
else begin sost: =4; exit; end;
3: if str [1] ='X'
then begin sost: =8; delete (str,1,1) end
else begin
if str [1] ='V' then begin sost: =9; delete (str,1,1) end
else begin
if str [1] ='I' then begin sost: =10; delete (str,1,1) end
else begin sost: =4; exit; end; end; end;
4: exit;
5: if str [1] ='X'
then begin sost: =6; delete (str,1,1) end
else begin
if str [1] ='V' then begin sost: =2; delete (str,1,1) end
else begin
if str [1] ='I' then begin sost: =3; delete (str,1,1) end
else begin sost: =4; exit; end; end; end;
6: if str [1] ='V'
then begin sost: =2; delete (str,1,1) end
else begin
if str [1] ='I' then begin sost: =3; delete (str,1,1) end
else begin sost: =4; exit; end; end;
7: if str [1] ='I'
then begin sost: =10; delete (str,1,1) end
else begin sost: =4; exit; end;
8: begin sost: =4; exit; end;
9: begin sost: =4; exit; end;
10: if str [1] ='I'
then begin sost: =11; delete (str,1,1) end
else begin sost: =4; exit; end;
11: begin sost: =4; exit; end;
end;
end;
if (sost=4) or (sost=12) then Rome: =-1 else Rome: =1;
end;
// функция распознавания идентификаторов
function Ident (str: string): integer;
var
sost: byte;
begin
sost: =0; // реализация конечного автомата
if str [1] in ['a'. 'z'] then
begin
sost: =1;
delete (str,1,1)
end
else exit;
while length (str) >0 do begin
if str [1] in ['a'. 'z','0'. '9','_']
then begin sost: =1; delete (str,1,1); end
else begin sost: =3; exit; end;
end;
sost: =2;
if sost=2 then ident: =1 else ident: =-1;
end;
procedure WriteCode (nomer: integer; lex: string; typ: char; num: integer); // запись в таблицу кодов лексем
begin
Code_Tab [NumLex]. nomer: =nomer;
Code_Tab [NumLex]. Lex: =lex;
Code_Tab [NumLex]. typ: =typ;
Code_Tab [NumLex]. Num: =num;
Code_Tab [NumLex]. numstr: =string_counter+1;
end;
procedure WriteLex (typelex: char); // запись лексем в таблицы
begin
case typelex of
'C': begin // если лексема-16-рич. константа
NumLex: =NumLex+1;
Search_Const (1,Lexem);
if Constyes=0 then // если лексема не найдена
begin
NumConst: =NumConst+1;
Add_Const (1,Lexem);
Const_tab [NumConst]. Typ: ='16-рич. ';