unit unUnitParser;

(**************************************************************************)

(* *)

(* VCL Generator Copyright (c) 1998 *)

(* *)

(* Morgan Martinet *)

(* 23 rue du 14 juillet *)

(* 94270 le Kremlin-Bicetre *)

(* Phone (Work): 01 47 25 70 77 *)

(* e-mail: mmm@imaginet.fr *)

(* *)

(**************************************************************************)

(* This source code is distributed with no WARRANTY, for no reason or use.*)

(* Everyone is allowed to use and change this code free for his own tasks *)

(* and projects, as long as this header and its copyright text is intact. *)

(* For changed versions of this code, which are public distributed the *)

(* following additional conditions have to be fullfilled: *)

(* 1) The header has to contain a comment on the change and the author of *)

(* it. *)

(* 2) A copy of the changed source has to be sent to the above E-Mail *)

(* address or my then valid address, if this is possible to the *)

(* author. *)

(* The second condition has the target to maintain an up to date central *)

(* version of the component. If this condition is not acceptable for *)

(* confidential or legal reasons, everyone is free to derive a component *)

(* or to generate a diff file to my or other original sources. *)

(**************************************************************************)

interface

uses unParser, Classes, SysUtils, ComCtrls;

type

TUnit = class;

TPascalItem = class

protected

FName : String;

FRefUnit : TUnit;

public

procedure AddToTree( tree : TTreeView; node : TTreeNode ); virtual; abstract;

function AsString : String; virtual; abstract;

function GetName : String; virtual;

property Name : String read FName write FName;

property RefUnit : TUnit read FRefUnit write FRefUnit;

end;

TVar = class(TPascalItem)

protected

FVarType : String;

FItems : TStringList;

FValue : String;

public

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property VarType : String read FVarType write FVarType;

property Items : TStringList read FItems;

property Value : String read FValue write FValue;

end;

TConst = class(TPascalItem)

protected

FConstType : String;

FConstValue : String;

public

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property ConstType : String read FConstType write FConstType;

property ConstValue : String read FConstValue write FConstValue;

end;

TType = class(TPascalItem)

public

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TMyClass = class(TType)

protected

FPrivateList : TList;

FProtectedList : TList;

FPublicList : TList;

FPublishedList : TList;

FAutomatedList : TList;

FCurrentSection : TList;

FParentClasses : TStringList;

procedure AddSectionsToTree( tree : TTreeView; node : TTreeNode );

public

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

procedure ParseSections( Parser : TMyParser; AUnit : TUnit );

property PrivateList : TList read FPrivateList;

property ProtectedList : TList read FProtectedList;

property PublicList : TList read FPublicList;

property PublishedList : TList read FPublishedList;

property AutomatedList : TList read FAutomatedList;

property CurrentSection : TList read FCurrentSection write FCurrentSection;

property ParentClasses : TStringList read FParentClasses;

end;

TClassRef = class(TType)

public

ClassRef : String;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TMyInterface = class(TMyClass)

public

Signature : String;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TMyDispInterface = class(TMyInterface)

public

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TEnum = class(TType)

protected

FItems : TStringList;

public

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property Items : TStringList read FItems;

end;

TNewType = class(TType)

public

TypeRenamed : String;

IntervalFrom : String;

IntervalTo : String;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TPointer = class(TType)

public

PointerOn : String;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TRecord = class(TType)

public

Fields : TList;

IsPacked : Boolean;

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TSet = class(TType)

public

TypeOfSet : TPascalItem;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TArrayDim = class(TPascalItem)

public

Low : String;

Hi : String;

TypeInterval : String;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TArray = class(TType)

protected

FItems : TList;

public

TypeOfArray : String;

IsPacked : Boolean;

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property Items : TList read FItems;

end;

TTypeFunc = class(TType)

public

Args : TPascalItem;

Modifiers : TPascalItem;

ReturnType : String;

IsOfObject : Boolean;

CallType : String;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TTypeProc = class(TType)

public

Args : TPascalItem;

Modifiers : TPascalItem;

IsOfObject : Boolean;

CallType : String;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TMethod = class(TPascalItem)

public

Args : TPascalItem;

Modifiers : TPascalItem;

IsClass : Boolean;

Count : Integer;

destructor Destroy; override;

function GetName : String; override;

end;

TFunc = class(TMethod)

public

