paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 05:49:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: fixed dotted runit reference

Browse Source 
git-svn-id: trunk@36117 -
This commit is contained in:
Mattias Gaertner 2017-05-05 14:19:21 +00:00
parent c552b2957a
commit 96f88184ef
2 changed files with 110 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
packages/fcl-passrc/src/pasresolver.pp
View File

@ -618,6 +618,7 @@ type
TPasModuleScope = class(TPasScope) TPasModuleScope = class(TPasScope)
public public
FirstName: string;
procedure IterateElements(const aName: string; StartScope: TPasScope; procedure IterateElements(const aName: string; StartScope: TPasScope;
const OnIterateElement: TIterateScopeElement; Data: Pointer; const OnIterateElement: TIterateScopeElement; Data: Pointer;
var Abort: boolean); override; var Abort: boolean); override;
@ -1528,6 +1529,7 @@ procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
function ProcNeedsImplProc(Proc: TPasProcedure): boolean; function ProcNeedsImplProc(Proc: TPasProcedure): boolean;
function ChompDottedIdentifier(const Identifier: string): string; function ChompDottedIdentifier(const Identifier: string): string;
function FirstDottedIdentifier(const Identifier: string): string;
function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean; function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
function dbgs(const Flags: TPasResolverComputeFlags): string; overload; function dbgs(const Flags: TPasResolverComputeFlags): string; overload;
@ -1815,6 +1817,17 @@ begin
Result:=LeftStr(Identifier,p-1); Result:=LeftStr(Identifier,p-1);
end; end;
function FirstDottedIdentifier(const Identifier: string): string;
var
p: SizeInt;
begin
p:=Pos('.',Identifier);
if p<1 then
Result:=Identifier
else
Result:=LeftStr(Identifier,p-1);
end;
function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean; function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
var var
l: Integer; l: Integer;
@ -2287,7 +2300,7 @@ procedure TPasModuleScope.IterateElements(const aName: string;
StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
Data: Pointer; var Abort: boolean); Data: Pointer; var Abort: boolean);
begin begin
if CompareText(aName,Element.Name)<>0 then exit; if CompareText(aName,FirstName)<>0 then exit;
OnIterateElement(Element,Self,StartScope,Data,Abort); OnIterateElement(Element,Self,StartScope,Data,Abort);
end; end;
@ -4985,6 +4998,7 @@ var
BuiltInProc: TResElDataBuiltInProc; BuiltInProc: TResElDataBuiltInProc;
p: SizeInt; p: SizeInt;
DottedName: String; DottedName: String;
Bin: TBinaryExpr;
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveNameExpr El=',GetObjName(El),' Name="',aName,'" ',Access); writeln('TPasResolver.ResolveNameExpr El=',GetObjName(El),' Name="',aName,'" ',Access);
@ -5041,15 +5055,19 @@ begin
if El=nil then if El=nil then
RaiseInternalError(20170503002012); RaiseInternalError(20170503002012);
CreateReference(DeclEl,El,Access); CreateReference(DeclEl,El,Access);
until false; if (El.Parent is TBinaryExpr) and (TBinaryExpr(El.Parent).right=El) then
// and add references to the binary expressions
while (El.Parent is TBinaryExpr) and (TBinaryExpr(El.Parent).right=El) do
begin begin
El:=TBinaryExpr(El.Parent); Bin:=TBinaryExpr(El.Parent);
if TBinaryExpr(El).OpCode<>eopSubIdent then break; while Bin.OpCode=eopSubIdent do
CreateReference(DeclEl,El,Access); begin
CreateReference(DeclEl,Bin,Access);
if not (Bin.Parent is TBinaryExpr) then break;
if (TBinaryExpr(Bin.Parent).right<>Bin) then break;
Bin:=TBinaryExpr(Bin.Parent);
end; end;
end; end;
until false;
end;
end; end;
procedure TPasResolver.ResolveInherited(El: TInheritedExpr; procedure TPasResolver.ResolveInherited(El: TInheritedExpr;
@ -5847,11 +5865,13 @@ end;
procedure TPasResolver.AddModule(El: TPasModule); procedure TPasResolver.AddModule(El: TPasModule);
var var
C: TClass; C: TClass;
ModScope: TPasModuleScope;
begin begin
if TopScope<>DefaultScope then if TopScope<>DefaultScope then
RaiseInvalidScopeForElement(20160922163504,El); RaiseInvalidScopeForElement(20160922163504,El);
PushScope(El,TPasModuleScope); ModScope:=TPasModuleScope(PushScope(El,TPasModuleScope));
TPasModuleScope(TopScope).VisibilityContext:=El; ModScope.VisibilityContext:=El;
ModScope.FirstName:=FirstDottedIdentifier(El.Name);
C:=El.ClassType; C:=El.ClassType;
if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
FDefaultNameSpace:=ChompDottedIdentifier(El.Name) FDefaultNameSpace:=ChompDottedIdentifier(El.Name)

90
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -280,6 +280,9 @@ type
Procedure TestUnitUseDotted; Procedure TestUnitUseDotted;
Procedure TestUnit_ProgramDefaultNamespace; Procedure TestUnit_ProgramDefaultNamespace;
Procedure TestUnit_DottedIdentifier; Procedure TestUnit_DottedIdentifier;
Procedure TestUnit_DottedPrg;
Procedure TestUnit_DottedUnit;
Procedure TestUnit_DottedExpr;
Procedure TestUnit_DuplicateDottedUsesFail; Procedure TestUnit_DuplicateDottedUsesFail;
Procedure TestUnit_DuplicateUsesDiffNameFail; Procedure TestUnit_DuplicateUsesDiffNameFail;
Procedure TestUnit_Unit1DotUnit2Fail; Procedure TestUnit_Unit1DotUnit2Fail;
@ -1260,14 +1263,14 @@ begin
Ref:=TResolvedReference(El.CustomData); Ref:=TResolvedReference(El.CustomData);
if ActualAccess<>rraNone then if ActualAccess<>rraNone then
begin begin
writeln('TTestResolver.CheckAccessMarkers multiple references at "#'+aMarker^.Identifier+'":'); //writeln('TTestResolver.CheckAccessMarkers multiple references at "#'+aMarker^.Identifier+'":');
for j:=0 to Elements.Count-1 do for j:=0 to Elements.Count-1 do
begin begin
El2:=TPasElement(Elements[i]); El2:=TPasElement(Elements[i]);
if not (El2.CustomData is TResolvedReference) then continue; if not (El2.CustomData is TResolvedReference) then continue;
//writeln('TTestResolver.CheckAccessMarkers ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); //writeln('TTestResolver.CheckAccessMarkers ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
Ref:=TResolvedReference(El.CustomData); Ref:=TResolvedReference(El.CustomData);
writeln(' ',j,'/',Elements.Count,' Element=',GetObjName(El2),' ',AccessNames[Ref.Access],' Declaration="',El2.GetDeclaration(true),'"'); //writeln(' ',j,'/',Elements.Count,' Element=',GetObjName(El2),' ',AccessNames[Ref.Access],' Declaration="',El2.GetDeclaration(true),'"');
end; end;
RaiseErrorAtSrcMarker('multiple references at "#'+aMarker^.Identifier+'"',aMarker); RaiseErrorAtSrcMarker('multiple references at "#'+aMarker^.Identifier+'"',aMarker);
end; end;
@ -3795,13 +3798,13 @@ begin
'begin', 'begin',
' if j1=0 then ;', ' if j1=0 then ;',
'']); '']);
writeln('TTestResolver.TestUnit_ProgramDefaultNamespace ');
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestUnit_DottedIdentifier; procedure TTestResolver.TestUnit_DottedIdentifier;
begin begin
MainFilename:='unitdots.main1.pas'; MainFilename:='unitdots.main1.pas';
AddModuleWithIntfImplSrc('unitdots.unit1.pp', AddModuleWithIntfImplSrc('unitdots.unit1.pp',
LinesToStr([ LinesToStr([
'type TColor = longint;', 'type TColor = longint;',
@ -3829,7 +3832,74 @@ begin
' if unitdots.j1=0 then ;', ' if unitdots.j1=0 then ;',
' if unitdots.unit1.i1=0 then ;', ' if unitdots.unit1.i1=0 then ;',
'']); '']);
writeln('TTestResolver.TestUnit_DottedIdentifier '); ParseProgram;
end;
procedure TTestResolver.TestUnit_DottedPrg;
begin
MainFilename:='unitdots.main1.pas';
AddModuleWithIntfImplSrc('unitdots.unit1.pp',
LinesToStr([
'type TColor = longint;',
'var i1: longint;']),
LinesToStr([
'']));
StartProgram(true);
Add([
'uses UnIt1;',
'type',
' TPrgColor = UNIT1.tcolor;',
' TStrange = UnitDots.Main1.tprgcolor;',
'var k1: longint;',
'begin',
' if unitdots.main1.k1=0 then ;',
' if unit1.i1=0 then ;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestUnit_DottedUnit;
begin
MainFilename:='unitdots.unit1.pas';
StartUnit(false);
Add([
'interface',
'var k1: longint;',
'implementation',
'initialization',
' if unitDots.Unit1.k1=0 then ;',
'']);
ParseUnit;
end;
procedure TTestResolver.TestUnit_DottedExpr;
begin
MainFilename:='unitdots1.sub1.main1.pas';
AddModuleWithIntfImplSrc('unitdots2.sub2.unit2.pp',
LinesToStr([
'procedure DoIt; external name ''$DoIt'';']),
LinesToStr([
'']));
AddModuleWithIntfImplSrc('unitdots3.sub3.unit3.pp',
LinesToStr([
'procedure DoSome;']),
LinesToStr([
'uses unitdots2.sub2.unit2;',
'procedure DoSome;',
'begin',
' unitdots2.sub2.unit2.doit;',
'end;']));
StartProgram(true);
Add([
'uses unitdots3.sub3.unit3;',
'begin',
' unitdots3.sub3.unit3.dosome;',
'']);
ParseProgram; ParseProgram;
end; end;
@ -4648,16 +4718,16 @@ begin
aMarker:=FirstSrcMarker; aMarker:=FirstSrcMarker;
while aMarker<>nil do while aMarker<>nil do
begin begin
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol); //writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker); Elements:=FindElementsAt(aMarker);
try try
for i:=0 to Elements.Count-1 do for i:=0 to Elements.Count-1 do
begin begin
El:=TPasElement(Elements[i]); El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); //writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue; if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData); Ref:=TResolvedReference(El.CustomData);
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',GetObjName(Ref.Declaration)); //writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',GetObjName(Ref.Declaration));
if not (Ref.Declaration is TPasResultElement) then continue; if not (Ref.Declaration is TPasResultElement) then continue;
ResultEl:=TPasResultElement(Ref.Declaration); ResultEl:=TPasResultElement(Ref.Declaration);
Proc:=ResultEl.Parent as TPasProcedure; Proc:=ResultEl.Parent as TPasProcedure;
@ -6203,17 +6273,17 @@ begin
aMarker:=FirstSrcMarker; aMarker:=FirstSrcMarker;
while aMarker<>nil do while aMarker<>nil do
begin begin
writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol); //writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker); Elements:=FindElementsAt(aMarker);
try try
for i:=0 to Elements.Count-1 do for i:=0 to Elements.Count-1 do
begin begin
El:=TPasElement(Elements[i]); El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); //writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue; if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData); Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProcedure) then continue; if not (Ref.Declaration is TPasProcedure) then continue;
writeln('TTestResolver.TestClass_ConDestructor_Inherited ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags); //writeln('TTestResolver.TestClass_ConDestructor_Inherited ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
if rrfNewInstance in Ref.Flags then if rrfNewInstance in Ref.Flags then
RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker); RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
if rrfFreeInstance in Ref.Flags then if rrfFreeInstance in Ref.Flags then