paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-04 23:17:49 +01:00
Code Issues Packages Projects Releases Wiki Activity

h2pas: finished tool to add named types for implicit types

Browse Source 
git-svn-id: trunk@10379 -
This commit is contained in:
mattias 2007-01-05 14:36:42 +00:00
parent 4c41489aae
commit 5c09d7b773
3 changed files with 651 additions and 412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

364
components/h2pas/h2pasconvert.pas
View File

@ -111,6 +111,32 @@ type
}
TReplaceImplicitTypes = class(TCustomTextConverterTool)
private
Src: String;
ImplicitTypes: TAvgLvlTree;// tree of TImplicitType
ExplicitTypes: TAvgLvlTree;// tree of TImplicitType
TypeStart: LongInt;
TypeEnd: integer; // 0 means invalid
ConstSectionStart: LongInt;
ConstSectionEnd: LongInt; // 0 means invalid
function FindNextImplicitType(var Position: integer;
out aTypeStart, aTypeEnd: integer): boolean;
function SearchImplicitParameterTypes(
var ModalResult: TModalResult): boolean;
function PosToStr(Position: integer): string;
procedure AdjustMinPositions(const Identifier: string);
function ReadWord(var Position: integer): boolean;
function ReadUntilAtom(var Position: integer;
const StopAtom: string; SkipBrackets: boolean = true): boolean;
function ReadRecord(var Position: integer): boolean;
function ReadClass(var Position: integer): boolean;
function ReadTypeDefinition(var Position: integer): boolean;
function ReadConstSection(var Position: integer): boolean;
function FindExplicitTypesAndConstants(
var ModalResult: TModalResult): boolean;
function InsertNewTypes(var ModalResult: TModalResult): boolean;
function FindInsertPosition(MinPos: integer): integer;
function UseNewTypes(var ModalResult: TModalResult): boolean;
public
class function ClassDescription: string; override;
function Execute(aText: TIDETextConverter): TModalResult; override;
@ -1816,6 +1842,7 @@ type
Code: string;
MinPosition: integer;
MaxPosition: integer;
MinPositionNeedsTypeSection: boolean;
end;
function CompareImplicitTypeNames(Type1, Type2: Pointer): integer;
@ -1831,6 +1858,11 @@ begin
PChar(TImplicitType(ImplicitType).Name));
end;
function CompareImplicitTypeMinPositions(Type1, Type2: Pointer): integer;
begin
Result:=TImplicitType(Type1).MinPosition-TImplicitType(Type2).MinPosition;
end;
{ TReplaceImplicitParameterTypes }
class function TReplaceImplicitTypes.ClassDescription: string;
@ -1844,20 +1876,15 @@ begin
+' Tarray_0to2_of_char = array[0..2] of char';
end;
function TReplaceImplicitTypes.Execute(aText: TIDETextConverter
): TModalResult;
var
Src: String;
ImplicitTypes: TAvgLvlTree;// tree of TImplicitType
ExplicitTypes: TAvgLvlTree;// tree of TImplicitType
function FindNextImplicitType(var Position: integer;
out TypeStart, TypeEnd: integer): boolean;
function TReplaceImplicitTypes.FindNextImplicitType(var Position: integer;
out aTypeStart, aTypeEnd: integer): boolean;
var
AtomStart: LongInt;
CurAtom: string;
begin
Result:=false;
aTypeStart:=0;
aTypeEnd:=0;
AtomStart:=Position;
repeat
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
@ -1866,7 +1893,7 @@ var
// var, const, out declaration
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if CurAtom='' then break;
TypeStart:=AtomStart;
aTypeStart:=AtomStart;
if CompareIdentifiers(PChar(CurAtom),'array')=0 then begin
// :array
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
@ -1884,7 +1911,7 @@ var
end else if (length(CurAtom)=1) and (CurAtom[1] in [';',')',']'])
then begin
// type end found
TypeEnd:=AtomStart;
aTypeEnd:=AtomStart;
Result:=true;
exit;
end;
@ -1895,7 +1922,8 @@ var
until CurAtom='';
end;
function SearchImplicitParameterTypes(var ModalResult: TModalResult): boolean;
function TReplaceImplicitTypes.SearchImplicitParameterTypes(
var ModalResult: TModalResult): boolean;
var
Position: Integer;
StartPos, EndPos: integer;
@ -1908,7 +1936,7 @@ var
Position:=1;
while FindNextImplicitType(Position,StartPos,EndPos) do begin
TypeCode:=copy(Src,StartPos,EndPos-StartPos);
DebugLn(['SearchImplicitParameterTypes ',StartPos,' TypeCode="',TypeCode,'"']);
//DebugLn(['SearchImplicitParameterTypes ',StartPos,' TypeCode="',TypeCode,'"']);
TypeName:=CodeToIdentifier(TypeCode);
if TypeName='' then continue;
if (ImplicitTypes<>nil)
@ -1919,7 +1947,7 @@ var
continue;
end;
// add new type
DebugLn(['SearchImplicitParameterTypes Adding new type ',StartPos,' TypeName=',TypeName,' TypeCode="',TypeCode,'"']);
//DebugLn(['SearchImplicitParameterTypes Adding new type ',StartPos,' TypeName=',TypeName,' TypeCode="',TypeCode,'"']);
NewType:=TImplicitType.Create;
NewType.Name:=TypeName;
NewType.Code:=TypeCode;
@ -1932,18 +1960,7 @@ var
Result:=true;
end;
function FindExplicitTypesAndConstants(var ModalResult: TModalResult): boolean;
{ every implicit type can contian references to explicit types and constants
For example: array[0..3] of bogus
If 'bogus' is defined in this source, then the new type must be defined
after 'bogus'.
=> Search all explicit types
}
var
TypeStart: LongInt;
TypeEnd: integer; // 0 means invalid
function PosToStr(Position: integer): string;
function TReplaceImplicitTypes.PosToStr(Position: integer): string;
var
Line, Col: integer;
begin
@ -1951,15 +1968,21 @@ var
Result:='(y='+IntToStr(Line)+',x='+IntToStr(Col)+')';
end;
procedure AdjustMinPositions(const Identifier: string);
procedure TReplaceImplicitTypes.AdjustMinPositions(const Identifier: string);
var
Node: TAvgLvlTreeNode;
Item: TImplicitType;
Position: Integer;
AtomStart: LongInt;
CurAtom: String;
MinPos: LongInt;
begin
if TypeEnd<1 then exit;
if TypeEnd>0 then
MinPos:=TypeEnd
else if ConstSectionEnd>0 then
MinPos:=ConstSectionEnd
else
exit;
//DebugLn(['AdjustMinPositions Identifier=',Identifier]);
// search Identifier in all implicit type definitions
@ -1977,12 +2000,14 @@ var
if CompareIdentifiers(PChar(Identifier),PChar(CurAtom))=0 then begin
// this implicit type depends on an explicit type defined
// prior in this source file
DebugLn(['AdjustMinPositions "',Item.Name,'=',Item.Code,'"',
{DebugLn(['AdjustMinPositions "',Item.Name,'=',Item.Code,'"',
' depends on ',Identifier,
' defined at ',PosToStr(TypeStart),'-',PosToStr(TypeEnd),
' as "',copy(Src,TypeStart,30),'"']);
if Item.MinPosition<TypeEnd then
Item.MinPosition:=TypeEnd;
' defined at ',PosToStr(MinPos),
' as "',copy(Src,MinPos,30),'"']);}
if Item.MinPosition<MinPos then begin
Item.MinPosition:=MinPos;
Item.MinPositionNeedsTypeSection:=TypeEnd<1;
end;
break;
end;
until false;
@ -1991,9 +2016,7 @@ var
end;
end;
function ReadTypeDefinition(var Position: integer): boolean; forward;
function ReadWord(var Position: integer): boolean;
function TReplaceImplicitTypes.ReadWord(var Position: integer): boolean;
var
AtomStart: LongInt;
CurAtom: String;
@ -2008,26 +2031,36 @@ var
end;
end;
function ReadUntilAtom(var Position: integer;
const StopAtom: string): boolean;
function TReplaceImplicitTypes.ReadUntilAtom(var Position: integer;
const StopAtom: string; SkipBrackets: boolean = true): boolean;
var
AtomStart: LongInt;
CurAtom: String;
StartPos: LongInt;
begin
Result:=false;
StartPos:=Position;
AtomStart:=Position;
repeat
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if CurAtom='' then begin
DebugLn(['ReadUntilAtom atom not found: "',StopAtom,'" (starting at ',PosToStr(StartPos),')']);
exit(false);
exit;
end;
if SkipBrackets then begin
if CurAtom='(' then begin
// skip round bracket open
if not ReadUntilAtom(Position,')') then exit;
end else if CurAtom='[' then begin
// skip edged bracket open
if not ReadUntilAtom(Position,']') then exit;
end;
end;
until CurAtom=StopAtom;
Result:=true;
end;
function ReadRecord(var Position: integer): boolean;
function TReplaceImplicitTypes.ReadRecord(var Position: integer): boolean;
var
AtomStart: LongInt;
CurAtom: String;
@ -2083,7 +2116,7 @@ var
Result:=true;
end;
function ReadClass(var Position: integer): boolean;
function TReplaceImplicitTypes.ReadClass(var Position: integer): boolean;
var
AtomStart: LongInt;
CurAtom: String;
@ -2119,7 +2152,9 @@ var
Result:=true;
end;
function ReadTypeDefinition(var Position: integer): boolean;
function TReplaceImplicitTypes.ReadTypeDefinition(
var Position: integer): boolean;
// Position must be after the colon
var
AtomStart: LongInt;
CurAtom: String;
@ -2171,13 +2206,80 @@ var
end else if CurAtom='[' then begin
// skip edged bracket open
if not ReadUntilAtom(Position,']') then exit;
end else if CurAtom=';' then
end else if (length(CurAtom)=1) and (CurAtom[1] in [';',')',']']) then
break;
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
until false;
Result:=true;
end;
function TReplaceImplicitTypes.ReadConstSection(var Position: integer): boolean;
// Position must be after the 'const' keyword
var
AtomStart: LongInt;
CurAtom: String;
ConstStart: LongInt;
begin
Result:=false;
AtomStart:=Position;
repeat
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if CurAtom='' then begin
DebugLn(['ReadConstSection end not found']);
exit;
end;
if IsIdentStartChar[CurAtom[1]] then begin
// const identifier(s) or end of const section
//DebugLn(['ReadConstSection Const name ',CurAtom,' at ',PosToStr(AtomStart)]);
ConstStart:=AtomStart;
// for example: a,b,c: integer = 1; d=1, e:integer=0;
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if (length(CurAtom)<>1) or (not (CurAtom[1] in [',','=',':'])) then
begin
// end of const section
Position:=ConstStart;
Result:=true;
exit;
end;
Position:=ConstStart;
repeat
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
// read identifier
if (CurAtom<>'') and IsIdentStartChar[CurAtom[1]] then begin
// identifier
AdjustMinPositions(CurAtom);
end else begin
DebugLn(['ReadConstSection end of section missing']);
exit;
end;
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if (CurAtom='=') or (CurAtom=':') then begin
// skip type and expression
if not ReadUntilAtom(Position,';') then exit;
break;
end else if CurAtom=',' then begin
// next const name
end else begin
DebugLn(['ReadConstSection end of section missing']);
exit;
end;
until false;
end else begin
// end of const section
break;
end;
until false;
Result:=true;
end;
function TReplaceImplicitTypes.FindExplicitTypesAndConstants(
var ModalResult: TModalResult): boolean;
{ every implicit type can contian references to explicit types and constants
For example: array[0..3] of bogus
If 'bogus' is defined in this source, then the new type must be defined
after 'bogus'.
=> Search all explicit types
}
var
Position: Integer;
AtomStart: LongInt;
@ -2202,14 +2304,14 @@ var
if (Identifier<>'') and (IsIdentStartChar[Identifier[1]]) then begin
// word found (can be an identifier or start of next section)
TypeStart:=AtomStart;
TypeEnd:=0;
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if CurAtom<>'=' then begin
DebugLn(['FindExplicitTypes type section ended at ',PosToStr(AtomStart)]);
//DebugLn(['FindExplicitTypes type section ended at ',PosToStr(AtomStart)]);
break;
end;
// Identifier is a type => find end of type definition
//DebugLn(['FindExplicitTypes type definition found: ',Identifier,' at ',PosToStr(TypeStart)]);
TypeEnd:=0;
TypeDefStart:=Position;
Result:=ReadTypeDefinition(Position);
if not Result then begin
@ -2233,20 +2335,30 @@ var
end;
// skip semicolon
Position:=TypeEnd;
TypeEnd:=0;
end;
until false;
end
else if CompareIdentifiers(PChar(CurAtom),'const')=0 then begin
{ ToDo
repeat
Identifier:=ReadNextPascalAtom(Src,Position,AtomStart);
if (Identifier<>'') and (IsIdentStartChar[Identifier[1]]) then begin
end else if CurAtom=':' then begin
end else begin
ConstSectionStart:=Position;
ConstSectionEnd:=0;
// find end of const section
//DebugLn(['TReplaceImplicitTypes.FindExplicitTypesAndConstants finding end of const section ...']);
Result:=ReadConstSection(Position);
if not Result then begin
DebugLn(['FindExplicitTypes FAILED reading const section at ',PosToStr(ConstSectionStart)]);
exit;
end;
until false;}
ConstSectionEnd:=Position;
// reread the section for the identifiers
Position:=ConstSectionStart;
//DebugLn(['TReplaceImplicitTypes.FindExplicitTypesAndConstants collecting const identifiers ...']);
Result:=ReadConstSection(Position);
if not Result then begin
DebugLn(['FindExplicitTypes FAILED reading const section at ',PosToStr(ConstSectionStart)]);
exit;
end;
ConstSectionEnd:=0;
end;
until false;
@ -2254,44 +2366,158 @@ var
Result:=true;
end;
function AdjustMinPositions(var ModalResult: TModalResult): boolean;
function TReplaceImplicitTypes.InsertNewTypes(var ModalResult: TModalResult
): boolean;
function CreateCode(Item: TImplicitType): string;
begin
Result:=' '+Item.Name+' = '+Item.Code+';';
end;
var
Node: TAvgLvlTreeNode;
Item: TImplicitType;
InsertPos: integer;
NextItem: TImplicitType;
NextInsertPos: integer;
NewCode: String;
begin
Result:=false;
ModalResult:=mrCancel;
if (ImplicitTypes<>nil) then begin
// find all explicit types
// ToDo: find constants, use constant section end as MinPosition
if not FindExplicitTypesAndConstants(ModalResult) then exit;
// now all min and max positions for the new types are known
// ToDo: resort the ImplicitTypes for MinPosition
// ToDo: Insert every type
Node:=ImplicitTypes.FindLowest;
// re-sort the ImplicitTypes for MinPosition
ImplicitTypes.OnCompare:=@CompareImplicitTypeMinPositions;
try
// Insert every type
Node:=ImplicitTypes.FindHighest;
while Node<>nil do begin
Item:=TImplicitType(Node.Data);
NewCode:=CreateCode(Item);
if Item.MinPositionNeedsTypeSection or (Item.MinPosition=0) then
NewCode:='type'+LineEnding+NewCode;
InsertPos:=FindInsertPosition(Item.MinPosition);
// add all items at the same position
repeat
Node:=ImplicitTypes.FindPrecessor(Node);
if (Node=nil) then break;
NextItem:=TImplicitType(Node.Data);
NextInsertPos:=FindLineEndOrCodeAfterPosition(Src,NextItem.MinPosition,
length(Src)+1,false);
if InsertPos>NextInsertPos then
break;
NewCode:=NewCode+LineEnding+CreateCode(NextItem);
until false;
Node:=ImplicitTypes.FindSuccessor(Node);
// insert line ends
if (InsertPos>1) and (InsertPos<length(Src))
and (not (Src[InsertPos-1] in [#10,#13])) then
NewCode:=LineEnding+NewCode;
if (InsertPos<=length(Src)) and (not (Src[InsertPos] in [#10,#13])) then
NewCode:=NewCode+LineEnding;
// insert code
DebugLn(['TReplaceImplicitTypes.InsertNewTypes Insert at ',PosToStr(InsertPos),' NewCode="',NewCode,'"']);
Src:=copy(Src,1,InsertPos-1)+NewCode+copy(Src,InsertPos,length(Src));
end;
finally
// re-sort the ImplicitTypes for Names
ImplicitTypes.OnCompare:=@CompareImplicitTypeNames;
end;
end;
ModalResult:=mrOk;
Result:=true;
end;
function TReplaceImplicitTypes.FindInsertPosition(MinPos: integer): integer;
var
Position: Integer;
AtomStart: LongInt;
CurAtom: String;
begin
{$IFNDEF EnableReplaceImplicitTypes}
exit(mrOk);
{$ENDIF}
if MinPos>0 then begin
Result:=FindLineEndOrCodeAfterPosition(Src,MinPos,length(Src)+1,false);
end else begin
// find insert position for a first type section
Result:=1;
Position:=1;
AtomStart:=Position;
repeat
CurAtom:=ReadNextPascalAtom(Src,Position,AtomStart);
if CurAtom='' then break;
if (CompareIdentifiers(PChar(CurAtom),'UNIT')=0)
or (CompareIdentifiers(PChar(CurAtom),'PROGRAM')=0)
or (CompareIdentifiers(PChar(CurAtom),'LIBRARY')=0)
or (CompareIdentifiers(PChar(CurAtom),'PACKAGE')=0)
or (CompareIdentifiers(PChar(CurAtom),'USES')=0)
then begin
ReadUntilAtom(Position,';');
Result:=Position;
end
else if (CompareIdentifiers(PChar(CurAtom),'INTERFACE')=0)
or (CompareIdentifiers(PChar(CurAtom),'IMPLEMENTATION')=0)
then begin
Result:=Position;
break;
end else
break;
until false;
end;
end;
function TReplaceImplicitTypes.UseNewTypes(var ModalResult: TModalResult
): boolean;
var
Position: Integer;
StartPos: Integer;
EndPos: Integer;
TypeCode: String;
TypeName: String;
Node: TAvgLvlTreeNode;
Item: TImplicitType;
begin
Result:=false;
ModalResult:=mrCancel;
if (ImplicitTypes<>nil) then begin
Position:=1;
StartPos:=1;
EndPos:=1;
while FindNextImplicitType(Position,StartPos,EndPos) do begin
TypeCode:=copy(Src,StartPos,EndPos-StartPos);
//DebugLn(['UseNewTypes ',StartPos,' TypeCode="',TypeCode,'"']);
TypeName:=CodeToIdentifier(TypeCode);
if TypeName='' then continue;
Node:=ImplicitTypes.FindKey(Pointer(TypeName),
@CompareImplicitTypeStringAndName);
if Node<>nil then begin
// replace
Item:=TImplicitType(Node.Data);
Src:=copy(Src,1,StartPos-1)+Item.Name+copy(Src,EndPos,length(Src));
Position:=StartPos+length(Item.Name);
end;
end;
end;
ModalResult:=mrOk;
Result:=true;
end;
function TReplaceImplicitTypes.Execute(aText: TIDETextConverter
): TModalResult;
begin
Src:=aText.Source;
if Src='' then exit(mrOk);
ImplicitTypes:=nil;
ExplicitTypes:=nil;
TypeEnd:=0;
ConstSectionEnd:=0;
try
if not SearchImplicitParameterTypes(Result) then exit;
if not AdjustMinPositions(Result) then exit;
if (ImplicitTypes<>nil) then begin
if not FindExplicitTypesAndConstants(Result) then exit;
if not InsertNewTypes(Result) then exit;
if not UseNewTypes(Result) then exit;
aText.Source:=Src;
end;
finally
if ImplicitTypes<>nil then begin
ImplicitTypes.FreeAndClear;

16
components/simpleideintf/examples/files/h2pastest.pas
View File

@ -1,3 +1,10 @@
unit h2pastest;
interface
const
MinValue = 0;
MaxValue = 5;
type
TMyClass = class;
@ -17,9 +24,10 @@ type
false: (AsWord: word);
end;
// this procedure contains an explicit/anoymous type, which is not allowed
// in FreePascal. The TReplaceImplicitTypes tool will replace it with a
// named type
procedure DoSomething(var a: array[0..3] of TMyClass);
// these procedures contain explicit/anoymous types, which are not allowed
// in FreePascal. The TReplaceImplicitTypes tool will replace them with
// named types
procedure DoSomething1(var a: array[0..3] of TMyClass);
procedure DoSomething2(var a: array[MinValue..MaxValue] of char);

33
components/simpleideintf/examples/testh2pastool.lpi
View File

@ -39,7 +39,7 @@
<PackageName Value="CodeTools"/>
</Item3>
</RequiredPackages>
<Units Count="17">
<Units Count="18">
<Unit0>
<Filename Value="testh2pastool.lpr"/>
<IsPartOfProject Value="True"/>
@ -47,7 +47,7 @@
<CursorPos X="23" Y="36"/>
<TopLine Value="21"/>
<EditorIndex Value="0"/>
<UsageCount Value="27"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
@ -100,11 +100,11 @@
</Unit7>
<Unit8>
<Filename Value="files/h2pastest.pas"/>
<UnitName Value="h2pasTest"/>
<CursorPos X="53" Y="23"/>
<UnitName Value="h2pastest"/>
<CursorPos X="10" Y="3"/>
<TopLine Value="1"/>
<EditorIndex Value="4"/>
<UsageCount Value="24"/>
<EditorIndex Value="2"/>
<UsageCount Value="26"/>
<Loaded Value="True"/>
</Unit8>
<Unit9>
@ -117,10 +117,10 @@
<Unit10>
<Filename Value="../../h2pas/h2pasconvert.pas"/>
<UnitName Value="H2PasConvert"/>
<CursorPos X="32" Y="2240"/>
<TopLine Value="2213"/>
<CursorPos X="10" Y="2457"/>
<TopLine Value="2433"/>
<EditorIndex Value="1"/>
<UsageCount Value="13"/>
<UsageCount Value="15"/>
<Loaded Value="True"/>
</Unit10>
<Unit11>
@ -133,8 +133,8 @@
<Unit12>
<Filename Value="../../codetools/basiccodetools.pas"/>
<UnitName Value="BasicCodeTools"/>
<CursorPos X="1" Y="2050"/>
<TopLine Value="2026"/>
<CursorPos X="10" Y="95"/>
<TopLine Value="75"/>
<EditorIndex Value="3"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
@ -162,13 +162,18 @@
</Unit15>
<Unit16>
<Filename Value="../../../packager/globallinks/simpleideintf-0.lpl"/>
<CursorPos X="53" Y="1"/>
<CursorPos X="12" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
<SyntaxHighlighter Value="None"/>
</Unit16>
<Unit17>
<Filename Value="../../../lcl/avglvltree.pas"/>
<UnitName Value="AvgLvlTree"/>
<CursorPos X="23" Y="93"/>
<TopLine Value="65"/>
<UsageCount Value="10"/>
</Unit17>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
</ProjectOptions>