ReturnType : String;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TProc = class(TMethod)

public

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TProperty = class(TPascalItem)

public

ReturnType : String;

PropRead : String;

PropWrite : String;

PropDefault : String;

PropStore : String;

PropDispId : String;

PropIndex : String;

PropImplements : String;

IndexName : String;

IndexType : String;

IsIndexConst : Boolean;

IsReadOnly : Boolean;

Args : TPascalItem;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TConstructor = class(TMethod)

public

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TDestructor = class(TPascalItem)

public

Args : TPascalItem;

Modifiers : TPascalItem;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

end;

TArg = class(TPascalItem)

protected

FItems : TStringList;

public

IsConst : Boolean;

IsVar : Boolean;

IsOut : Boolean;

IsArrayOf : Boolean;

DefaultValue : String;

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property Items : TStringList read FItems;

end;

TArgs = class(TPascalItem)

protected

FItems : TList;

public

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property Items : TList read FItems;

end;

TModifiers = class(TPascalItem)

protected

FItems : TStringList;

public

constructor Create;

destructor Destroy; override;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property Items : TStringList read FItems;

end;

TUnit = class(TPascalItem)

protected

FParser : TMyParser;

FUsesList : TStringList;

FVars : TList;

FConsts : TList;

FThreadVars : TList;

FTypes : TList;

FResourceStrings : TList;

function GetVarCount : Integer;

function GetVars( idx : Integer ) : TVar;

function GetConstCount : Integer;

function GetConsts( idx : Integer ) : TConst;

function GetThreadVarCount : Integer;

function GetThreadVars( idx : Integer ) : TVar;

function GetTypeCount : Integer;

function GetTypes( idx : Integer ) : TPascalItem;

function GetResourceStringCount : Integer;

function GetResourceStrings( idx : Integer ) : TPascalItem;

public

constructor Create;

destructor Destroy; override;

procedure Parse( const str : String );

procedure ParseVars;

procedure ParseThreadVars;

procedure ParseConsts;

procedure ParseResourceStrings;

procedure ParseTypes;

function ParseVar : TVar;

function ParseConst : TConst;

function ParseNewType( const TypeName : String ) : TNewType;

function ParseType : TPascalItem;

function ParseFunc : TFunc;

function ParseProc : TProc;

function ParseClass( const TypeName : String ) : TMyClass;

function ParseClassRef( const TypeName : String ) : TClassRef;

function ParseInterface( const TypeName : String ) : TMyInterface;

function ParseDispInterface( const TypeName : String ) : TMyDispInterface;

function ParseEnum( const TypeName : String ) : TEnum;

function ParsePointer( const TypeName : String ) : TPointer;

function ParseRecord( const TypeName : String; isPacked : Boolean ) : TRecord;

function ParseSet( const TypeName : String ) : TSet;

function ParseArray( const TypeName : String; isPacked : Boolean ) : TArray;

function ParseTypeFunc( const TypeName : String ) : TTypeFunc;

function ParseTypeProc( const TypeName : String ) : TTypeProc;

function ParseProperty : TProperty;

function ParseConstructor : TConstructor;

function ParseDestructor : TDestructor;

function ParseArgs : TArgs;

function ParseModifiers : TModifiers;

function IsSection : Boolean;

function IsCallType : Boolean;

procedure AddToTree( tree : TTreeView; node : TTreeNode ); override;

function AsString : String; override;

property UsesList : TStringList read FUsesList write FUsesList;

property Vars[idx : Integer ] : TVar read GetVars;

property VarCount : Integer read GetVarCount;

property Consts[idx : Integer ] : TConst read GetConsts;

property ConstCount : Integer read GetConstCount;

property ThreadVars[idx : Integer ] : TVar read GetThreadVars;

property ThreadVarCount : Integer read GetThreadVarCount;

property Types[idx : Integer ] : TPascalItem read GetTypes;

property TypeCount : Integer read GetTypeCount;

property ResourceStrings[idx : Integer] : TPascalItem read GetResourceStrings;

property ResourceStringCount : Integer read GetResourceStringCount;

end;

implementation

////////////////////////////////////////////////////

//

// class TPascalItem

//

////////////////////////////////////////////////////

function TPascalItem.GetName : String;

begin

Result := Name;

end;

////////////////////////////////////////////////////

//

// class TEnum

//

////////////////////////////////////////////////////

