1737 lines
44 KiB
Plaintext
1737 lines
44 KiB
Plaintext
unit v_ideCodeParser;
|
|
|
|
{$include ValistusDefines.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Classes,
|
|
CastaliaPasLex, CastaliaSimplePasPar,
|
|
v_MiscFunctions;
|
|
|
|
type
|
|
TDeclaration = class;
|
|
TDeclarationArray = array of TDeclaration;
|
|
TDeclarationClass = class of TDeclaration;
|
|
|
|
TVarBase = (vbName, vbType);
|
|
|
|
TDeclarationStack = class
|
|
private
|
|
fItems: TList;
|
|
fTop: TDeclaration;
|
|
public
|
|
procedure Push(Item: TDeclaration);
|
|
function Pop: TDeclaration;
|
|
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
property Top: TDeclaration read fTop;
|
|
end;
|
|
|
|
TDeclarationList = class
|
|
private
|
|
fItems: TList;
|
|
|
|
function GetItem(Index: Integer): TDeclaration;
|
|
function GetCount: Integer;
|
|
public
|
|
procedure AddItem(AItem: TDeclaration);
|
|
procedure DeleteItem(AItem: TDeclaration);
|
|
function GetItemsOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclarationArray;
|
|
function GetFirstItemOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclaration;
|
|
function GetItemsInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclarationArray;
|
|
function GetItemInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclaration;
|
|
|
|
procedure Clear;
|
|
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
property Items[Index: Integer]: TDeclaration read GetItem; default;
|
|
property Count: Integer read GetCount;
|
|
end;
|
|
|
|
TDeclaration = class
|
|
private
|
|
fParser: TmwSimplePasPar;
|
|
fOwner: TDeclaration;
|
|
fOrigin: PAnsiChar;
|
|
fRawText: string;
|
|
fCleanText: string;
|
|
fShortText: string;
|
|
fStartPos: Integer;
|
|
fEndPos: Integer;
|
|
fItems: TDeclarationList;
|
|
|
|
function GetRawText: string; virtual;
|
|
function GetCleanText: string; virtual;
|
|
function GetShortText: string; virtual;
|
|
public
|
|
function HasOwnerClass(AClass: TDeclarationClass; out Declaration: TDeclaration; Recursive: Boolean = False): Boolean;
|
|
function GetOwnersOfClass(AClass: TDeclarationClass): TDeclarationArray;
|
|
|
|
constructor Create(AParser: TmwSimplePasPar; AOwner: TDeclaration; AOrigin: PAnsiChar; AStart: Integer; AEnd: Integer = -1); overload; virtual;
|
|
constructor Create(AssignFrom: TDeclaration); overload; virtual;
|
|
destructor Destroy; override;
|
|
|
|
property Parser: TmwSimplePasPar read fParser;
|
|
property Owner: TDeclaration read fOwner;
|
|
property Origin: PAnsiChar read fOrigin;
|
|
|
|
property RawText: string read GetRawText write fRawText;
|
|
property CleanText: string read GetCleanText;
|
|
property ShortText: string read GetShortText;
|
|
property StartPos: Integer read fStartPos write fStartPos;
|
|
property EndPos: Integer read fEndPos write fEndPos;
|
|
property Items: TDeclarationList read fItems;
|
|
end;
|
|
|
|
TciStruct = class(TDeclaration)
|
|
private
|
|
function GetShortText: string; override;
|
|
public
|
|
function HasField(Name: string; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean; overload;
|
|
function HasField(Name: string; out Decl: TDeclaration; Return: TVarBase = vbName): Boolean; overload;
|
|
function GetDefault(Return: TVarBase = vbName): TDeclaration;
|
|
end;
|
|
|
|
TciTypeKind = class(TDeclaration)
|
|
private
|
|
function GetShortText: string; override;
|
|
public
|
|
function GetRealType(var ArrayCount: Integer): TDeclaration; overload;
|
|
function GetRealType: TDeclaration; overload;
|
|
end;
|
|
|
|
TciProcedureName = class(TDeclaration);
|
|
|
|
{ TciProcedureDeclaration }
|
|
TciProcedureDeclaration = class(TDeclaration)
|
|
private
|
|
fProcType: string;
|
|
fParams: string;
|
|
fName: TciProcedureName;
|
|
fCleanDecl : string;
|
|
|
|
function GetCleanDeclaration: string;
|
|
function GetName: TciProcedureName;
|
|
function GetProcType: string;
|
|
function GetParams: string;
|
|
|
|
function GetShortText: string; override;
|
|
public
|
|
function GetParamDeclarations: TDeclarationArray;
|
|
|
|
property CleanDeclaration : string read GetCleanDeclaration;
|
|
property Name : TciProcedureName read GetName;
|
|
property ProcType: string read GetProcType;
|
|
property Params: string read GetParams;
|
|
end;
|
|
|
|
TciUsedUnit = class(TDeclaration); //Included Units
|
|
TciInclude = class(TDeclaration); //Includes
|
|
TciJunk = class(TDeclaration); //Junk
|
|
|
|
TciCompoundStatement = class(TDeclaration); //Begin-End
|
|
TciWithStatement = class(TDeclaration); //With
|
|
TciSimpleStatement = class(TDeclaration); //Begin-End + With
|
|
TciVariable = class(TDeclaration); //With
|
|
|
|
//TciTypeKind = class(TciVarType); //Var + Const + Array + Record
|
|
TciTypedConstant = class(TDeclaration); //Var + Procedure/Function Parameters
|
|
TciExpression = class(TDeclaration); //Var + Const + Enum
|
|
TciProceduralType = class(TciProcedureDeclaration); //Var + Tciype + Procedure/Function Parameters
|
|
|
|
TciTypeDeclaration = class(TDeclaration); //Type
|
|
TciTypeName = class(TDeclaration); //Type
|
|
|
|
TciVarDeclaration = class(TDeclaration); //Var
|
|
TciVarName = class(TDeclaration); //Var
|
|
|
|
TciConstantDeclaration = class(TDeclaration); //Const
|
|
TciConstantName = class(TDeclaration); //Const
|
|
|
|
TciLabelDeclaration = class(TDeclaration); //Label
|
|
TciLabelName = class(TDeclaration); //Label
|
|
|
|
//TciProcedureDeclaration = class(TDeclaration); //Procedure/Function
|
|
//TciProcedureName = class(TDeclaration); //Procedure/Function
|
|
TciProcedureClassName = class(TDeclaration); //Class Procedure/Function
|
|
TciReturnType = class(TciTypeKind); //Function Result
|
|
TciForward = class(TciTypeKind); //Forwarding
|
|
TciConstParameter = class(TDeclaration); //Procedure/Function Parameters
|
|
TciOutParameter = class(TDeclaration); //Procedure/Function Parameters
|
|
TciFormalParameter = class(TDeclaration); //Procedure/Function Parameters
|
|
TciInParameter = class(TDeclaration); //Procedure/Function Parameters
|
|
TciVarParameter = class(TDeclaration); //Procedure/Function Parameters
|
|
TciParameterName = class(TDeclaration); //Procedure/Function Parameters
|
|
TciParameterType = class(TciTypeKind); //Procedure/Function Parameters
|
|
|
|
TciArrayType = class(TDeclaration); //Array
|
|
TciArrayConstant = class(TDeclaration); //Array
|
|
|
|
TciRecordType = class(TciStruct); //Record
|
|
TciClassField = class(TDeclaration); //Record
|
|
TciFieldName = class(TDeclaration); //Record
|
|
TciRecordConstant = class(TDeclaration); //Record
|
|
TciRecordFieldConstant = class(TDeclaration); //Record
|
|
|
|
TciClassType = class(TciStruct); //Class
|
|
TciAncestorId = class(TDeclaration); //Class
|
|
TciClassMethodHeading = class(TciProcedureDeclaration); //Record + Class
|
|
TciClassProperty = class(TDeclaration); //Record + Class
|
|
TciPropertyDefault = class(TDeclaration); //Record + Class
|
|
TciIdentifier = class(TDeclaration); //Record + Class
|
|
TciPropertyParameterList = class(TDeclaration); //Record + Class
|
|
|
|
TciSetType = class(TDeclaration); //Set
|
|
TciOrdinalType = class(TDeclaration); //Set
|
|
|
|
TciEnumType = class(TDeclaration); //Enum
|
|
TciQualifiedIdentifier = class(TDeclaration); //Enum
|
|
|
|
TCodeParser = class(TmwSimplePasPar)
|
|
protected
|
|
fStack: TDeclarationStack;
|
|
fItems: TDeclarationList;
|
|
|
|
function InDeclaration(AClass: TDeclarationClass): Boolean;
|
|
function InDeclarations(AClassArray: array of TDeclarationClass): Boolean;
|
|
procedure PushStack(AClass: TDeclarationClass; AStart: Integer = -1);
|
|
procedure PopStack(AEnd: Integer = -1);
|
|
|
|
procedure ParseFile; override;
|
|
procedure OnInclude(Sender: TmwBasePasLex); virtual; //Includes
|
|
procedure UsedUnitName; override; //Included Units
|
|
procedure NextToken; override; //Junk
|
|
procedure OnDirect(Sender: TmwBasePasLex); //Junk
|
|
|
|
procedure CompoundStatement; override; //Begin-End
|
|
procedure WithStatement; override; //With
|
|
procedure SimpleStatement; override; //Begin-End + With
|
|
procedure Variable; override; //With
|
|
|
|
procedure TypeKind; override; //Var + Const + Array + Record
|
|
procedure TypedConstant; override; //Var + Procedure/Function Parameters
|
|
procedure Expression; override; //Var + Const + ArrayConst
|
|
procedure ProceduralType; override; //Var + Tciype + Procedure/Function Parameters
|
|
|
|
procedure TypeDeclaration; override; //Type
|
|
procedure TypeName; override; //Type
|
|
|
|
procedure VarDeclaration; override; //Var
|
|
procedure VarName; override; //Var
|
|
|
|
procedure ConstantDeclaration; override; //Const
|
|
procedure ConstantName; override; //Const
|
|
|
|
procedure LabelDeclarationSection; override; //Label
|
|
procedure LabelId; override; //Label
|
|
|
|
procedure ProcedureDeclarationSection; override; //Procedure/Function
|
|
procedure FunctionProcedureName; override; //Procedure/Function
|
|
procedure ObjectNameOfMethod; override; //Class Procedure/Function
|
|
procedure ReturnType; override; //Function Result
|
|
procedure ForwardDeclaration; override; //Forwarding
|
|
procedure ConstParameter; override; //Procedure/Function Parameters
|
|
procedure OutParameter; override; //Procedure/Function Parameters
|
|
procedure ParameterFormal; override; //Procedure/Function Parameters
|
|
procedure InParameter; override; //Procedure/Function Parameters
|
|
procedure VarParameter; override; //Procedure/Function Parameters
|
|
procedure ParameterName; override; //Procedure/Function Parameters
|
|
procedure NewFormalParameterType; override; //Procedure/Function Parameters
|
|
|
|
procedure ArrayType; override; //Array
|
|
procedure ArrayConstant; override; //Array Const
|
|
|
|
procedure RecordType; override; //Record
|
|
procedure ClassField; override; //Record + Class
|
|
procedure FieldName; override; //Record + Class
|
|
procedure RecordConstant; override; //Record Const
|
|
procedure RecordFieldConstant; override; //Record Const
|
|
|
|
procedure ClassType; override; //Class
|
|
procedure AncestorId; override; //Class
|
|
procedure ClassMethodHeading; override; //Class
|
|
procedure ConstructorName; override; //Class
|
|
procedure DestructorName; override; //Class
|
|
procedure FunctionMethodName; override; //Class
|
|
procedure ProcedureMethodName; override; //Class
|
|
procedure ClassProperty; override; //Record + Class
|
|
procedure PropertyName; override; //Record + Class
|
|
procedure TypeId; override; //Record + Class
|
|
procedure PropertyDefault; override; //Record + Class
|
|
procedure Identifier; override; //Record + Class
|
|
procedure PropertyParameterList; override; //Record + Class
|
|
|
|
procedure SetType; override; //Set
|
|
procedure OrdinalType; override; //Set + Array Range
|
|
|
|
procedure EnumeratedType; override; //Enum
|
|
procedure QualifiedIdentifier; override; //Enum
|
|
public
|
|
constructor Create; virtual;
|
|
destructor Destroy; override;
|
|
|
|
property Items: TDeclarationList read fItems;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
CastaliaPasLexTypes;
|
|
|
|
procedure TDeclarationStack.Push(Item: TDeclaration);
|
|
begin
|
|
fItems.Add(Item);
|
|
fTop := Item;
|
|
end;
|
|
|
|
function TDeclarationStack.Pop: TDeclaration;
|
|
begin
|
|
with fItems do
|
|
begin
|
|
if (Count > 0) then
|
|
Delete(Count - 1);
|
|
if (Count > 0) then
|
|
fTop := TDeclaration(Items[Count - 1])
|
|
else
|
|
fTop := nil;
|
|
end;
|
|
Result := fTop;
|
|
end;
|
|
|
|
constructor TDeclarationStack.Create;
|
|
begin
|
|
fItems := TList.Create;
|
|
fTop := nil;
|
|
end;
|
|
|
|
destructor TDeclarationStack.Destroy;
|
|
begin
|
|
FreeAndNil(fItems);
|
|
|
|
inherited;
|
|
end;
|
|
|
|
function TDeclarationList.GetItem(Index: Integer): TDeclaration;
|
|
begin
|
|
Result := TDeclaration(fItems[Index]);
|
|
end;
|
|
|
|
function TDeclarationList.GetCount: Integer;
|
|
begin
|
|
Result := fItems.Count;
|
|
end;
|
|
|
|
procedure TDeclarationList.AddItem(AItem: TDeclaration);
|
|
begin
|
|
fItems.Add(AItem);
|
|
end;
|
|
|
|
procedure TDeclarationList.DeleteItem(AItem: TDeclaration);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to fItems.Count - 1 do
|
|
if (TDeclaration(fItems[i]) = AItem) then
|
|
begin
|
|
TDeclaration(fItems[i]).Free;
|
|
fItems.Delete(i);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TDeclarationList.GetItemsOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclarationArray;
|
|
|
|
procedure SearchItem(
|
|
AClass: TDeclarationClass;
|
|
SubSearch: Boolean;
|
|
Item: TDeclaration;
|
|
var Res: TDeclarationArray;
|
|
var ResIndex: Integer);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if ((Item = nil) and (AClass = nil)) or (Item is AClass) then
|
|
begin
|
|
SetLength(Res, ResIndex + 1);
|
|
Res[ResIndex] := Item;
|
|
Inc(ResIndex);
|
|
end;
|
|
if SubSearch then
|
|
for i := 0 to Item.Items.Count - 1 do
|
|
SearchItem(AClass, SubSearch, Item.Items[i], Res, ResIndex);
|
|
end;
|
|
|
|
var
|
|
i, l: Integer;
|
|
begin
|
|
l := 0;
|
|
SetLength(Result, 0);
|
|
|
|
for i := 0 to fItems.Count - 1 do
|
|
SearchItem(AClass, SubSearch, TDeclaration(fItems[i]), Result, l);
|
|
end;
|
|
|
|
function TDeclarationList.GetFirstItemOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclaration;
|
|
|
|
function SearchItem(AClass: TDeclarationClass; SubSearch: Boolean; Item: TDeclaration; out Res: TDeclaration): Boolean;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
if ((Item = nil) and (AClass = nil)) or (Item is AClass) then
|
|
begin
|
|
Res := Item;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
if SubSearch then
|
|
for i := 0 to Item.Items.Count - 1 do
|
|
if SearchItem(AClass, SubSearch, Item.Items[i], Res) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
for i := 0 to fItems.Count - 1 do
|
|
SearchItem(AClass, SubSearch, TDeclaration(fItems[i]), Result);
|
|
end;
|
|
|
|
function TDeclarationList.GetItemsInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclarationArray;
|
|
|
|
procedure SearchItem(
|
|
AStart, AEnd: Integer;
|
|
SubSearch: Boolean;
|
|
Item: TDeclaration;
|
|
var Res: TDeclarationArray;
|
|
var ResIndex: Integer);
|
|
var
|
|
i: Integer;
|
|
b: Boolean;
|
|
begin
|
|
b := False;
|
|
if (AStart >= Item.StartPos) and (AEnd <= Item.EndPos) then
|
|
begin
|
|
SetLength(Res, ResIndex + 1);
|
|
Res[ResIndex] := Item;
|
|
Inc(ResIndex);
|
|
b := True;
|
|
end;
|
|
if SubSearch and b then
|
|
for i := 0 to Item.Items.Count - 1 do
|
|
SearchItem(AStart, AEnd, SubSearch, Item.Items[i], Res, ResIndex);
|
|
end;
|
|
|
|
var
|
|
i, l: Integer;
|
|
begin
|
|
l := 0;
|
|
SetLength(Result, 0);
|
|
|
|
for i := 0 to fItems.Count - 1 do
|
|
SearchItem(AStart, AEnd, SubSearch, TDeclaration(fItems[i]), Result, l);
|
|
end;
|
|
|
|
function TDeclarationList.GetItemInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclaration;
|
|
|
|
function SearchItem(AStart, AEnd: Integer; SubSearch: Boolean; Item: TDeclaration; out Res: TDeclaration): Boolean;
|
|
var
|
|
i: Integer;
|
|
b: Boolean;
|
|
begin
|
|
Result := False;
|
|
b := (AStart >= Item.StartPos) and (AEnd <= Item.EndPos);
|
|
if b and ((Item.Items.Count < 1) or (not SubSearch)) then
|
|
begin
|
|
Res := Item;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
if SubSearch and b then
|
|
for i := 0 to Item.Items.Count - 1 do
|
|
if SearchItem(AStart, AEnd, SubSearch, Item.Items[i], Res) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
if b and (not Result) then
|
|
begin
|
|
Res := Item;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
for i := 0 to fItems.Count - 1 do
|
|
SearchItem(AStart, AEnd, SubSearch, TDeclaration(fItems[i]), Result);
|
|
end;
|
|
|
|
procedure TDeclarationList.Clear;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to fItems.Count - 1 do
|
|
if (Assigned(fItems[i])) then
|
|
TDeclaration(fItems[i]).Free;
|
|
fItems.Clear;
|
|
end;
|
|
|
|
constructor TDeclarationList.Create;
|
|
begin
|
|
fItems := TList.Create;
|
|
end;
|
|
|
|
destructor TDeclarationList.Destroy;
|
|
begin
|
|
Clear;
|
|
|
|
FreeAndNil(fItems);
|
|
inherited;
|
|
end;
|
|
|
|
function TDeclaration.GetRawText: string;
|
|
begin
|
|
Result := '';
|
|
if (fRawText <> '') then
|
|
Result := fRawText
|
|
else if (fStartPos <> fEndPos) and (fOrigin <> nil) then
|
|
begin
|
|
SetString(fRawText, fOrigin + fStartPos, fEndPos - fStartPos);
|
|
Result := fRawText;
|
|
end;
|
|
end;
|
|
|
|
function TDeclaration.GetCleanText: string;
|
|
var
|
|
i: Integer;
|
|
a: TDeclarationArray;
|
|
begin
|
|
Result := '';
|
|
if (fCleanText <> '') then
|
|
Result := fCleanText
|
|
else if (fStartPos <> fEndPos) and (fOrigin <> nil) then
|
|
begin
|
|
fCleanText := RawText;
|
|
a := Items.GetItemsOfClass(TciJunk, True);
|
|
for i := High(a) downto 0 do
|
|
begin
|
|
Delete(fCleanText, a[i].StartPos - fStartPos + 1, a[i].EndPos - a[i].StartPos);
|
|
if (Pos(LineEnding, a[i].GetRawText) > 0) then
|
|
Insert(LineEnding, fCleanText, a[i].StartPos - fStartPos + 1)
|
|
else
|
|
Insert(' ', fCleanText, a[i].StartPos - fStartPos + 1);
|
|
end;
|
|
Result := fCleanText;
|
|
end;
|
|
end;
|
|
|
|
function TDeclaration.GetShortText: string;
|
|
begin
|
|
if (fShortText = '') then
|
|
fShortText := CompressWhiteSpace(CleanText);
|
|
Result := fShortText;
|
|
end;
|
|
|
|
function TDeclaration.HasOwnerClass(AClass: TDeclarationClass; out Declaration: TDeclaration; Recursive: Boolean = False): Boolean;
|
|
|
|
function IsOwner(Item: TDeclaration; AClass: TDeclarationClass; out Decl: TDeclaration; Recursive: Boolean): Boolean;
|
|
begin
|
|
if ((AClass = nil) and (Item.Owner = nil)) or (Item.Owner is AClass) then
|
|
begin
|
|
Result := True;
|
|
Decl := Item.Owner;
|
|
end
|
|
else if (Item.Owner <> nil) and Recursive then
|
|
Result := IsOwner(Item.Owner, AClass, Decl, True)
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
begin
|
|
Declaration := nil;
|
|
if (AClass = nil) then
|
|
Result := True
|
|
else
|
|
Result := IsOwner(Self, Aclass, Declaration, Recursive);
|
|
end;
|
|
|
|
function TDeclaration.GetOwnersOfClass(AClass: TDeclarationClass): TDeclarationArray;
|
|
|
|
procedure IsOwner(
|
|
AClass: TDeclarationClass;
|
|
Item: TDeclaration;
|
|
var Res: TDeclarationArray;
|
|
var ResIndex: Integer);
|
|
begin
|
|
if ((AClass = nil) and (Item.Owner = nil)) or (Item.Owner is AClass) then
|
|
begin
|
|
SetLength(Res, ResIndex + 1);
|
|
Res[ResIndex] := Item.Owner;
|
|
Inc(ResIndex);
|
|
end;
|
|
if (Item.Owner <> nil) then
|
|
IsOwner(AClass, Item.Owner, Res, ResIndex);
|
|
end;
|
|
|
|
var
|
|
l: Integer;
|
|
begin
|
|
l := 0;
|
|
SetLength(Result, 0);
|
|
|
|
IsOwner(AClass, Self, Result, l);
|
|
end;
|
|
|
|
constructor TDeclaration.Create(AParser: TmwSimplePasPar; AOwner: TDeclaration; AOrigin: PAnsiChar; AStart, AEnd: Integer);
|
|
begin
|
|
inherited Create;
|
|
|
|
fParser := AParser;
|
|
fOwner := AOwner;
|
|
fOrigin := AOrigin;
|
|
fRawText := '';
|
|
fCleanText := '';
|
|
fStartPos := AStart;
|
|
if (AEnd > -1) then
|
|
fEndPos := AEnd
|
|
else
|
|
fEndPos := AStart;
|
|
|
|
fItems := TDeclarationList.Create;
|
|
end;
|
|
|
|
constructor TDeclaration.Create(AssignFrom: TDeclaration);
|
|
begin
|
|
if (AssignFrom <> nil) then
|
|
Create(AssignFrom.Parser, AssignFrom.Owner, AssignFrom.Origin, AssignFrom.StartPos, AssignFrom.EndPos)
|
|
else
|
|
Create(nil, nil, nil, -1);
|
|
end;
|
|
|
|
destructor TDeclaration.Destroy;
|
|
begin
|
|
FreeAndNil(fItems);
|
|
|
|
inherited;
|
|
end;
|
|
|
|
function TciStruct.GetShortText: string;
|
|
begin
|
|
if (fShortText = '') then
|
|
fShortText := GetFirstWord(CleanText);
|
|
Result := fShortText;
|
|
end;
|
|
|
|
function TciStruct.HasField(Name: string; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean;
|
|
var
|
|
a, b: TDeclarationArray;
|
|
i, ii: Integer;
|
|
t: TDeclaration;
|
|
begin
|
|
Result := False;
|
|
Name := PrepareString(Name);
|
|
|
|
a := fItems.GetItemsOfClass(TciClassField);
|
|
for i := Low(a) to High(a) do
|
|
begin
|
|
b := a[i].Items.GetItemsOfClass(TciFieldName);
|
|
for ii := Low(b) to High(b) do
|
|
begin
|
|
if (PrepareString(b[ii].CleanText) = Name) then
|
|
begin
|
|
Result := True;
|
|
if (Return = vbType) then
|
|
Decl := b[ii].Owner.Items.GetFirstItemOfClass(TciTypeKind)
|
|
else
|
|
Decl := b[ii];
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
a := fItems.GetItemsOfClass(TciClassProperty);
|
|
for i := Low(a) to High(a) do
|
|
begin
|
|
b := a[i].Items.GetItemsOfClass(TciFieldName);
|
|
for ii := Low(b) to High(b) do
|
|
begin
|
|
if (PrepareString(b[ii].CleanText) = Name) then
|
|
begin
|
|
Result := True;
|
|
|
|
t := a[i].Items.GetFirstItemOfClass(TciPropertyParameterList);
|
|
if (t <> nil) then
|
|
//ArrayCount := ArrayCount + t.Items.Count; [a, b] Indices count as 1
|
|
Inc(ArrayCount);
|
|
|
|
if (Return = vbType) then
|
|
Decl := b[ii].Owner.Items.GetFirstItemOfClass(TciTypeKind)
|
|
else
|
|
Decl := b[ii];
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
a := fItems.GetItemsOfClass(TciClassMethodHeading);
|
|
for i := Low(a) to High(a) do
|
|
begin
|
|
b := a[i].Items.GetItemsOfClass(TciProcedureName);
|
|
for ii := Low(b) to High(b) do
|
|
if (PrepareString(b[ii].CleanText) = Name) then
|
|
begin
|
|
Result := True;
|
|
if (Return = vbType) then
|
|
//Decl := b[ii].Owner
|
|
if (a[ii] is TciProcedureDeclaration) and (LowerCase(TciProcedureDeclaration(a[i]).ProcType) = 'constructor') then
|
|
Decl := Self
|
|
else
|
|
Decl := b[ii].Owner.Items.GetFirstItemOfClass(TciTypeKind)
|
|
else
|
|
Decl := b[ii];
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TciStruct.HasField(Name: string; out Decl: TDeclaration; Return: TVarBase = vbName): Boolean;
|
|
var
|
|
a: Integer;
|
|
begin
|
|
Result := HasField(Name, Decl, Return, a);
|
|
end;
|
|
|
|
function TciStruct.GetDefault(Return: TVarBase = vbName): TDeclaration;
|
|
var
|
|
d: TDeclaration;
|
|
begin
|
|
Result := nil;
|
|
d := fItems.GetFirstItemOfClass(TciPropertyDefault, True);
|
|
if (d <> nil) then
|
|
if (Return = vbType) then
|
|
Result := d.Owner.Items.GetFirstItemOfClass(TciTypeKind)
|
|
else
|
|
Result := d.Owner.Items.GetFirstItemOfClass(TciFieldName)
|
|
end;
|
|
|
|
function TciTypeKind.GetShortText: string;
|
|
var
|
|
d: TDeclaration;
|
|
begin
|
|
if (fShortText = '') then
|
|
begin
|
|
d := GetRealType;
|
|
if (d = nil) or (not (d is TciStruct)) then
|
|
fShortText := CompressWhiteSpace(CleanText)
|
|
else
|
|
fShortText := CompressWhiteSpace(StringReplace(CleanText, d.CleanText, GetFirstWord(d.CleanText), []));
|
|
end;
|
|
Result := fShortText;
|
|
end;
|
|
|
|
function TciTypeKind.GetRealType(var ArrayCount: Integer): TDeclaration;
|
|
var
|
|
d, t: TDeclaration;
|
|
begin
|
|
d := Self;
|
|
while (d <> nil) do
|
|
begin
|
|
if (d.Items.Count > 0) then
|
|
begin
|
|
d := d.Items[0];
|
|
if (d is TciArrayType) then
|
|
begin
|
|
d := d.Items.GetFirstItemOfClass(TciTypeKind);
|
|
Inc(ArrayCount);
|
|
Continue;
|
|
end;
|
|
|
|
if (d is TciProceduralType) then
|
|
begin
|
|
t := d.Items.GetFirstItemOfClass(TciReturnType);
|
|
if (t <> nil) then
|
|
begin
|
|
d := t;
|
|
Continue;
|
|
end
|
|
else
|
|
Break;
|
|
end;
|
|
|
|
if (d is TciTypeKind) then
|
|
Continue;
|
|
end;
|
|
|
|
Break;
|
|
end;
|
|
|
|
Result := d;
|
|
end;
|
|
|
|
function TciTypeKind.GetRealType: TDeclaration;
|
|
var
|
|
a: Integer;
|
|
begin
|
|
Result := GetRealType(a);
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetProcType: string;
|
|
var
|
|
s: string;
|
|
begin
|
|
if (fProcType = '') then
|
|
begin
|
|
s := CleanText;
|
|
fProcType := GetFirstWord(s);
|
|
if (LowerCase(fProcType) = 'class') then
|
|
begin
|
|
Delete(s, 1, 6);
|
|
fProcType := 'class ' + GetFirstWord(s);
|
|
end;
|
|
|
|
if (fProcType = '') then
|
|
if (Items.GetFirstItemOfClass(TciReturnType) <> nil) then
|
|
fProcType := 'function'
|
|
else
|
|
fProcType := 'procedure';
|
|
end;
|
|
|
|
Result := fProcType;
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetName: TciProcedureName;
|
|
var
|
|
d: TDeclaration;
|
|
begin
|
|
if (fName <> nil) then
|
|
Result := fName
|
|
else
|
|
begin
|
|
fName := TciProcedureName(fItems.GetFirstItemOfClass(TciProcedureName));
|
|
if (fName = nil) and (HasOwnerClass(TciClassField, d, True)) then
|
|
fName := TciProcedureName(d.Items.GetFirstItemOfClass(TciFieldName));
|
|
if (fName = nil) and (HasOwnerClass(TciVarDeclaration, d, True)) then
|
|
fName := TciProcedureName(d.Items.GetFirstItemOfClass(TciVarName));
|
|
if (fName = nil) and (HasOwnerClass(TciTypeDeclaration, d, True)) then
|
|
fName := TciProcedureName(d.Items.GetFirstItemOfClass(TciTypeName));
|
|
Result := fName;
|
|
end;
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetCleanDeclaration: string;
|
|
var
|
|
Return : TciReturnType;
|
|
begin
|
|
if (fCleanDecl <> '') then
|
|
result := fCleanDecl
|
|
else
|
|
begin
|
|
result := proctype;
|
|
if (Name <> nil) then
|
|
result := result + ' ' + Name.ShortText;
|
|
if (Params <> '') then
|
|
result := result + '(' + params + ')';
|
|
Return := fItems.GetFirstItemOfClass(TciReturnType) as TciReturnType;
|
|
if (Return <> nil) then
|
|
result := result + ': ' + Return.ShortText
|
|
else
|
|
result := result + ';';
|
|
end;
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetParams: string;
|
|
var
|
|
i: Integer;
|
|
a: TDeclarationArray;
|
|
begin
|
|
Result := '';
|
|
if (fParams <> '') then
|
|
Result := fParams
|
|
else if (fItems.Count > 0) then
|
|
begin
|
|
a := GetParamDeclarations;
|
|
for i := Low(a) to High(a) do
|
|
if (fParams <> '') then
|
|
fParams := fParams + '; ' + a[i].ShortText
|
|
else
|
|
fParams := fParams + a[i].ShortText;
|
|
Result := fParams;
|
|
end;
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetShortText: string;
|
|
begin
|
|
if (fShortText = '') then
|
|
fShortText := ProcType;
|
|
Result := fShortText;
|
|
end;
|
|
|
|
function TciProcedureDeclaration.GetParamDeclarations: TDeclarationArray;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
SetLength(Result, 0);
|
|
|
|
for i := 0 to fItems.Count - 1 do
|
|
if (fItems[i] is TciConstParameter) or
|
|
(fItems[i] is TciOutParameter) or
|
|
(fItems[i] is TciFormalParameter) or
|
|
(fItems[i] is TciInParameter) or
|
|
(fItems[i] is TciVarParameter) then
|
|
begin
|
|
SetLength(Result, Length(Result) + 1);
|
|
Result[High(Result)] := fItems[i];
|
|
end;
|
|
end;
|
|
|
|
function TCodeParser.InDeclaration(AClass: TDeclarationClass): Boolean;
|
|
begin
|
|
if (fStack.Top = nil) then
|
|
Result := (AClass = nil)
|
|
else
|
|
Result := (fStack.Top is AClass);
|
|
end;
|
|
|
|
function TCodeParser.InDeclarations(AClassArray: array of TDeclarationClass): Boolean;
|
|
var
|
|
i: Integer;
|
|
t: TDeclaration;
|
|
begin
|
|
Result := False;
|
|
t := fStack.Top;
|
|
if (t = nil) then
|
|
begin
|
|
for i := Low(AClassArray) to High(AClassArray) do
|
|
if (AClassArray[i] = nil) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
Exit;
|
|
end;
|
|
for i := Low(AClassArray) to High(AClassArray) do
|
|
if (t is AClassArray[i]) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodeParser.PushStack(AClass: TDeclarationClass; AStart: Integer = -1);
|
|
var
|
|
t: TDeclaration;
|
|
begin
|
|
if (AStart = -1) then
|
|
AStart := Lexer.TokenPos;
|
|
t := AClass.Create(Self, fStack.Top, Lexer.Origin, AStart);
|
|
if (fStack.Top <> nil) then
|
|
fStack.Top.Items.AddItem(t)
|
|
else
|
|
fItems.AddItem(t);
|
|
fStack.Push(t);
|
|
end;
|
|
|
|
procedure TCodeParser.PopStack(AEnd: Integer = -1);
|
|
begin
|
|
if (AEnd = -1) then
|
|
AEnd := Lexer.TokenPos;
|
|
if (fStack.Top <> nil) then
|
|
fStack.Top.EndPos := AEnd;
|
|
fStack.Pop;
|
|
end;
|
|
|
|
constructor TCodeParser.Create;
|
|
begin
|
|
inherited;
|
|
|
|
fStack := TDeclarationStack.Create;
|
|
fItems := TDeclarationList.Create;
|
|
|
|
Lexer.OnIncludeDirect := {$IFDEF FPC}@{$ENDIF}OnInclude;
|
|
Lexer.OnDefineDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnElseDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnEndIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnIfDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnIfNDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnUnDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnIfEndDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
Lexer.OnElseIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect;
|
|
end;
|
|
|
|
destructor TCodeParser.Destroy;
|
|
begin
|
|
FreeAndNil(fStack);
|
|
FreeAndNil(fItems);
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCodeParser.ParseFile;
|
|
begin
|
|
SkipJunk;
|
|
case GenID of
|
|
TokLibrary:
|
|
begin
|
|
LibraryFile;
|
|
end;
|
|
TokPackage:
|
|
begin
|
|
PackageFile;
|
|
end;
|
|
TokUnit:
|
|
begin
|
|
UnitFile;
|
|
end;
|
|
else
|
|
begin
|
|
if (Lexer.GenID = TokProgram) then
|
|
begin
|
|
Expected(TokProgram);
|
|
QualifiedIdentifier;
|
|
if TokenID = TokRoundOpen then
|
|
begin
|
|
NextToken;
|
|
IdentifierList;
|
|
Expected(TokRoundClose);
|
|
end;
|
|
SEMICOLON;
|
|
end;
|
|
if (TokenID = TokUses) then
|
|
MainUsesClause;
|
|
|
|
while TokenID in [TokClass, TokConst, TokConstructor, TokDestructor, TokExports,
|
|
TokFunction, TokLabel, TokProcedure, TokResourceString, TokThreadVar, TokType,
|
|
TokVar{$IFDEF D8_NEWER}, TokSquareOpen{$ENDIF}] do
|
|
begin
|
|
DeclarationSection;
|
|
end;
|
|
|
|
if (TokenID = TokBegin) then
|
|
begin
|
|
CompoundStatement;
|
|
Expected(TokPoint);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodeParser.OnInclude(Sender: TmwBasePasLex);
|
|
begin
|
|
if (not Sender.IsJunk) then
|
|
begin
|
|
PushStack(TciInclude, Sender.TokenPos);
|
|
fStack.Top.RawText := Sender.DirectiveParamOriginal;
|
|
PopStack(Sender.TokenPos + Sender.TokenLen);
|
|
end;
|
|
|
|
Sender.Next;
|
|
end;
|
|
|
|
procedure TCodeParser.UsedUnitName;
|
|
begin
|
|
PushStack(TciUsedUnit);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.NextToken;
|
|
var
|
|
ValidJunk: Boolean;
|
|
begin
|
|
ValidJunk := False;
|
|
Lexer.Next;
|
|
if Lexer.IsJunk and (not InDeclaration(TciJunk)) then
|
|
begin
|
|
{if (not InDeclaration(nil)) then
|
|
PushStack(TciJunk);
|
|
while (Lexer.IsJunk) do
|
|
begin
|
|
if (not (Lexer.TokenID in [TokCRLF, TokCRLFCo, TokSpace])) then
|
|
ValidJunk := True;
|
|
Lexer.Next;
|
|
end;
|
|
if InDeclaration(TciJunk) then
|
|
begin
|
|
if ValidJunk then
|
|
PopStack
|
|
else
|
|
begin
|
|
if (fStack.Top.Owner <> nil) then
|
|
fStack.Top.Owner.Items.DeleteItem(fStack.Top)
|
|
else
|
|
fStack.Top.Free;
|
|
fStack.Pop;
|
|
end;
|
|
end;}
|
|
|
|
//while Lexer.IsJunk do
|
|
//begin
|
|
repeat
|
|
if (Lexer.TokenID in [tokAnsiComment, tokBorComment, tokSlashesComment]) then
|
|
begin
|
|
if (not InDeclaration(TciJunk)) then
|
|
PushStack(TciJunk);
|
|
end
|
|
else if InDeclaration(TciJunk) then
|
|
PopStack;
|
|
Lexer.Next;
|
|
until (not Lexer.IsJunk);
|
|
//end;
|
|
if InDeclaration(TciJunk) then
|
|
PopStack;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodeParser.OnDirect(Sender: TmwBasePasLex);
|
|
begin
|
|
if (Sender.TokenID = TokElseDirect) then
|
|
begin
|
|
Sender.Next;
|
|
Exit;
|
|
end;
|
|
if InDeclaration(TciJunk) then
|
|
Exit;
|
|
if (not InDeclaration(nil)) then
|
|
PushStack(TciJunk, Sender.TokenPos);
|
|
|
|
if (not (Sender.TokenID in [TokEndIfDirect, TokIfEndDirect])) then
|
|
if Sender = Lexer then
|
|
NextToken
|
|
else
|
|
Sender.Next;
|
|
|
|
if InDeclaration(TciJunk) then
|
|
PopStack(Sender.TokenPos + Sender.TokenLen);
|
|
end;
|
|
|
|
procedure TCodeParser.CompoundStatement;
|
|
begin
|
|
if (not InDeclarations([nil, TciProcedureDeclaration, TciWithStatement])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciCompoundStatement);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.WithStatement;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciCompoundStatement])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciWithStatement);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.SimpleStatement;
|
|
begin
|
|
if (not InDeclaration(TciWithStatement)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciSimpleStatement);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.Variable;
|
|
begin
|
|
if (not InDeclaration(TciWithStatement)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciVariable);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.TypeKind;
|
|
var
|
|
n: Boolean;
|
|
begin
|
|
if (not InDeclarations([TciVarDeclaration, TciConstantDeclaration, TciTypeDeclaration, TciArrayType, TciClassField])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
n := (InDeclaration(TciArrayType)) and (TokenID = tokConst);
|
|
PushStack(TciTypeKind);
|
|
if n then
|
|
NextToken
|
|
else
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.TypedConstant;
|
|
begin
|
|
if (not InDeclarations([TciVarDeclaration, TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciTypedConstant);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.Expression;
|
|
begin
|
|
if (not InDeclarations([TciVarDeclaration, TciConstantDeclaration, TciOrdinalType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciExpression);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ProceduralType;
|
|
begin
|
|
if (not InDeclaration(TciTypeKind)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProceduralType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.TypeDeclaration;
|
|
begin
|
|
PushStack(TciTypeDeclaration);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.TypeName;
|
|
begin
|
|
if (not InDeclaration(TciTypeDeclaration)) then
|
|
Exit;
|
|
PushStack(TciTypeName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.VarDeclaration;
|
|
begin
|
|
PushStack(TciVarDeclaration);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.VarName;
|
|
begin
|
|
if (not InDeclaration(TciVarDeclaration)) then
|
|
Exit;
|
|
PushStack(TciVarName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ConstantDeclaration;
|
|
begin
|
|
PushStack(TciConstantDeclaration);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ConstantName;
|
|
begin
|
|
if (not InDeclaration(TciConstantDeclaration)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciConstantName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.LabelDeclarationSection;
|
|
begin
|
|
PushStack(TciLabelDeclaration);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.LabelId;
|
|
begin
|
|
if (not InDeclaration(TciLabelDeclaration)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciLabelName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ProcedureDeclarationSection;
|
|
begin
|
|
PushStack(TciProcedureDeclaration);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.FunctionProcedureName;
|
|
begin
|
|
if (not InDeclaration(TciProcedureDeclaration)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ObjectNameOfMethod;
|
|
begin
|
|
if (not InDeclaration(TciProcedureDeclaration)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureClassName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ReturnType;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciReturnType);
|
|
//inherited;
|
|
TypeKind;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ForwardDeclaration;
|
|
begin
|
|
if (not InDeclaration(TciProcedureDeclaration)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciForward);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ConstParameter;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciConstParameter);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.OutParameter;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciOutParameter);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ParameterFormal;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciFormalParameter);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.InParameter;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciInParameter);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.VarParameter;
|
|
begin
|
|
if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciVarParameter);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ParameterName;
|
|
begin
|
|
if (not InDeclarations([TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciParameterName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.NewFormalParameterType;
|
|
begin
|
|
if (not InDeclarations([TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciParameterType);
|
|
//inherited;
|
|
TypeKind;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ArrayType;
|
|
begin
|
|
PushStack(TciArrayType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ArrayConstant;
|
|
begin
|
|
if (not InDeclaration(TciTypedConstant)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciArrayConstant);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.RecordType;
|
|
begin
|
|
PushStack(TciRecordType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ClassField;
|
|
begin
|
|
if (not InDeclarations([TciRecordType, TciClassType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciClassField);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.FieldName;
|
|
begin
|
|
if (not InDeclaration(TciClassField)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciFieldName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.RecordConstant;
|
|
begin
|
|
if (not InDeclarations([TciTypedConstant, TciArrayConstant])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciRecordConstant);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.RecordFieldConstant;
|
|
begin
|
|
if (not InDeclaration(TciRecordConstant)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciRecordFieldConstant);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ClassType;
|
|
begin
|
|
PushStack(TciClassType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.AncestorId;
|
|
begin
|
|
if (not InDeclaration(TciClassType)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciAncestorID);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ClassMethodHeading;
|
|
begin
|
|
if (not InDeclarations([TciRecordType, TciClassType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciClassMethodHeading);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ConstructorName;
|
|
begin
|
|
if (not InDeclaration(TciClassMethodHeading)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.DestructorName;
|
|
begin
|
|
if (not InDeclaration(TciClassMethodHeading)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.FunctionMethodName;
|
|
begin
|
|
if (not InDeclaration(TciClassMethodHeading)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ProcedureMethodName;
|
|
begin
|
|
if (not InDeclaration(TciClassMethodHeading)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciProcedureName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.ClassProperty;
|
|
begin
|
|
if (not InDeclarations([TciRecordType, TciClassType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciClassProperty);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.PropertyName;
|
|
begin
|
|
if (not InDeclaration(TciClassProperty)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciFieldName);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.TypeId;
|
|
begin
|
|
if (not InDeclarations([TciClassProperty, TciPropertyParameterList])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciTypeKind);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.PropertyDefault;
|
|
begin
|
|
if (not InDeclaration(TciClassProperty)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciPropertyDefault);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.Identifier;
|
|
begin
|
|
if (not InDeclaration(TciPropertyParameterList)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciIdentifier);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.PropertyParameterList;
|
|
begin
|
|
if (not InDeclaration(TciClassProperty)) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciPropertyParameterList);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.SetType;
|
|
begin
|
|
PushStack(TciSetType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.OrdinalType;
|
|
begin
|
|
if (not InDeclarations([TciSetType, TciArrayType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciOrdinalType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.EnumeratedType;
|
|
begin
|
|
PushStack(TciEnumType);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
procedure TCodeParser.QualifiedIdentifier;
|
|
begin
|
|
if (not InDeclarations([TciEnumType])) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
PushStack(TciQualifiedIdentifier);
|
|
inherited;
|
|
PopStack;
|
|
end;
|
|
|
|
end.
|