constructor CreateKey(LexKey: TLexType;

iA,iSt,iP: integer);

constructor CreateVar(VarInf: TVarInfo;

iA,iSt,iP: integer);

constructor CreateConst(iVal: integer;

iA,iSt,iP: integer);

constructor CreateInfo(sInf: string;

iA,iSt,iP: integer);

destructor Destroy; override;

{ Свойства для получения информации о лексеме }

property LexType: TLexType read LexInfo.LexType;

property VarInfo: TVarInfo read LexInfo.VarInfo;

property ConstVal: integer read LexInfo.ConstVal;

{ Свойства для чтения позиции лексемы

в исходном тексте программы }

property StrNum: integer read iStr;

property PosNum: integer read iPos;

property PosAll: integer read iAllP;

{ Текстовая информация о типе лексемы }

function LexInfoStr: string;

{ Имя для лексемы-переменной }

function VarName: string;

end;

{ Структура для описания списка лексем }

TLexList = class(TList)

public

{ Деструктор для освобождения памяти

при уничтожении списка }

destructor Destroy; override;

{ Процедура очистки списка }

procedure Clear; override;

{ Процедура и свойство для получения информации

о лексеме по ее номеру }

function GetLexem(iIdx: integer): TLexem;

property Lexem[iIdx: integer]: TLexem read GetLexem;

default;

end;

implementation

uses SysUtils, LexAuto;

onstructor TLexem.CreateKey(LexKey: TLexType;

iA,iSt,iP: integer);

{ Конструктор создания лексемы типа "ключевое слово" }

begin

inherited Create;

LexInfo.LexType := LexKey;

{ запоминаем тип ключевого слова }

iStr := iSt; { запоминаем позицию лексемы }

iPos := iP;

iAllP := iA;

end;

constructor TLexem.CreateVar(VarInf: TVarInfo;

iA,iSt,iP: integer);

{ Конструктор создания лексемы типа "ключевое слово" }

begin

inherited Create;

LexInfo.LexType := LEX_VAR; { тип - "переменная" }

{ запоминаем ссылку на таблицу идентификаторов }

LexInfo.VarInfo := VarInf;

iStr := iSt; { запоминаем позицию лексемы }

iPos := iP;

iAllP := iA;

end;

constructor TLexem.CreateConst(iVal: integer;

iA,iSt,iP: integer);

{ Конструктор создания лексемы типа "константа" }

begin

inherited Create;

LexInfo.LexType := LEX_CONST; { тип - "константа" }

{ запоминаем значение константы }

LexInfo.ConstVal := iVal;

iStr := iSt; { запоминаем позицию лексемы }

iPos := iP;

iAllP := iA;

end;

constructor TLexem.CreateInfo(sInf: string;

iA,iSt,iP: integer);

{ Конструктор создания информационной лексемы }

begin

inherited Create;

LexInfo.LexType := LEX_START; { тип - "доп. лексема" }

{ выделяем память для информации }

LexInfo.szInfo := StrAlloc(Length(sInf)+1);

{ запоминаем информацию }

StrPCopy(LexInfo.szInfo,sInf);

iStr := iSt; { запоминаем позицию лексемы }

iPos := iP;

iAllP := iA;

end;

destructor TLexem.Destroy;

begin

{ Освобождаем занятую память,

если это информационная лексема }

if LexType = LEX_START then StrDispose(LexInfo.szInfo);

inherited Destroy;

end;

function TLexem.VarName: string;

{ Функция получения имени лексемы типа "переменная" }

begin

Result := VarInfo.VarName;

end;

function TLexem.LexInfoStr: string;

{ Текстовая информация о типе лексемы }

begin

case LexType of

LEX_VAR: Result := VarName;

{ для переменной - ее имя }

LEX_CONST: Result := IntToStr(ConstVal);

{ для константы - значение }

LEX_START: Result := StrPas(LexInfo.szInfo);

{ для инф. лексемы - информация }

else Result := LexTypeInfo(LexType);

{ для остальных - имя типа }

end;

end;

procedure TLexList.Clear;

{ Процедура очистки списка }

var i: integer;

begin

{ Уничтожаем все элементы списка }

for i:=Count-1 downto 0 do Lexem[i].Free;

inherited Clear; { вызываем функцию базового класса }

end;

destructor TLexList.Destroy;

{ Деструктор для освобождения памяти

при уничтожении списка }

begin

Clear; { Уничтожаем все элементы списка }

{ Вызываем деструктор базового класса }

inherited Destroy;

end;

function TLexList.GetLexem(iIdx: integer): TLexem;

{ Получение лексемы из списка по ее номеру }

begin

Result := TLexem(Items[iIdx]);

end;

end.

5. LexAuto

unit LexAuto; {!!! Зависит от входного языка !!!}

interface

{ Модуль, обеспечивающий построение таблицы лексем

по исходному тексту программы }

uses Classes, TblElem, LexType, LexElem;

{ Функция создания списка лексем по исходному

тексту программы }

function MakeLexList(listFile: TStrings;

listLex: TLexList): integer;

implementation

uses SysUtils, FncTree;

type

{ Перечень всех возможных состояний конечного автомата }

TAutoPos = (

AP_START,AP_IF1,AP_IF2,AP_NOT1,AP_NOT2,AP_NOT3,

AP_ELSE1,AP_ELSE2,AP_ELSE3,AP_ELSE4,AP_END2,AP_END3,

AP_PROG1,AP_PROG2,AP_PROG3,AP_PROG4,AP_OR1,AP_OR2,

AP_BEGIN1,AP_BEGIN2,AP_BEGIN3,AP_BEGIN4,AP_BEGIN5,

AP_XOR1,AP_XOR2,AP_XOR3,

AP_AND1,AP_AND2,AP_AND3,

AP_REPEAT1,AP_REPEAT2,AP_REPEAT3,AP_REPEAT4,AP_REPEAT5,

AP_COMM,AP_COMMSG,AP_ASSIGN,AP_VAR,AP_CONST,

AP_UNTIL1,AP_UNTIL2,AP_SIGN,AP_LT,AP_FIN,AP_ERR);

function MakeLexList(listFile: TStrings;

listLex: TLexList): integer;

{ Функция создания списка лексем по исходному

тексту программы }

var

i,j,iCnt,iStr, { Переменные и счетчики циклов }

iAll,{ Счетчик общего количества входных символов }

{ Переменные для запоминания позиции начала лексемы }

iStComm,iStart: integer;

posCur: TAutoPos;{ Текущее состояние конечного автомата }

{ Строки для временного хранения результатов }

sCurStr,sTmp: string;

{ Несколько простых процедур для работы со списком лексем }

procedure AddVarToList(posNext: TAutoPos; iP: integer);

{ Процедура добавления переменной в список }

begin

{ Выделяем имя переменной из текущей строки }

sTmp := System.Copy(sCurStr,iStart,iP-iStart);

{ При создании переменной она сначала заносится

в таблицу идентификаторов, а потом ссылка на нее -

в таблицу лексем }

listLex.Add(TLexem.CreateVar(AddTreeVar(sTmp),

iStComm,i,iStart));

iStart := j;

iStComm := iAll-1;

posCur := posNext;

end;

procedure AddVarKeyToList(keyAdd: TLexType;

posNext: TAutoPos);

{ Процедура добавления переменной и

разделителя в список }

begin

{ Выделяем имя переменной из текущей строки }

sTmp := System.Copy(sCurStr,iStart,j-iStart);

{ При создании переменной она сначала заносится

в таблицу идентификаторов, а потом ссылка на нее -

в таблицу лексем }

listLex.Add(TLexem.CreateVar(AddTreeVar(sTmp),

iStComm,i,iStart));

{ Добавляем разделитель после переменной }

listLex.Add(TLexem.CreateKey(keyAdd,iAll,i,j));

iStart := j;

iStComm := iAll-1;

posCur := posNext;

end;

function StrBinToInt(S : string) : integer;

var

ii, li, mi : integer;