constructor TEnum.Create;

begin

inherited;

FItems := TStringList.Create;

end;

destructor TEnum.Destroy;

begin

FItems.Free;

inherited;

end;

procedure TEnum.AddToTree( tree : TTreeView; node : TTreeNode );

var

n : TTreeNode;

i : Integer;

begin

tree.Items.AddChild( node, AsString );

exit;

n := tree.Items.AddChild( node, Format('enum %s', [Name]) );

for i := 0 to Items.Count - 1 do

tree.Items.AddChild( n, Items.Strings[i] );

end;

function TEnum.AsString : String;

var

i : Integer;

s : String;

begin

if Items.Count > 0 then

begin

s := '( ' + Items.Strings[0];

for i := 1 to Items.Count - 1 do

s := s + ', ' + Items.Strings[i];

s := s + ' )';

end

else

s := '';

if Name <> '' then

Result := Format('%s = %s;', [Name, s])

else

Result := s;

end;

////////////////////////////////////////////////////

//

// class TMyClass

//

////////////////////////////////////////////////////

constructor TMyClass.Create;

begin

inherited;

FPrivateList := TList.Create;

FProtectedList := TList.Create;

FPublicList := TList.Create;

FPublishedList := TList.Create;

FAutomatedList := TList.Create;

CurrentSection := FPublicList;

FParentClasses := TStringList.Create;

end;

destructor TMyClass.Destroy;

begin

FPrivateList.Free;

FProtectedList.Free;

FPublicList.Free;

FPublishedList.Free;

FAutomatedList.Free;

FParentClasses.Free;

inherited;

end;

procedure TMyClass.AddSectionsToTree( tree : TTreeView; node : TTreeNode );

var

i : Integer;

n : TTreeNode;

begin

if PrivateList.Count > 0 then

begin

n := tree.Items.AddChild( node, 'Private' );

for i := 0 to PrivateList.Count - 1 do

tree.Items.AddChild( n, TPascalItem(PrivateList.Items[i]).AsString );

end;

if ProtectedList.Count > 0 then

begin

n := tree.Items.AddChild( node, 'Protected' );

for i := 0 to ProtectedList.Count - 1 do

tree.Items.AddChild( n, TPascalItem(ProtectedList.Items[i]).AsString );

end;

if PublicList.Count > 0 then

begin

n := tree.Items.AddChild( node, 'Public' );

for i := 0 to PublicList.Count - 1 do

tree.Items.AddChild( n, TPascalItem(PublicList.Items[i]).AsString );

end;

if PublishedList.Count > 0 then

begin

n := tree.Items.AddChild( node, 'Published' );

for i := 0 to PublishedList.Count - 1 do

tree.Items.AddChild( n, TPascalItem(PublishedList.Items[i]).AsString );

end;

end;

procedure TMyClass.AddToTree( tree : TTreeView; node : TTreeNode );

var

i : Integer;

p : TTreeNode;

s : String;

begin

if ParentClasses.Count > 0 then

begin

s := ParentClasses.Strings[0];

for i := 1 to ParentClasses.Count - 1 do

s := s + ', ' + ParentClasses.Strings[i];

s := Format( 'class %s( %s )', [Name, s]);

end

else

s := Format( 'class %s', [Name]);

p := tree.Items.AddChild( node, s );

AddSectionsToTree( tree, p );

end;

function TMyClass.AsString : String;

begin

Result := Format( 'class %s', [Name]);

end;

procedure TMyClass.ParseSections( Parser : TMyParser; AUnit : TUnit );

function CountMeth( meth : TPascalItem ) : TPascalItem;

var

m : TMethod;

i : Integer;

item : TPascalItem;

begin

Result := meth;

if not (meth is TMethod) then Exit;

m := TMethod(meth);

for i := CurrentSection.Count-1 downto 0 do

begin

item := TPascalItem( CurrentSection.Items[i] );

if (item.ClassName = m.ClassName) and

(m.Name = item.Name) then

begin

m.Count := (item as TMethod).Count + 1;

Break;

end;

end;

end;

var

s : String;

tmp : TPascalItem;

begin

with Parser, AUnit do

begin

while (PeekChar <> ';') and

(UpperCase( PeekSymbol ) <> 'END') do

begin

s := UpperCase(PeekSymbol);

if s = 'PRIVATE' then

begin

ReadSymbol;

