1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-04 22:52:15 -05:00
Simba/Units/Misc/v_ideCodeParser.pas

1737 lines
44 KiB
ObjectPascal
Raw Normal View History

2010-03-26 18:09:12 -04:00
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;
2010-03-26 18:09:12 -04:00
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);
2010-03-28 14:02:57 -04:00
{ TciProcedureDeclaration }
2010-03-26 18:09:12 -04:00
TciProcedureDeclaration = class(TDeclaration)
private
fProcType: string;
fParams: string;
2010-05-24 05:06:39 -04:00
fName: TciProcedureName;
2010-03-28 14:02:57 -04:00
fCleanDecl : string;
2010-03-26 18:09:12 -04:00
2010-03-28 14:02:57 -04:00
function GetCleanDeclaration: string;
function GetName: TciProcedureName;
2010-03-26 18:09:12 -04:00
function GetProcType: string;
function GetParams: string;
function GetShortText: string; override;
public
function GetParamDeclarations: TDeclarationArray;
2010-03-28 14:02:57 -04:00
property CleanDeclaration : string read GetCleanDeclaration;
property Name : TciProcedureName read GetName;
2010-03-26 18:09:12 -04:00
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
2010-03-26 18:09:12 -04:00
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
2010-03-26 18:09:12 -04:00
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
2010-03-26 18:09:12 -04:00
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
2010-05-24 05:06:39 -04:00
if ((Item = nil) and (AClass = nil)) or (Item is AClass) then
2010-03-26 18:09:12 -04:00
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;
2010-05-24 05:06:39 -04:00
if ((Item = nil) and (AClass = nil)) or (Item is AClass) then
2010-03-26 18:09:12 -04:00
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
2010-05-24 05:06:39 -04:00
if ((AClass = nil) and (Item.Owner = nil)) or (Item.Owner is AClass) then
2010-03-26 18:09:12 -04:00
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
2010-05-24 05:06:39 -04:00
if ((AClass = nil) and (Item.Owner = nil)) or (Item.Owner is AClass) then
2010-03-26 18:09:12 -04:00
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
2010-05-24 05:06:39 -04:00
inherited Create;
2010-03-26 18:09:12 -04:00
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;
2010-03-26 18:09:12 -04:00
var
a, b: TDeclarationArray;
i, ii: Integer;
t: TDeclaration;
2010-03-26 18:09:12 -04:00
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);
2010-03-26 18:09:12 -04:00
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)
2010-03-26 18:09:12 -04:00
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;
2010-03-26 18:09:12 -04:00
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);
2010-05-24 05:06:39 -04:00
fProcType := 'class ' + GetFirstWord(s);
2010-03-26 18:09:12 -04:00
end;
2010-03-28 09:51:26 -04:00
if (fProcType = '') then
if (Items.GetFirstItemOfClass(TciReturnType) <> nil) then
fProcType := 'function'
else
fProcType := 'procedure';
2010-03-26 18:09:12 -04:00
end;
Result := fProcType;
end;
function TciProcedureDeclaration.GetName: TciProcedureName;
var
d: TDeclaration;
2010-03-28 14:02:57 -04:00
begin
if (fName <> nil) then
2010-05-24 05:06:39 -04:00
Result := fName
2010-03-28 14:02:57 -04:00
else
begin
2010-05-24 05:06:39 -04:00
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));
2010-05-24 05:06:39 -04:00
Result := fName;
2010-03-28 14:02:57 -04:00
end;
end;
function TciProcedureDeclaration.GetCleanDeclaration: string;
var
Return : TciReturnType;
begin
if (fCleanDecl <> '') then
result := fCleanDecl
else
begin
2010-05-24 05:06:39 -04:00
result := proctype;
if (Name <> nil) then
result := result + ' ' + Name.ShortText;
if (Params <> '') then
2010-03-28 14:02:57 -04:00
result := result + '(' + params + ')';
Return := fItems.GetFirstItemOfClass(TciReturnType) as TciReturnType;
if (Return <> nil) then
result := result + ': ' + Return.ShortText
else
result := result + ';';
end;
end;
2010-03-26 18:09:12 -04:00
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);
2010-03-28 14:02:57 -04:00
fStack.Top.RawText := Sender.DirectiveParamOriginal;
2010-03-26 18:09:12 -04:00
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;}
2010-04-07 11:07:01 -04:00
//while Lexer.IsJunk do
//begin
repeat
2010-03-26 18:09:12 -04:00
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;
2010-04-07 11:07:01 -04:00
until (not Lexer.IsJunk);
//end;
if InDeclaration(TciJunk) then
PopStack;
2010-03-26 18:09:12 -04:00
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
2010-03-26 18:09:12 -04:00
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;
2010-03-26 18:09:12 -04:00
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.