begin

li:=length(S);

if li>8 then begin

posCur := AP_ERR;

li:=8;

end;

mi:=1;

Result:=0;

for ii := li downto 1 do begin

case S[ii] of

'0':;

'1': Result:=Result+mi;

else begin

Result:=0;

posCur := AP_ERR;

Exit;

end;

end;

mi:=mi*2;

end;

end;

procedure AddConstToList(posNext: TAutoPos; iP: integer);

{ Процедура добавления константы в список }

begin

{ Выделяем константу из текущей строки }

sTmp := System.Copy(sCurStr,iStart,iP-iStart);

{ Заносим константу в список вместе с ее значением }

listLex.Add(TLexem.CreateConst(StrBinToInt(sTmp),

iStComm,i,iStart));

iStart := j;

iStComm := iAll-1;

if posCur<>AP_ERR then

posCur := posNext;

end;

procedure AddConstKeyToList(keyAdd: TLexType;

posNext: TAutoPos);

{ Процедура добавления константы и разделителя в список }

begin

{ Выделяем константу из текущей строки }

sTmp := System.Copy(sCurStr,iStart,j-iStart);

{ Заносим константу в список вместе с ее значением }

listLex.Add(TLexem.CreateConst(StrBinToInt(sTmp),iStComm,

i,iStart));

{ Добавляем разделитель после константы }

listLex.Add(TLexem.CreateKey(keyAdd,iAll,i,j));

iStart := j;

iStComm := iAll-1;

if posCur<>AP_ERR then

posCur := posNext;

end;

procedure AddKeyToList(keyAdd: TLexType;

posNext: TAutoPos);

{ Процедура добавления ключевого слова или

разделителя в список }

begin

listLex.Add(TLexem.CreateKey(keyAdd,iStComm,i,iStart));

iStart := j;

iStComm := iAll-1;

posCur := posNext;

end;

procedure Add2KeysToList(keyAdd1,keyAdd2: TLexType;

posNext: TAutoPos);

{ Процедура добавления ключевого слова и

разделителя в список }

begin

listLex.Add(TLexem.CreateKey(keyAdd1,iStComm,i,iStart));

listLex.Add(TLexem.CreateKey(keyAdd2,iAll,i,j));

iStart := j;

iStComm := iAll-1;

posCur := posNext;

end;

procedure KeyLetter(chNext: char; posNext: TAutoPos);

{ Процедура проверки очередного символа ключевого слова }

begin

case sCurStr[j] of

':': AddVarToList(AP_ASSIGN,j);

'-': AddVarKeyToList(LEX_SUB,AP_SIGN);