CurrentSection := PrivateList

end

else if s = 'PROTECTED' then

begin

ReadSymbol;

CurrentSection := ProtectedList;

end

else if s = 'PUBLIC' then

begin

ReadSymbol;

CurrentSection := PublicList;

end

else if s = 'PUBLISHED' then

begin

ReadSymbol;

CurrentSection := PublishedList;

end

else if s = 'AUTOMATED' then

begin

ReadSymbol;

CurrentSection := AutomatedList;

end

else if s = 'CONSTRUCTOR' then

CurrentSection.Add( CountMeth( ParseConstructor ) )

else if s = 'DESTRUCTOR' then

CurrentSection.Add( ParseDestructor )

else if s = 'PROCEDURE' then

CurrentSection.Add( CountMeth( ParseProc ) )

else if s = 'FUNCTION' then

CurrentSection.Add( CountMeth( ParseFunc ) )

else if s = 'PROPERTY' then

CurrentSection.Add( ParseProperty )

else if s = 'CLASS' then

begin

ReadSymbol; // pass "class"

SkipWhite;

tmp := nil;

if UpperCase( PeekSymbol ) = 'PROCEDURE' then

tmp := ParseProc

else if UpperCase( PeekSymbol ) = 'FUNCTION' then

tmp := ParseFunc

else

RaiseErr('Could not find "procedure" or "function"');

if Assigned(tmp) then

begin

(tmp as TMethod).IsClass := True;

CurrentSection.Add( CountMeth( tmp ) );

end;

end

else

CurrentSection.Add( ParseVar );

SkipWhite;

end;

if PeekChar <> ';' then

ReadSymbol; // pass "end"

SkipSemiColon;

end;

end;

////////////////////////////////////////////////////

//

// class TClassRef

//

////////////////////////////////////////////////////

procedure TClassRef.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TClassRef.AsString : String;

begin

Result := Format('%s = class of %s;', [Name, ClassRef]);

end;

////////////////////////////////////////////////////

//

// class TMyInterface

//

////////////////////////////////////////////////////

procedure TMyInterface.AddToTree( tree : TTreeView; node : TTreeNode );

var

i : Integer;

p : TTreeNode;

s : String;

begin

if ParentClasses.Count > 0 then

begin

s := ParentClasses.Strings[0];

for i := 1 to ParentClasses.Count - 1 do

s := s + ', ' + ParentClasses.Strings[i];

s := Format( 'interface %s( %s )', [Name, s]);

end

else

s := Format( 'interface %s', [Name]);

p := tree.Items.AddChild( node, s );

tree.Items.AddChild( p, 'Signature = '+Signature );

AddSectionsToTree( tree, p );

end;

function TMyInterface.AsString : String;

begin

Result := Format( 'interface %s', [Name]);

end;

////////////////////////////////////////////////////

//

// class TMyDispInterface

//

////////////////////////////////////////////////////

procedure TMyDispInterface.AddToTree( tree : TTreeView; node : TTreeNode );

var

i : Integer;

p : TTreeNode;

s : String;

begin

if ParentClasses.Count > 0 then

begin

s := ParentClasses.Strings[0];

for i := 1 to ParentClasses.Count - 1 do

s := s + ', ' + ParentClasses.Strings[i];

s := Format( 'dispinterface %s( %s )', [Name, s]);

end

else

s := Format( 'dispinterface %s', [Name]);

p := tree.Items.AddChild( node, s );

tree.Items.AddChild( p, 'Signature = '+Signature );

AddSectionsToTree( tree, p );

end;

function TMyDispInterface.AsString : String;

begin

Result := Format( 'dispinterface %s', [Name]);

end;

////////////////////////////////////////////////////

//

// class TVar

//

////////////////////////////////////////////////////

constructor TVar.Create;

begin

inherited;

FItems := TStringList.Create;

end;

destructor TVar.Destroy;

begin

FItems.Free;

inherited;

end;

procedure TVar.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TVar.AsString : String;

var

i : Integer;

begin

Result := '';

if Items.Count = 0 then

Exit;

Result := Items.Strings[0];

for i := 1 to Items.Count - 1 do

Result := Result + ', ' + Items.Strings[i];

Result := Format('%s : %s', [Result, VarType]);

if Value <> '' then

Result := Result + ' = ' + Value;

Result := Result + ';';

end;