'+': AddVarKeyToList(LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': AddVarKeyToList(LEX_EQ,AP_SIGN);

'>': AddKeyToList(LEX_GT,AP_SIGN);

'<': AddVarToList(AP_LT,j);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

';': AddVarKeyToList(LEX_SEMI,AP_START);

' ',#10,#13,#9: AddVarToList(AP_START,j);

else

if sCurStr[j] = chNext then posCur := posNext

else

if sCurStr[j] in ['0'..'9','A'..'Z','a'..'z','_']

then posCur := AP_VAR

else posCur := AP_ERR;

end{case list};

end;

procedure KeyFinish(keyAdd: TLexType);

{ Процедура проверки завершения ключевого слова }

begin

case sCurStr[j] of

'-': Add2KeysToList(keyAdd,LEX_UMIN,AP_SIGN);

'+': Add2KeysToList(keyAdd,LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': Add2KeysToList(keyAdd,LEX_EQ,AP_SIGN);

'>': Add2KeysToList(keyAdd,LEX_GT,AP_SIGN);

'<': AddKeyToList(keyAdd,AP_LT);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

';': Add2KeysToList(keyAdd,LEX_SEMI,AP_START);

'0'..'9','A'..'Z','a'..'z','_': posCur := AP_VAR;

' ',#10,#13,#9: AddKeyToList(keyAdd,AP_SIGN);

else posCur := AP_ERR;

end{case list};

end;

begin

{ Обнуляем общий счетчик символов и результат функции }

iAll := 0;

Result := 0;

iStComm := 0;

{ Устанавливаем начальное состояние конечного автомата }

posCur := AP_START;

{ Цикл по всем строкам входного файла }

iCnt := listFile.Count-1;

for i:=0 to iCnt do

begin

{ Позиция начала лексемы - первый символ }

iStart := 1;

{ Запоминаем текущую строку }

sCurStr := listFile[i];

{ Цикл по всем символам текущей строки }

iStr := Length(sCurStr);

j:=0;

repeat

Inc(j);

{ Увеличиваем общий счетчик символов }

Inc(iAll);

{ Моделируем работу конечного автомата в зависимости

от состояния КА и текущего символа входной строки }

case posCur of

AP_START:

begin

{ В начальном состоянии запоминаем позицию

начала лексемы }

iStart := j;

iStComm := iAll-1;

case sCurStr[j] of

'b': posCur := AP_BEGIN1;

'i': posCur := AP_IF1;

'p': posCur := AP_PROG1;

'e': posCur := AP_ELSE1;

'r': posCur := AP_REPEAT1;

'u': posCur := AP_UNTIL1;

'o': posCur := AP_OR1;

'x': posCur := AP_XOR1;

's': posCur := AP_SHL1;

'a': posCur := AP_AND1;

'n': posCur := AP_NOT1;

':': posCur := AP_ASSIGN;

'-': AddKeyToList(LEX_SUB,AP_SIGN);

'+': AddKeyToList(LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': AddKeyToList(LEX_EQ,AP_SIGN);

'>': AddKeyToList(LEX_GT,AP_SIGN);

'<': posCur := AP_LT;

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

';': AddKeyToList(LEX_SEMI,AP_START);

'0'..'9': posCur := AP_CONST;

'A'..'Z','c','f'..'h','j'..'m',

'q'..'r','t'..'v','y','z','_': posCur := AP_VAR;

' ',#10,#13,#9: ;

else posCur := AP_ERR;

end{case list};

end;

AP_SIGN:

begin

{ Состояние, когда может встретиться

унарный минус }

iStart := j;

iStComm := iAll-1;

case sCurStr[j] of

'b': posCur := AP_BEGIN1;

'i': posCur := AP_IF1;

'p': posCur := AP_PROG1;

'e': posCur := AP_ELSE1;

'w': posCur := AP_REPEAT1;

'd': posCur := AP_UNTIL1;

'o': posCur := AP_OR1;

'x': posCur := AP_XOR1;

's': posCur := AP_SHL1;

'a': posCur := AP_AND1;

'n': posCur := AP_NOT1;

'-': AddKeyToList(LEX_UMIN,AP_SIGN);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

'0'..'9': posCur := AP_CONST;

'A'..'Z','c','f'..'h','j'..'m',

'q'..'r','t'..'v','y','z','_': posCur := AP_VAR;

' ',#10,#13,#9: ;

else posCur := AP_ERR;

end{case list};

end;

AP_LT:

{ Знак меньше или знак неравенства? }

case sCurStr[j] of

'b': AddKeyToList(LEX_LT,AP_BEGIN1);

'i': AddKeyToList(LEX_LT,AP_IF1);

'p': AddKeyToList(LEX_LT,AP_PROG1);

'e': AddKeyToList(LEX_LT,AP_ELSE1);

'r': AddKeyToList(LEX_LT,AP_REPEAT1);

'u': AddKeyToList(LEX_LT,AP_UNTIL1);

'o': AddKeyToList(LEX_LT,AP_OR1);

'x': AddKeyToList(LEX_LT,AP_XOR1);

's': AddKeyToList(LEX_LT,AP_SHL1);

'a': AddKeyToList(LEX_LT,AP_AND1);

'n': AddKeyToList(LEX_LT,AP_NOT1);

'>': AddKeyToList(LEX_NEQ,AP_SIGN);

'-': Add2KeysToList(LEX_LT,LEX_UMIN,AP_SIGN);

'(': Add2KeysToList(LEX_LT,LEX_OPEN,AP_SIGN);

'0'..'9': AddKeyToList(LEX_LT,AP_CONST);

'A'..'Z','c','f'..'h','j'..'m','q'..'r','t'..'v',

'y','z','_': AddKeyToList(LEX_LT,AP_VAR);

' ',#10,#13,#9: AddKeyToList(LEX_LT,AP_SIGN);

else posCur := AP_ERR;

end{case list};

AP_ELSE1:

{ "else", или же "end", или переменная? }

case sCurStr[j] of

'l': posCur := AP_ELSE2;

'n': posCur := AP_END2;

':': AddVarToList(AP_ASSIGN,j);

'-': AddVarKeyToList(LEX_SUB,AP_SIGN);

'+': AddVarKeyToList(LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': AddVarKeyToList(LEX_EQ,AP_SIGN);

'>': AddKeyToList(LEX_GT,AP_SIGN);

'<': AddVarToList(AP_LT,j);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

';': AddVarKeyToList(LEX_SEMI,AP_START);

'0'..'9','A'..'Z','a'..'k','m',

'o'..'z','_': posCur := AP_VAR;

' ',#10,#13,#9: AddVarToList(AP_START,j);

else posCur := AP_ERR;

end{case list};

AP_IF1: KeyLetter('f',AP_IF2);

AP_IF2: KeyFinish(LEX_IF);

AP_ELSE2: KeyLetter('s',AP_ELSE3);

AP_ELSE3: KeyLetter('e',AP_ELSE4);

AP_ELSE4: KeyFinish(LEX_ELSE);

AP_OR1: KeyLetter('r',AP_OR2);

AP_OR2: KeyFinish(LEX_OR);

AP_UNTIL1: KeyLetter('o',AP_UNTIL2);

AP_UNTIL2: KeyFinish(LEX_UNTIL);

AP_XOR1: KeyLetter('o',AP_XOR2);

AP_XOR2: KeyLetter('r',AP_XOR3);

AP_XOR3: KeyFinish(LEX_XOR);

AP_AND1: KeyLetter('n',AP_AND2);

AP_AND2: KeyLetter('d',AP_AND3);

AP_AND3: KeyFinish(LEX_AND);

AP_NOT1: KeyLetter('o',AP_NOT2);

AP_NOT2: KeyLetter('t',AP_NOT3);

AP_NOT3: KeyFinish(LEX_NOT);

AP_PROG1: KeyLetter('r',AP_PROG2);

AP_PROG2: KeyLetter('o',AP_PROG3);

AP_PROG3: KeyLetter('g',AP_PROG4);

AP_PROG4: KeyFinish(LEX_PROG);

AP_REPEAT1: KeyLetter('h',AP_REPEAT2);

AP_REPEAT2: KeyLetter('i',AP_REPEAT3);

AP_REPEAT3: KeyLetter('l',AP_REPEAT4);

AP_REPEAT4: KeyLetter('e',AP_REPEAT5);

AP_REPEAT5: KeyFinish(LEX_REPEAT);

AP_BEGIN1: KeyLetter('e',AP_BEGIN2);

AP_BEGIN2: KeyLetter('g',AP_BEGIN3);

AP_BEGIN3: KeyLetter('i',AP_BEGIN4);

AP_BEGIN4: KeyLetter('n',AP_BEGIN5);

AP_BEGIN5: KeyFinish(LEX_BEGIN);

AP_END2: KeyLetter('d',AP_END3);

AP_END3:

{ "end", или же "end.", или переменная? }

case sCurStr[j] of

'-': Add2KeysToList(LEX_END,LEX_UMIN,AP_SIGN);

'+': Add2KeysToList(LEX_END,LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': Add2KeysToList(LEX_END,LEX_EQ,AP_SIGN);

'>': Add2KeysToList(LEX_END,LEX_GT,AP_SIGN);

'<': AddKeyToList(LEX_END,AP_LT);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'{': posCur := AP_COMMSG;

';': Add2KeysToList(LEX_END,LEX_SEMI,AP_START);

'.': AddKeyToList(LEX_FIN,AP_START);

'0'..'9','A'..'Z','a'..'z','_':

posCur := AP_VAR;

' ',#10,#13,#9: AddKeyToList(LEX_END,AP_SIGN);

else posCur := AP_ERR;

end{case list};

AP_ASSIGN:

case sCurStr[j] of

'=': AddKeyToList(LEX_ASSIGN,AP_SIGN);

else posCur := AP_ERR;

end{case list};

AP_VAR:

case sCurStr[j] of

':': AddVarToList(AP_ASSIGN,j);

'-': AddVarKeyToList(LEX_SUB,AP_SIGN);

'+': AddVarKeyToList(LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': AddVarKeyToList(LEX_EQ,AP_SIGN);

'>': AddVarKeyToList(LEX_GT,AP_SIGN);

'<': AddVarToList(AP_LT,j);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'\': posCur := AP_COMMSG;

';': AddVarKeyToList(LEX_SEMI,AP_START);

'0'..'9','A'..'Z','a'..'z','_':

posCur := AP_VAR;

'^': AddVarToList(AP_COMM,j);

' ',#10,#13,#9: AddVarToList(AP_START,j);

else posCur := AP_ERR;

end{case list};

AP_CONST:

case sCurStr[j] of

':': AddConstToList(AP_ASSIGN,j);

'-': AddConstKeyToList(LEX_SUB,AP_SIGN);

'+': AddConstKeyToList(LEX_ADD,AP_SIGN);

'*': AddKeyToList(LEX_MUL,AP_SIGN);

'/': AddKeyToList(LEX_DIV,AP_SIGN);

'=': AddConstKeyToList(LEX_EQ,AP_SIGN);

'>': AddConstKeyToList(LEX_GT,AP_SIGN);

'<': AddConstToList(AP_LT,j);

'(': AddKeyToList(LEX_OPEN,AP_SIGN);

')': AddKeyToList(LEX_CLOSE,AP_START);

'}': posCur := AP_COMMSG;

';': AddConstKeyToList(LEX_SEMI,AP_START);

'0'..'9': posCur := AP_CONST;

' ',#10,#13,#9: AddConstToList(AP_START,j);

else posCur := AP_ERR;

end{case list};

AP_COMM:

case sCurStr[j] of

'\': if (j<iStr)and(sCurStr[j+1]=')') then begin

posCur := AP_START;

Inc(j);

Inc(iAll);

end;

end{case list};

AP_COMMSG:

case sCurStr[j] of

'}': if (j<iStr)and(sCurStr[j+1]=')') then begin

posCur := AP_SIGN;

Inc(j);

Inc(iAll);

end;

end{case list};

end{case pos};

{ Проверяем, не достигнут ли конец строки }

if j = iStr then

begin

{ Конец строки - это конец текущей лексемы }

case posCur of

AP_IF2: AddKeyToList(LEX_IF,AP_SIGN);

AP_PROG4: AddKeyToList(LEX_PROG,AP_START);

AP_ELSE4: AddKeyToList(LEX_ELSE,AP_START);

AP_BEGIN5: AddKeyToList(LEX_BEGIN,AP_START);

AP_REPEAT5: AddKeyToList(LEX_REPEAT,AP_SIGN);

AP_END3: AddKeyToList(LEX_END,AP_START);

AP_OR2: AddKeyToList(LEX_OR,AP_SIGN);

AP_UNTIL2: AddKeyToList(LEX_UNTIL,AP_SIGN);

AP_XOR3: AddKeyToList(LEX_XOR,AP_SIGN);

AP_AND3: AddKeyToList(LEX_AND,AP_SIGN);

AP_NOT3: AddKeyToList(LEX_AND,AP_SIGN);

AP_LT: AddKeyToList(LEX_LT,AP_SIGN);

AP_FIN: AddKeyToList(LEX_FIN,AP_START);

AP_CONST: AddConstToList(AP_START,j+1);

AP_ASSIGN: posCur := AP_ERR;

AP_IF1,AP_PROG1,AP_PROG2,AP_PROG3,

AP_ELSE1,AP_ELSE2,AP_ELSE3,AP_XOR1,AP_XOR2,

AP_OR1,AP_UNTIL1,AP_AND1,AP_AND2,AP_NOT1,AP_NOT2,

AP_REPEAT1,AP_REPEAT2,AP_REPEAT3,AP_REPEAT4,

AP_END2,AP_BEGIN1,AP_BEGIN2,AP_BEGIN3,AP_BEGIN4,

AP_VAR: AddVarToList(AP_START,j+1);

end{case pos2};

end;

{ Проверяем не была ли ошибка в лексемах }

if posCur = AP_ERR then

begin

{ Если была ошибка, вычисляем позицию

ошибочной лексемы }

iStart := (j - iStart)+1;

{ и запоминаем ее в виде фиктивной лексемы в начале

списка для детальной диагностики ошибки }

listLex.Insert(0,

TLexem.CreateInfo('Недопустимая лексема',

iAll-iStart,i,iStart));

{ Если ошибка, прерываем цикл }

Break;

end;

do j=iStr;

{ В конце строки увеличиваем общий счетчик символов

на 2: конец строки и возврат каретки }

Inc(iAll,2);

{ Если ошибка, запоминаем номер ошибочной строки

и прерываем цикл }

if posCur = AP_ERR then

begin

Result := i+1;

Break;

end;

end;

{ Если комментарий не был закрыт, то это ошибка }

if posCur in [AP_COMM,AP_COMMSG] then

begin

listLex.Insert(0,

TLexem.CreateInfo('Незакрытый комментарий',

iStComm,iCnt,iAll-iStComm));

Result := iCnt;

end

else

if not (posCur in [AP_START,AP_SIGN,AP_ERR]) then

{ Если КА не в начальном состоянии -

это неверная лексема }

begin

listLex.Insert(0,

TLexem.CreateInfo('Незавершенная лексема',

iAll-iStart,iCnt,iStart));

Result := iCnt;

end;

end;

end.

6. LexType

unit LexType; {!!! Зависит от входного языка !!!}

interface

{ Модуль, содержащий описание всех типов лексем }

type

{ Возможные типы лексем в программе }

TLexType =

(LEX_PROG, LEX_FIN, LEX_SEMI, LEX_IF, LEX_OPEN, LEX_CLOSE,

LEX_ELSE, LEX_BEGIN, LEX_END, LEX_REPEAT, LEX_UNTIL, LEX_VAR,

LEX_CONST, LEX_ASSIGN, LEX_OR, LEX_XOR, LEX_AND,

LEX_LT, LEX_GT, LEX_EQ, LEX_NEQ, LEX_NOT,

LEX_SUB, LEX_ADD,LEX_MUL,LEX_DIV, LEX_UMIN, LEX_START);

{ Функция получения строки наименования типа лексемы }

function LexTypeName(lexT: TLexType): string;

{ Функция получения текстовой информации о типе лексемы }

function LexTypeInfo(lexT: TLexType): string;

implementation

function LexTypeName(lexT: TLexType): string;

{ Функция получения строки наименования типа лексемы }

begin

case lexT of

LEX_OPEN: Result := 'Открывающая скобка';

LEX_CLOSE: Result := 'Закрывающая скобка';

LEX_ASSIGN: Result := 'Знак присвоения';

LEX_VAR: Result := 'Переменная';

LEX_CONST: Result := 'Константа';

LEX_SEMI: Result := 'Разделитель';

LEX_ADD,LEX_SUB,LEX_MUL,LEX_DIV,LEX_UMIN,LEX_GT,LEX_LT,LEX_EQ,

LEX_NEQ: Result := 'Знак операции';

else Result := 'Ключевое слово';

end;

end;

function LexTypeInfo(lexT: TLexType): string;

{ Функция получения текстовой информации о типе лексемы }

begin

case lexT of

LEX_PROG: Result := 'prog';

LEX_FIN: Result := 'end.';

LEX_SEMI: Result := ';';

LEX_IF: Result := 'if';

LEX_OPEN: Result := '(';

LEX_CLOSE: Result := ')';

LEX_ELSE: Result := 'else';

LEX_BEGIN: Result := 'begin';

LEX_END: Result := 'end';

LEX_REPEAT: Result := 'repeat';

LEX_UNTIL: Result := 'until';

LEX_VAR: Result := 'a';

LEX_CONST: Result := 'c';

LEX_ASSIGN: Result := ':=';

LEX_OR: Result := 'or';

LEX_XOR: Result := 'xor';

LEX_AND: Result := 'and';

LEX_LT: Result := '<';

LEX_GT: Result := '>';

LEX_EQ: Result := '=';

LEX_NEQ: Result := '<>';

LEX_NOT: Result := 'not';

LEX_ADD: Result := '+';

LEX_MUL: Result := '*';

LEX_DIV: Result := '/';

LEX_SUB,

LEX_UMIN: Result := '-';

else Result := '';

end;

end;

end.

7. SyntRyle

unit SyntRule; {!!! Зависит от входного языка !!!}

interface

{ Модуль, содержащий описание матрицы предшествования и правил грамматики }

uses LexType, Classes;

const

RULE_LENGTH = 7; { максимальная длина правила

(в расчете на символы грамматики) }

RULE_NUM = 30; { общее количество правил грамматики }

var

{ Матрица операторного предшествования }

GramMatrix: array[TLexType,TLexType] of char =

( {pr. end. ; if ( ) else beg end rpt until a c := or xor and < > = <> not - + um ! * /}

{pr.} (' ','=','<','<',' ',' ',' ','<',' ','<',' ','<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{end.}(' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ','>',' ',' '),

{;} (' ','>','>','<',' ',' ',' ','<','>','<',' ','<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{if} (' ',' ',' ',' ','=',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{(} (' ',' ',' ',' ','<','=',' ',' ',' ',' ',' ','<','<',' ','<','<','<','<','<','<','<','<','<','<','<',' ','<','<'),

{)} (' ','>','>','<',' ','>','=','<','>','<','=','<',' ',' ','>','>','>','>','>','>','>',' ','>','>',' ',' ','>','>'),

{else}(' ','>','>','<',' ',' ','>','<','>','<',' ','<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{beg.}(' ',' ','<','<',' ',' ',' ','<','=','<',' ','<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{end} (' ','>','>',' ',' ',' ','>',' ','>',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{repeat}(' ',' ',' ',' ','=',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{until} (' ','>','>','<',' ',' ','>','<','<','<',' ','<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{a} (' ','>','>',' ',' ','>','>',' ','>',' ',' ',' ',' ','=','>','>','>','>','>','>','>',' ','>','>',' ',' ','>','>'),

{c} (' ','>','>',' ',' ','>','>',' ','>',' ',' ',' ',' ',' ','>','>','>','>','>','>','>',' ','>','>',' ',' ','>','>'),

{:=} (' ','>','>',' ','<',' ','>',' ','>',' ',' ','<','<',' ',' ',' ',' ',' ',' ',' ',' ',' ','<','<','<',' ','<','<'),

{or} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','<','<','<','<','<','<','<','<','<',' ','<','<'),

{xor} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','<','<','<','<','<','<','<','<','<',' ','<','<'),

{and} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','>','<','<','<','<','<','<','<','<',' ','<','<'),

{<} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','>',' ',' ',' ',' ',' ','<','<','<',' ','<','<'),

{>} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','>',' ',' ',' ',' ',' ','<','<','<',' ','<','<'),

{=} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','>',' ',' ',' ',' ',' ','<','<','<',' ','<','<'),

{<>} (' ',' ',' ',' ','<','>',' ',' ',' ',' ',' ','<','<',' ','>','>','>',' ',' ',' ',' ',' ','<','<','<',' ','<','<'),

{not} (' ',' ',' ',' ','=',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{-} (' ','>','>',' ','<','>','>',' ','>',' ',' ','<','<',' ','>','>','>','>','>','>','>',' ','>','>','<',' ','<','<'),

{+} (' ','>','>',' ','<','>','>',' ','>',' ',' ','<','<',' ','>','>','>','>','>','>','>',' ','>','>','<',' ','<','<'),

{um} (' ','>','>',' ','<','>','>',' ','>',' ',' ','<','<',' ','>','>','>','>','>','>','>',' ','>','>','<',' ','>','>'),

{!} ('<',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '),

{*} (' ','>','>',' ','<','>','>',' ','>',' ',' ','<','<',' ','>','>','>','>','>','>','>',' ','>','>','<',' ','<','<'),

{/} (' ','>','>',' ','<','>','>',' ','>',' ',' ','<','<',' ','>','>','>','>','>','>','>',' ','>','>','<',' ','<','<')

)

);

{ Правила исходной грамматики }

GramRules: array[1..RULE_NUM] of string =

('progEend.','E','E;E','E;','if(B)EelseE','if(B)E',

'beginEend','repeat(B)untilE','a:=E','BorB','BxorB','B',

'BandB','B','E<E','E>E','E=E','E<>E','(B)','not(B)',

'E-E','E+E','E','-E','E','(E)','a','c', 'E*E','E/E');

function MakeSymbolStr(iRuleNum: integer): string;

{ Функция корректировки отношений предшествования

для расширения матрицы предшествования }

function CorrectRule(cRule: char; lexTop,lexCur: TLexType;

symbStack: TList): char;

implementation

uses SyntSymb;

function MakeSymbolStr(iRuleNum: integer): string;

begin

if iRuleNum in [10..20] then Result := 'B'

else Result := 'E';

end;

function CorrectRule(cRule: char; lexTop,lexCur: TLexType;

symbStack: TList): char;

var j: integer;

begin

{ Корректируем отношение для символа "else", если в стеке

не логическое выражение }

Result := cRule;

if (cRule = '=') and (lexTop = LEX_CLOSE)

and (lexCur = LEX_ELSE) then

begin

j := TSymbStack(symbStack).Count-1;

if (j > 2)

and (TSymbStack(symbStack)[j-2].SymbolStr <> 'B')

then Result := '>';

end;

end;

end.

8. SyntSymb

unit SyntSymb;

interface

{ Модуль, обеспечивающий выполнение функций синтаксического

разбора с помощью алгоритма "сдвиг-свертка" на основе

матрицы операторного предшествования }

uses Classes, LexElem, SyntRule;

type

{ Два типа символов: терминальные (лексемы)

и нетерминальные (синтаксические) }

TSymbKind = (SYMB_LEX, SYMB_SYNT);

{ Структура данных для информации о символе грамматики }

TSymbInfo = record

{ Тип символа - терминальный или нетерминальный }

case SymbType: TSymbKind of

{ Для терминального символа - ссылка на лексему }

SYMB_LEX: (LexOne: TLexem);

{ Для нетерминального символа - ссылка на список

символов, из которых он был построен }

SYMB_SYNT: (LexList: TList);

end;

{ Предварительное описание класса "Символ" }

TSymbol = class;

{ Массив символов, составляющих правило грамматики }

TSymbArray = array[0..RULE_LENGTH] of TSymbol;

{ Структура, описывающая грамматический символ }

TSymbol = class(TObject)

protected

{ Информация о символе }

SymbInfo: TSymbInfo;

{ Номер правила, по которому создан символ }

iRuleNum: integer;

public

{ Конструктор создания терминального символа

на основе лексемы }

constructor CreateLex(Lex: TLexem);

{ Конструктор создания нетерминального символа

на основе правила и массива символов }

constructor CreateSymb(iR,iSymbN: integer;

const SymbArr: TSymbArray);

{ Деструктор для удаления символа }

destructor Destroy; override;

{ Функция получения символа из правила по порядковому

номеру символа }

function GetItem(iIdx: integer): TSymbol;

{ Функция, возвращающее количество символов

в исходном правиле }

function Count: integer;

{ Функция, формирующая строковое представление символа }

function SymbolStr: string;

{ Свойства символа на основе описанных выше

функций и данных }

{ Свойство, возвращающее тип символа }

property SymbType: TSymbKind read SymbInfo.SymbType;

{ Свойство, возвращающее ссылку на лексему

для терминального символа }

property Lexem: TLexem read SymbInfo.LexOne;

{ Свойство, возвращающее символа из правила

по порядковому номеру символа }

property Items[iIdx: integer]: TSymbol read GetItem;

default;

{ Свойство, возвращающее номер правила }

property Rule: integer read iRuleNum;

end;

{ Структура, описывающая синтаксический стек }

TSymbStack = class(TList)

public

{ Деструктор для удаления стека }

destructor Destroy; override;

{ Функция очистки стека }

procedure Clear; override;

{ Функция выборки символа по порядковому номеру

от конца стека }

function GetSymbol(iIdx: integer): TSymbol;

{ Функция помещения в стек входящей лексемы }

function Push(lex: TLexem): TSymbol;

{ Свойство для выборки символа по порядковому номеру

от вершины стека }

property Symbols[iIdx: integer]: TSymbol read GetSymbol;

default;

{ Функция, возвращающая самую верхнюю лексему в стеке }

function TopLexem: TLexem;

{ Функция, выполняющая свертку и помещающая новый символ

на вершину стека }

function MakeTopSymb: TSymbol;

end;

{ Функция, выполняющая алгоритм "сдвиг-свертка" }

function BuildSyntList(const listLex: TLexList;

symbStack: TSymbStack): TSymbol;

implementation

uses LexType, LexAuto;

constructor TSymbol.CreateLex(Lex: TLexem);

{ Конструктор создания терминального символа

на основе лексемы }

begin

{ Вызываем конструктор базового класа }

inherited Create;

{ Ставим тип символа "терминальный" }

SymbInfo.SymbType := SYMB_LEX;

{ Запоминаем ссылку на лексему }

SymbInfo.LexOne := Lex;

{ Правило не используется, поэтому "0" }

iRuleNum := 0;

end;

constructor TSymbol.CreateSymb(iR{номер правила},

iSymbN{кол-во исходных символов}: integer;

const SymbArr: TSymbArray{массив исходных символов});

{ Конструктор создания нетерминального символа

на основе правила и массива символов }

var i: integer;

begin

{ Вызываем конструктор базового класа }

inherited Create;

{ Ставим тип символа "нетерминальный" }

SymbInfo.SymbType := SYMB_SYNT;

{ Создаем список для хранения исходных символов }

SymbInfo.LexList := TList.Create;

{ Переносим все исходные символы в список

в обратном порядке }

for i:=iSymbN-1 downto 0 do

SymbInfo.LexList.Add(SymbArr[i]);

{ Запоминаем номер правила }

iRuleNum := iR;

end;

function TSymbol.GetItem(iIdx: integer): TSymbol;

{ Функция получения символа из правила

по порядковому номеру символа }

begin

Result := TSymbol(SymbInfo.LexList[iIdx])

end;

function TSymbol.Count: integer;

{ Функция, возвращающее количество символов

в исходном правиле }

begin

Result := SymbInfo.LexList.Count;

end;

function TSymbol.SymbolStr: string;

{ Функция, формирующая строковое представление символа }

begin

{ Если это нетерминальный символ, формируем его

представление в зависимости от номера правила }

if SymbType = SYMB_SYNT then

Result := MakeSymbolStr(iRuleNum)

{ Если это терминальный символ, формируем его

представление в соответствии со строковым

представлением лексемы }

else Result := Lexem.LexInfoStr;

end;

destructor TSymbol.Destroy;

{ Деструктор для удаления символа }

var i: integer;

begin

if SymbInfo.SymbType = SYMB_SYNT then

{ Если это нетерминальный символ }

with SymbInfo.LexList do

begin

{ Удаляем все его исходные символы из списка }

for i:=Count-1 downto 0 do TSymbol(Items[i]).Free;

{ Удаляем список символов }

Free;

end;

{ Вызываем деструктор базового класа }

inherited Destroy;

end;

destructor TSymbStack.Destroy;

{ Деструктор для удаления синтаксического стека }

begin

{ Очищаем стек }

Clear;

{ Вызываем деструктор базового класа }

inherited Destroy;

end;

procedure TSymbStack.Clear;

{ Функция очистки синтаксического стека }

var i: integer;

begin

{ Удаляем все символы из стека }

for i:=Count-1 downto 0 do TSymbol(Items[i]).Free;

{ Вызываем функцию базового класса }

inherited Clear;

end;

function TSymbStack.GetSymbol(iIdx: integer): TSymbol;

{ Функция выборки символа по порядковому номеру

от конца стека }

begin

Result := TSymbol(Items[iIdx]);

end;

function TSymbStack.TopLexem: TLexem;

{ Функция, возвращающая самую верхнюю лексему

в синтаксическом стеке }

var i: integer;

begin

Result := nil;

{ Для всех символов начиная от вершины стека }

for i:=Count-1 downto 0 do

{ Если это терминальный символ }

if Symbols[i].SymbType = SYMB_LEX then

begin

{ Берем ссылку на лексему }

Result := Symbols[i].Lexem;

{ Прекращаем поиск }

Break;

end;

end;

function TSymbStack.Push(lex: TLexem): TSymbol;

{ Функция помещения лексемы в синтаксический стек }

begin

{ Создаем новый терминальный символ }

Result := TSymbol.CreateLex(lex);

{ Добавляем его в стек }

Add(Result);

end;

function TSymbStack.MakeTopSymb: TSymbol;

{ Функция, выполняющая свертку и помещающая новый символ

на вершину стека.

Результат функции:

nil - если не удалось выполнить свертку, иначе ссылка

на новый нетерминальный символ - если свертка выполнена }

var

symCur: TSymbol; {текущий символ стека}

SymbArr: TSymbArray;

{массив для запоминания символов правила}

i,iSymbN: integer;

{счетчик символов стеке и счетчик символов в правиле}

sRuleStr: string; {строковое представление правила}

{ Функция добавления символа в правило }

procedure AddToRule(const sStr: string;{строка символа}

sym: TSymbol{тек. символ});

begin

{ Устанавливаем ссылку на текущий символ }

symCur := sym;

{ Добавляем очередной символ в массив символов правила }

SymbArr[iSymbN] := Symbols[i];

{ Добавляем его в строковое представление правила

(слева!) }

sRuleStr := sStr + sRuleStr;

{ Удаляем символ из стека }

Delete(i);

{ Увеличиваем счетчик символов в правиле }

Inc(iSymbN);

end;

begin

Result := nil;

{ Сбрасываем счетчик символов в правиле и

обнуляем текущий символ }

iSymbN := 0;

symCur := nil;

{ Строковое представление правила пустое }

sRuleStr := '';

{ Выполняем алгоритм для всех символов,

начиная с вершины стека }

for i:=Count-1 downto 0 do

begin

{ Если это нетерминальный (синтаксический) символ }

if Symbols[i].SymbType = SYMB_SYNT then

{ Добавляем его в правило, текущий символ при этом

не меняется }

AddToRule(Symbols[i].SymbolStr,symCur)

else

{ Если это терминальный символ и

текущий символ пустой }

if symCur = nil then

{ Добавляем его в правило и делаем текущим }

AddToRule(LexTypeInfo(Symbols[i].Lexem.LexType),

Symbols[i])

else

{ Если это терминальный символ и он связан

отношением "=" с текущим символов }

if GramMatrix[Symbols[i].Lexem.LexType,

symCur.Lexem.LexType] = '=' then

{ Добавляем его в правило и делаем текущим }

AddToRule(LexTypeInfo(Symbols[i].Lexem.LexType),

Symbols[i])

else

{ Иначе прерываем цикл, дальше искать не нужно }

Break;

{ Если превышена максимальная длина правила,

цикл прекращаем }

if iSymbN > RULE_LENGTH then Break;

end;

{ Если выбран хотя бы один символ из стека }

if iSymbN <> 0 then

begin

{ Ищем простым перебором правило, у которого строковое

представление совпадает с построенным

строковым представлением }

for i:=1 to RULE_NUM do

if GramRules[i] = sRuleStr then

begin

{ Если правило найдено, создаем новый

нетерминальный символ }

Result := TSymbol.CreateSymb(i,iSymbN,SymbArr);

{ И добавляем его в стека }

Add(Result);

{ Прерываем цикл поика правил }

Break;

end;

{ Если не был создан новый символ (правило не найдено),

надо удалить все исходные символы, это ошибка }

if Result = nil then

for i:=0 to iSymbN-1 do SymbArr[i].Free;

end;

end;

function BuildSyntList(

const listLex: TLexList{входная таблица лексем};

symbStack: TSymbStack{стек для работы алгоритма}

): TSymbol;

{ Функция, выполняющая алгоритм "сдвиг-свертка".

Результат функции:

- нетерминальный символ (корень синтаксического дерева),

если разбор был выполнен успешно;

- терминальный символ, ссылающийся на лексему, где была

обнаружена ошибка, если разбор выполнен с ошибками. }

var

i,iCnt: integer; {счетчик лексем и длина таблицы лексем}

lexStop: TLexem;

{ссылка на дополнительную начальную лексему}

lexTCur: TLexType;{тип текущей лексемы}

cRule: char;{текущее отношение предшествования}

begin

Result := nil;

{ Вычисляем длину входной таблицы лексем }

iCnt := listLex.Count-1;

{ Создаем дополнительную лексему "начало строки" }

lexStop := TLexem.CreateInfo('Начало файла',0,0,0);

try

{ Помещаем начальную лексему в стек }

symbStack.Push(lexStop);

{ Обнуляем счетчик входных лексем }

i := 0;

{ Цикл по всем лексемам от начала

до конца таблицы лексем }

repeat i<=iCnt do

begin

{ Получаем тип лексемы на вершине стека }

lexTCur := symbStack.TopLexem.LexType;

{ Если на вершине стека начальная лексема,

а текущая лексема - конечная,

то алгоритм разбора завершен }

if (lexTCur = LEX_START)

and (listLex[i].LexType = LEX_START) then Break;

{ Смотрим отношение лексемы на вершине стека

и текущей лексемы в строке }

cRule := GramMatrix[lexTCur,listLex[i].LexType];

{ Корректируем отношение. Если корректировка матрицы

предшествования не используется, то функция должна

вернуть то же самое отношение }

cRule := CorrectRule(cRule,lexTCur,

listLex[i].LexType,symbStack);

case cRule of

'<','=': { Надо выполнять сдвиг (перенос) }

begin

{ Помещаем текущую лексему в стек }

symbStack.Push(listLex[i]);

{ Увеличиваем счетчик входных лексем }

Inc(i);

end;

'>': { Надо выполнять свертку }

if symbStack.MakeTopSymb = nil then

{ Если не удалось выполнить свертку }

begin

{ Запоминаем текущую лексему как место ошибки }

Result := TSymbol.CreateLex(listLex[i]);

{ Прерываем алгоритм }

Break;

end;

else

{ Отношение не установлено - ошибочная ситуация }

begin

{ Запоминаем текущую лексему как место ошибки }

Result := TSymbol.CreateLex(listLex[i]);

{ Прерываем алгоритм }

Break;

end;

end{case};

end{repeat};

{ Если алгоритм прошел без ошибок }

if Result = nil then

begin

{ Проверяем, что в стеке осталось только 2 символа }

if symbStack.Count = 2 then

{ Если да, то верхний символ -

результат синтаксического разбора }

Result := symbStack[1]

{ Иначе это ошибка - отмечаем последнюю лексему

как место ошибки }

else Result := TSymbol.CreateLex(listLex[iCnt]);

end;

finally

{ Уничтожаем временную начальную лексему }

lexStop.Free;

end;

end;

end.

9. TrdOpt

unit TrdOpt;

interface

{ Модуль реализующий два алгоритма оптимизации:

- оптимизация путём свёртки объектного кода;

- оптимизация за счёт исключения лишних операций. }

uses Classes, TblElem, LexElem, TrdType, Triads;

type

{ Информационная структура для таблицы идентификаторов,

предназначенная для алгоритма свёртки объектного кода }

TConstInfo = class(TAddVarInfo)

protected

{ Поле для записи значения переменной }

iConst: longint;

{ Конструктор для создания структуры }

constructor Create(iInfo: longint);

public

{ Функции для чтения и записи информации }

function GetInfo(iIdx: integer): longint; override;

procedure SetInfo(iIdx: integer; iInfo: longint);

override;

end;

{ Информационная структура для таблицы идентификаторов,

предназначенная для алгоритма исключения лишних операций }

TDepInfo = class(TAddVarInfo)

protected

{ Поле для записи числа зависимости переменной }

iDep: longint;

{ Конструктор для создания структуры }

constructor Create(iInfo: longint);

public

{ Функции для чтения и записи информации }

function GetInfo(iIdx: integer): longint; override;

procedure SetInfo(iIdx: integer; iInfo: longint);

override;

end;

{ Процедура оптимизации методом свёртки объектного кода }

procedure OptimizeConst(listTriad: TTriadList);

{ Процедура оптимизации методом

исключения лишних операций }

procedure OptimizeSame(listTriad: TTriadList);

implementation

uses SysUtils, FncTree, LexType, TrdCalc;

constructor TConstInfo.Create(iInfo: longint);

{ Конструктор создания информационной структуры

для свёртки объектного кода }

begin

inherited Create;

iConst := iInfo;

end;

procedure TConstInfo.SetInfo(iIdx: integer;

iInfo: longint);

{ Функция записи инфоримации }

begin

iConst := iInfo;

end;

function TConstInfo.GetInfo(iIdx: integer): longint;

{ Функция чтения инфоримации }

begin

Result := iConst;

end;

function TestOperConst(Op: TOperand; listTriad: TTriadList;

var iConst: integer): Boolean;

{ Функция проверки того, что операнд является константой

и получения его значения в переменную iConst }

var pInfo: TConstInfo;

begin

Result := False;

{ Выборка по типу операнда }

case Op.OpType of

OP_CONST:

{ Если оператор - константа, то всё просто... }

begin

iConst := Op.ConstVal;

Result := True;

end;

OP_VAR:

{ Если оператор - переменная }

begin

{ тогда проверяем наличие у нее

информационной структуры }

pInfo := TConstInfo(Op.VarLink.Info);

if pInfo <> nil then

begin

{ и если такая структура есть,

берём ее значение }

iConst := pInfo[0];

Result := True;

end;

end;

OP_LINK:

{ Если оператор - ссылка на триаду }

begin

{ то он является константой,

если триада имеет тип "CONST" }

if listTriad[Op.TriadNum].TrdType = TRD_CONST

then

begin

iConst := listTriad[Op.TriadNum][1].ConstVal;

Result := True;

end;

end;

end{case};

end;

procedure OptimizeConst(listTriad: TTriadList);

{ Процедура оптимизации методом свёртки объектного кода }

var

i,j,iCnt,iOp1,iOp2: integer;

Ops: TOpArray;

Trd: TTriad;

begin

{ Очищаем информационные структуры

таблицы идентификаторов }

ClearTreeInfo;

{ Заполняем операнды для триады типа "CONST" }

Ops[1].OpType := OP_CONST;

Ops[2].OpType := OP_CONST;

Ops[2].ConstVal := 0;

iCnt := listTriad.Count-1;

{ Для всех триад списка выполняем алгоритм }

for i:=0 to iCnt do

begin

Trd := listTriad[i];

if Trd.TrdType in TriadLineSet then

begin

{ Если любой операнд линейной триады ссылается

на триаду типа "CONST",

то берём и запоминаем её значение }

for j:=1 to 2 do

if (Trd[j].OpType = OP_LINK)

and (listTriad[Trd.Links[j]].TrdType = TRD_CONST)

then

begin

Trd.OpTypes[j] := OP_CONST;

Trd.Values[j] :=

listTriad[Trd.Links[j]][1].ConstVal;

end;

end

else

if Trd.TrdType = TRD_IF then

begin

{ Если первый операнд условной триады ссылается

на триаду типа "CONST",

то берём и запоминаем её значение }

if (Trd[1].OpType = OP_LINK)

and (listTriad[Trd.Links[1]].TrdType = TRD_CONST)

then

begin

Trd.OpTypes[1] := OP_CONST;

Trd.Values[1] :=

listTriad[Trd.Links[1]][1].ConstVal;

end;

end

else

if Trd.TrdType = TRD_ASSIGN then

begin

{ Если второй операнд триады присвоения

ссылается на триаду типа "CONST",

то берём и запоминаем её значение }

if (Trd[2].OpType = OP_LINK)

and (listTriad[Trd.Links[2]].TrdType = TRD_CONST)

then

begin

Trd.OpTypes[2] := OP_CONST;

Trd.Values[2] :=

listTriad[Trd.Links[2]][1].ConstVal;

end;

end;

{ Если триада помечена ссылкой, то линейный участок

кода закончен - опять очищаем информационные

структуры таблицы идентификаторов }

if Trd.IsLinked then ClearTreeInfo;

{ Если триада имеет тип "присвоение" }

if Trd.TrdType = TRD_ASSIGN then

begin

{ И если её второй операнд - константа }

if TestOperConst(Trd[2],listTriad,iOp2) then

{ запоминаем его значение в информационной

структуре переменной }

Trd[1].VarLink.Info := TConstInfo.Create(iOp2);

end

else

{ Если триада - одна из линейных операций }

if Trd.TrdType in TriadLineSet then

begin

{ И если оба её операнда - константы }

if TestOperConst(Trd[1],listTriad,iOp1)

and TestOperConst(Trd[2],listTriad,iOp2) then

begin

{ тогда вычисляем значение операции }

Ops[1].ConstVal :=

CalcTriad(Trd.TrdType,iOp1,iOp2);

{ запоминаем его в триаде типа "CONST",

которую записываем в список

вместо прежней триады }

listTriad.Items[i] := TTriad.Create(TRD_CONST,Ops);

{ Если на прежнюю триаду была ссылка,

сохраняем её }

listTriad[i].IsLinked := Trd.IsLinked;

{ Уничтожаем прежнюю триаду }

Trd.Free;

end;

end;

end;

end;

constructor TDepInfo.Create(iInfo: longint);

{ Конструктор создания информационной структуры

для чисел зависимости }

begin

inherited Create;

iDep := iInfo;

end;

procedure TDepInfo.SetInfo(iIdx: integer; iInfo: longint);

{ Функция записи числа зависимости }

begin

iDep := iInfo;

end;

function TDepInfo.GetInfo(iIdx: integer): longint;

{ Функция чтения числа зависимости }

begin

Result := iDep;

end;

function CalcDepOp(listTriad: TTriadList;

Op: TOperand): longint;

{ Функция вычисления числа зависимости

для операнда триады }

begin

Result := 0;

{ Выборка по типу операнда }

case Op.OpType of

OP_VAR:

{ Если это переменная - смотрим ее информационную

структуру, и если такая структура есть,

то берем оттуда число зависимости }

if Op.VarLink.Info <> nil then Result :=

Op.VarLink.Info.Info[0];

OP_LINK:

{ Если это ссылка на триаду,

то берем число зависимости триады }

Result := listTriad[Op.TriadNum].Info;

end{case};

end;

function CalcDep(listTriad: TTriadList;

Trd: TTriad): longint;

{ Функция вычисления числа зависимости триады }

var iDepTmp: longint;

begin

Result := CalcDepOp(listTriad,Trd[1]);

iDepTmp := CalcDepOp(listTriad,Trd[2]);

{ Число зависимости триады есть на единицу большее,

чем максимальное из чисел зависимости её операндов }

if iDepTmp > Result then Result := iDepTmp+1

else Inc(Result);

Trd.Info := Result;

end;

procedure OptimizeSame(listTriad: TTriadList);

{ Процедура оптимизации методом исключения

лишних операций }

var

i,j,iStart,iCnt,iNum: integer;

Ops: TOpArray;

Trd: TTriad;

begin

{ Ставим начало линейного участка равным

началу списка триад }

iStart := 0;

{ Очищаем информационные структуры

таблицы идентификаторов }

ClearTreeInfo;

iCnt := listTriad.Count-1;

{ Заполняем операнды для триады типа "SAME" }

Ops[1].OpType := OP_LINK;

Ops[2].OpType := OP_CONST;

Ops[2].ConstVal := 0;

{ Для всех триад списка выполняем алгоритм }

for i:=0 to iCnt do

begin

Trd := listTriad[i];

{ Если триада помечена ссылкой, то линейный участок

кода закончен - опять очищаем информационные

структуры таблицы идентификаторов,

и запоминаем начало нового линейного участка }

if Trd.IsLinked then

begin

ClearTreeInfo;

iStart := i;

end;

{ Если любой операнд триады ссылается на триаду

типа "SAME", то переставляем ссылку на предыдущую,

совпадающую с ней триаду }

for j:=1 to 2 do

if Trd[j].OpType = OP_LINK then

begin

iNum := Trd[j].TriadNum;

if listTriad[iNum].TrdType = TRD_SAME then

Trd.Links[j] := listTriad[iNum].Links[1];

end;

{ Если триада типа "присвоение",

то запоминаем число зависимости переменной }

if Trd.TrdType = TRD_ASSIGN then

begin

Trd[1].VarLink.Info := TDepInfo.Create(i+1);

end

else

{ Если триада - одна из линейных операций }

if Trd.TrdType in TriadLineSet then

begin

{ Вычисляем число зависимости триады }

CalcDep(listTriad,Trd);

{ На всем линейном участке ищем совпадающую с ней

триаду с таким же числом зависимости }

for j:=iStart to i-1 do

begin

if Trd.IsEqual(listTriad[j])

and (Trd.Info = listTriad[j].Info) then

begin

{ Если такая триада найдена, запоминаем

ссылку на нее }

Ops[1].TriadNum := j;

{ запоминаем её в триаде типа "SAME", которую

записываем в список вместо прежней триады }

listTriad.Items[i] :=

TTriad.Create(TRD_SAME,Ops);

{ Если на прежнюю триаду была ссылка,

сохраняем её }

listTriad[i].IsLinked := Trd.IsLinked;

{ Уничтожаем прежнюю триаду }

Trd.Free;

{ Прерываем поиск }

Break;

end;

end;

end{if};

end{for};

end;

end.

10. Triads

unit Triads;

interface

{ Модуль, обеспечивающий работу с триадами

и списком триад }

uses Classes, TblElem, LexElem, TrdType;

type

{ Предварительное описание класса триад }

TTriad = class;

{ Типы операндов: константа, переменная,

ссылка на другую триаду }

TOpType = (OP_CONST, OP_VAR, OP_LINK);

{ Структура данных для описания операнда в триадах }

TOperand = record

{ Тип операнда }

case OpType: TOpType of

OP_CONST: (ConstVal: integer);

{ для константы - её значение }

OP_VAR: (VarLink: TVarInfo);

{ для переменной - ссылка на элемент

таблицы идентификаторов }

OP_LINK: (TriadNum: integer);

{ для триады - номер триады }

end;

{ Массив операндов из двух элементов }

TOpArray = array[1..2] of TOperand;

{ Структура данных для описания триады }

TTriad = class(TObject)

private

{ Тип триады }

TriadType: TTriadType;

{ Массив операндов }

Operands: TOpArray;

public

{ Дополнительная информация для оптимизирующих алгоритмов }

Info: longint;

{ Флаг наличия ссылки на эту триаду }

IsLinked: Boolean;

{ Конструктор для создания триады }

constructor Create(Typ: TTriadType; const Ops: TOpArray);

{ Функции для чтения и записи операндов }

function GetOperand(iIdx: integer): TOperand;

procedure SetOperand(iIdx: integer; Op: TOperand);

{ Функции для чтения и записи ссылок на другие триады }

function GetLink(iIdx: integer): integer;

procedure SetLink(iIdx: integer; TrdN: integer);

{ Функции для чтения и записи типа операндов }

function GetOpType(iIdx: integer): TOpType;

procedure SetOpType(iIdx: integer; OpT: TOpType);

{ Функции для чтения и записи значений констант }

function GetConstVal(iIdx: integer): integer;

procedure SetConstVal(iIdx: integer; iVal: integer);

{ Свойства триады, основанные на описанных выше

функциях }

property TrdType: TTriadType read TriadType;

property Opers[iIdx: integer]: TOperand read GetOperand

write SetOperand; default;

property Links[iIdx: integer]: integer read GetLink

write SetLink;

property OpTypes[iIdx: integer]: TOpType read GetOpType

write SetOpType;

property Values[iIdx: integer]: integer read GetConstVal

write SetConstVal;

{ Функция, проверяющая совпадение (эквивалентность)

двух триад }

function IsEqual(Trd1: TTriad): Boolean;

{ Функция, формирующая строковое представление триады }

function MakeString(i: integer): string;

end;

{ Класс для описания списка триад и работы с ним }

TTriadList = class(TList)

public

{ Процедура очистки списка и деструктор

для удаления списка }

procedure Clear; override;

destructor Destroy; override;

{ Процедура вывода списка триад в список строк

для отображения списка триад }

procedure WriteToList(list: TStrings);

{ Процедура удаления триады из списка }

procedure DelTriad(iIdx: integer);

{ Функция получения триады из списка по её номеру }

function GetTriad(iIdx: integer): TTriad;

{ Свойство списка триад для доступа к нему

по номеру триады }

property Triads[iIdx: integer]: TTriad read GetTriad;

default;

end;

{ Процедура удаления из списка триад

всех триад заданного типа }

procedure DelTriadTypes(listTriad: TTriadList;

TrdType: TTriadType);

implementation

uses SysUtils, FncTree, LexType;

constructor TTriad.Create(Typ: TTriadType;

const Ops: TOpArray);

{ Конструктор создания триады }

var i: integer;

begin

{ Вызываем конструктор базового класса }

inherited Create;

{ Запоминаем тип триады }

TriadType := Typ;

{ Запоминаем два операнда триады }

for i:=1 to 2 do Operands[i] := Ops[i];

{ Очищаем поле дополнительной информации

и поле внешней ссылки }

Info := 0;

IsLinked := False;

end;

function TTriad.GetOperand(iIdx: integer): TOperand;

{ Функция получения данных об операнде триады

по его номеру }

begin

Result := Operands[iIdx];

end;

procedure TTriad.SetOperand(iIdx: integer; Op: TOperand);

{ Функция записи данных операнда триады по его номеру }

begin

Operands[iIdx] := Op;

end;

function TTriad.GetLink(iIdx: integer): integer;

{ Функция получения ссылки на другую триаду из операнда

по его номеру }

begin

Result := Operands[iIdx].TriadNum;

end;

procedure TTriad.SetLink(iIdx: integer; TrdN: integer);

{ Функция записи номера ссылки на другую триаду

в операнд по его номеру }

begin

Operands[iIdx].TriadNum := TrdN;

end;

function TTriad.GetOpType(iIdx: integer): TOpType;

{ Функция получения типа операнда по его номеру }

begin

Result := Operands[iIdx].OpType;

end;

function TTriad.GetConstVal(iIdx: integer): integer;

{ Функция записи типа операнда по его номеру }

begin

Result := Operands[iIdx].ConstVal;

end;

procedure TTriad.SetConstVal(iIdx: integer; iVal: integer);