////////////////////////////////////////////////////

//

// class TConst

//

////////////////////////////////////////////////////

procedure TConst.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TConst.AsString : String;

begin

if ConstType <> '' then

Result := Format('%s : %s = %s', [Name, ConstType, ConstValue])

else

Result := Format('%s = %s', [Name, ConstValue]);

Result := Result + ';';

end;

////////////////////////////////////////////////////

//

// class TType

//

////////////////////////////////////////////////////

procedure TType.AddToTree( tree : TTreeView; node : TTreeNode );

begin

end;

function TType.AsString : String;

begin

Result := '';

end;

////////////////////////////////////////////////////

//

// class TNewType

//

////////////////////////////////////////////////////

procedure TNewType.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TNewType.AsString : String;

begin

if IntervalFrom <> '' then

Result := Format('%s..%s', [IntervalFrom, IntervalTo])

else

Result := TypeRenamed;

if Name <> '' then

Result := Name + ' = ' + Result + ';';

end;

////////////////////////////////////////////////////

//

// class TPointer

//

////////////////////////////////////////////////////

procedure TPointer.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TPointer.AsString : String;

begin

Result := Format('%s = ^%s;', [Name, PointerOn]);

end;

////////////////////////////////////////////////////

//

// class TRecord

//

////////////////////////////////////////////////////

constructor TRecord.Create;

begin

inherited;

Fields := TList.Create;

end;

destructor TRecord.Destroy;

begin

Fields.Free;

inherited;

end;

procedure TRecord.AddToTree( tree : TTreeView; node : TTreeNode );

var

n : TTreeNode;

i : Integer;

begin

n := tree.Items.AddChild( node, Format('record %s', [Name]) );

for i := 0 to Fields.Count - 1 do

TPascalItem(Fields.Items[i]).AddToTree( tree, n );

end;

function TRecord.AsString : String;

begin

Result := Format('record %s', [Name]);

end;

////////////////////////////////////////////////////

//

// class TSet

//

////////////////////////////////////////////////////

destructor TSet.Destroy;

begin

TypeOfSet.Free;

inherited;

end;

procedure TSet.AddToTree( tree : TTreeView; node : TTreeNode );

var

n : TTreeNode;

begin

tree.Items.AddChild( node, AsString );

exit;

n := tree.Items.AddChild( node, Format('set %s of', [Name]) );

if Assigned(TypeOfSet) then

TypeOfSet.AddToTree( tree, n );

end;

function TSet.AsString : String;

begin

Result := Format('%s = set of %s;', [Name, TypeOfSet.AsString]);

end;

////////////////////////////////////////////////////

//

// class TArrayDim

//

////////////////////////////////////////////////////

procedure TArrayDim.AddToTree( tree : TTreeView; node : TTreeNode );

begin

tree.Items.AddChild( node, AsString );

end;

function TArrayDim.AsString : String;

begin

if TypeInterval <> '' then

Result := Format('%s', [TypeInterval])

else

Result := Format('%s..%s', [Low, Hi]);

end;

////////////////////////////////////////////////////

//

// class TArray

//

////////////////////////////////////////////////////

constructor TArray.Create;

begin

inherited;

FItems := TList.Create;

end;

destructor TArray.Destroy;

begin

FItems.Free;

inherited;

end;

procedure TArray.AddToTree( tree : TTreeView; node : TTreeNode );

var

i : Integer;

n : TTreeNode;

begin

tree.Items.AddChild( node, AsString );

exit;

n := tree.Items.AddChild( node, Format('array %s of %s', [Name, TypeOfArray]) );

for i := 0 to Items.Count - 1 do

TPascalItem(Items.Items[i]).AddToTree( tree, n );

end;

function TArray.AsString : String;

var

i : Integer;

s : String;

begin

if Items.Count > 0 then

begin

s := '[ ' + TPascalItem(Items.Items[0]).AsString;

for i := 1 to Items.Count - 1 do

s := s + ', ' + TPascalItem(Items.Items[i]).AsString;

s := s + ' ]';

end

else

s := '';

Result := Format('%s = array %s of %s', [Name, s, TypeOfArray]);

end;

////////////////////////////////////////////////////

//

// class TTypeFunc

//

////////////////////////////////////////////////////

destructor TTypeFunc.Destroy;

begin

inherited;

Args.Free;

Modifiers.Free;