paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 13:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: parse library

Browse Source 
git-svn-id: trunk@47936 -
This commit is contained in:
Mattias Gaertner 2021-01-01 22:29:58 +00:00
parent e6037961e3
commit f0122bd4a0
5 changed files with 272 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -435,6 +435,7 @@ type
revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3]
revkExternal // TResEvalExternal: an external const
);
TREVKinds = set of TREVKind;
const
revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString];
type
@ -447,6 +448,7 @@ type
function Clone: TResEvalValue; virtual;
function AsDebugString: string; virtual;
function AsString: string; virtual;
function TypeAsString: string; virtual;
end;
TResEvalValueClass = class of TResEvalValue;
@ -459,6 +461,7 @@ type
constructor CreateValue(const aValue: boolean);
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
TResEvalTypedInt = (
@ -520,6 +523,7 @@ type
function Clone: TResEvalValue; override;
function AsString: string; override;
function AsDebugString: string; override;
function TypeAsString: string; override;
end;
{ TResEvalUInt }
@ -531,6 +535,7 @@ type
constructor CreateValue(const aValue: TMaxPrecUInt);
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
{ TResEvalFloat }
@ -543,6 +548,7 @@ type
function Clone: TResEvalValue; override;
function AsString: string; override;
function IsInt(out Int: TMaxPrecInt): boolean;
function TypeAsString: string; override;
end;
{ TResEvalCurrency }
@ -556,6 +562,7 @@ type
function AsString: string; override;
function IsInt(out Int: TMaxPrecInt): boolean;
function AsInt: TMaxPrecInt; // value * 10.000
function TypeAsString: string; override;
end;
{$ifdef FPC_HAS_CPSTRING}
@ -569,6 +576,7 @@ type
constructor CreateValue(const aValue: RawByteString);
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
{$endif}
@ -581,6 +589,7 @@ type
constructor CreateValue(const aValue: UnicodeString);
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
{ TResEvalEnum - Kind=revkEnum, Value.Int }
@ -596,6 +605,7 @@ type
function Clone: TResEvalValue; override;
function AsDebugString: string; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
TRESetElKind = (
@ -620,6 +630,7 @@ type
function AsString: string; override;
function AsDebugString: string; override;
function ElementAsString(El: TMaxPrecInt): string; virtual;
function TypeAsString: string; override;
end;
{ TResEvalRangeUInt }
@ -631,6 +642,7 @@ type
constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt);
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
{ TResEvalSet - Kind=revkSetOfInt }
@ -652,6 +664,7 @@ type
const aRangeStart, aRangeEnd: TMaxPrecInt); override;
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored
function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer;
function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range
@ -665,6 +678,7 @@ type
constructor Create; override;
function Clone: TResEvalValue; override;
function AsString: string; override;
function TypeAsString: string; override;
end;
TResEvalFlag = (
@ -1188,6 +1202,11 @@ begin
Result:=inherited AsString;
end;
function TResEvalExternal.TypeAsString: string;
begin
Result:='external value';
end;
{ TResEvalCurrency }
constructor TResEvalCurrency.Create;
@ -1231,6 +1250,11 @@ begin
{$endif};
end;
function TResEvalCurrency.TypeAsString: string;
begin
Result:='currency';
end;
{ TResEvalBool }
constructor TResEvalBool.Create;
@ -1259,6 +1283,11 @@ begin
Result:='false';
end;
function TResEvalBool.TypeAsString: string;
begin
Result:='boolean';
end;
{ TResEvalRangeUInt }
constructor TResEvalRangeUInt.Create;
@ -1287,6 +1316,11 @@ begin
Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd);
end;
function TResEvalRangeUInt.TypeAsString: string;
begin
Result:='unsigned integer range';
end;
{ TResExprEvaluator }
procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType;
@ -5615,6 +5649,15 @@ begin
end;
end;
function TResEvalValue.TypeAsString: string;
begin
case Kind of
revkNil: Result:='nil';
else
Result:='';
end;
end;
{ TResEvalUInt }
constructor TResEvalUInt.Create;
@ -5640,6 +5683,11 @@ begin
Result:=IntToStr(UInt);
end;
function TResEvalUInt.TypeAsString: string;
begin
Result:='unsigned int';
end;
{ TResEvalInt }
constructor TResEvalInt.Create;
@ -5697,6 +5745,24 @@ begin
end;
end;
function TResEvalInt.TypeAsString: string;
begin
case Typed of
reitByte: Result:='byte';
reitShortInt: Result:='shortint';
reitWord: Result:='word';
reitSmallInt: Result:='smallint';
reitUIntSingle: Result:='unsinged int single';
reitIntSingle: Result:='int single';
reitLongWord: Result:='longword';
reitLongInt: Result:='longint';
reitUIntDouble: Result:='unsigned int double';
reitIntDouble: Result:='int double';
else
Result:='int';
end;
end;
{ TResEvalFloat }
constructor TResEvalFloat.Create;
@ -5732,6 +5798,11 @@ begin
Result:=true;
end;
function TResEvalFloat.TypeAsString: string;
begin
Result:='float';
end;
{$ifdef FPC_HAS_CPSTRING}
{ TResEvalString }
@ -5759,6 +5830,15 @@ function TResEvalString.AsString: string;
begin
Result:=RawStrToCaption(S,60);
end;
function TResEvalString.TypeAsString: string;
begin
if OnlyASCII then
Result:='string'
else
Result:='ansistring';
end;
{$endif}
{ TResEvalUTF16 }
@ -5786,6 +5866,11 @@ begin
Result:=String(UnicodeStrToCaption(S,60));
end;
function TResEvalUTF16.TypeAsString: string;
begin
Result:='unicodestring';
end;
{ TResEvalEnum }
constructor TResEvalEnum.Create;
@ -5849,6 +5934,13 @@ begin
Result:=ElType.Name+'('+IntToStr(Index)+')';
end;
function TResEvalEnum.TypeAsString: string;
begin
Result:=ElType.Name;
if Result='' then
Result:='enum';
end;
{ TResEvalRangeInt }
constructor TResEvalRangeInt.Create;
@ -5920,6 +6012,18 @@ begin
end;
end;
function TResEvalRangeInt.TypeAsString: string;
begin
case ElKind of
revskEnum: Result:='enum range';
revskInt: Result:='integer range';
revskChar: Result:='char range';
revskBool: Result:='boolean range';
else
Result:='integer range';
end;
end;
{ TResEvalSet }
constructor TResEvalSet.Create;
@ -5980,6 +6084,11 @@ begin
Result:=Result+']';
end;
function TResEvalSet.TypeAsString: string;
begin
Result:='set';
end;
function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean;
{$IF FPC_FULLVERSION<30101}

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

@ -1698,6 +1698,7 @@ type
procedure FinishAncestors(aClass: TPasClassType); virtual;
procedure FinishMethodResolution(El: TPasMethodResolution); virtual;
procedure FinishAttributes(El: TPasAttributes); virtual;
procedure FinishExportSymbol(El: TPasExportSymbol); virtual;
procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual;
procedure FinishPropertyParamAccess(Params: TParamsExpr;
Prop: TPasProperty); virtual;
@ -5826,6 +5827,7 @@ begin
FinishSection(TPasLibrary(CurModule).LibrarySection);
// resolve begin..end block
ResolveImplBlock(CurModule.InitializationSection);
ResolveImplBlock(CurModule.FinalizationSection);
end
else if (CurModuleClass=TPasModule) then
begin
@ -7776,6 +7778,8 @@ begin
FinishMethodResolution(TPasMethodResolution(El))
else if C=TPasAttributes then
FinishAttributes(TPasAttributes(El))
else if C=TPasExportSymbol then
FinishExportSymbol(TPasExportSymbol(El))
else
begin
{$IFDEF VerbosePasResolver}
@ -9133,6 +9137,31 @@ begin
end;
end;
procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol);
procedure CheckExpExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string);
var
Value: TResEvalValue;
ResolvedEl: TPasResolverResult;
begin
if Expr=nil then exit;
ResolveExpr(Expr,rraRead);
Value:=Eval(Expr,[refConst]);
if (Value<>nil) and (Value.Kind in Kinds) then
begin
ReleaseEvalValue(Value);
exit;
end;
ReleaseEvalValue(Value);
ComputeElement(Expr,ResolvedEl,[rcConstant]);
RaiseXExpectedButYFound(20210101194628,Expected,GetTypeDescription(ResolvedEl),Expr);
end;
begin
CheckExpExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
CheckExpExpr(El.ExportName,[revkString,revkUnicodeString],'string');
end;
procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType;
Params: TParamsExpr);
var
@ -20836,6 +20865,7 @@ begin
else if AClass.InheritsFrom(TPasImplBlock) then
// resolved when finished
else if AClass=TPasAttributes then
else if AClass=TPasExportSymbol then
else if AClass=TPasUnresolvedUnitRef then
RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
else

1
packages/fcl-passrc/src/pastree.pp
View File

@ -447,6 +447,7 @@ type
PackageName: string;
Filename : String; // the IN filename, only written when not empty.
end;
TPasModuleClass = class of TPasModule;
{ TPasUnitModule }

1
packages/fcl-passrc/src/pparser.pp
View File

@ -4360,6 +4360,7 @@ begin
end;
if not (CurToken in [tkComma,tkSemicolon]) then
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
Engine.FinishScope(stDeclaration,E);
until (CurToken=tkSemicolon);
end;

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

@ -142,7 +142,9 @@ type
Procedure TearDown; override;
procedure CreateEngine(var TheEngine: TPasTreeContainer); override;
procedure ParseModule; override;
procedure ParseMain(ExpectedModuleClass: TPasModuleClass); virtual;
procedure ParseProgram; virtual;
procedure ParseLibrary; virtual;
procedure ParseUnit; virtual;
procedure CheckReferenceDirectives; virtual;
procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer;
@ -172,6 +174,7 @@ type
ImplementationSrc: string): TTestEnginePasResolver;
procedure AddSystemUnit(Parts: TSystemUnitParts = []);
procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []);
procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []);
procedure StartUnit(NeedSystemUnit: boolean);
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
property ModuleCount: integer read GetModuleCount;
@ -975,6 +978,15 @@ type
Procedure TestAttributes_NonConstParam_Fail;
Procedure TestAttributes_UnknownAttrWarning;
Procedure TestAttributes_Members;
// library
Procedure TestLibrary_Empty;
Procedure TestLibrary_ExportFunc;
Procedure TestLibrary_ExportFunc_NameIntFail;
Procedure TestLibrary_ExportFunc_IndexStringFail;
Procedure TestLibrary_ExportVar; // ToDo
Procedure TestLibrary_Initialization_Finalization;
// ToDo Procedure TestLibrary_UnitExports;
end;
function LinesToStr(Args: array of const): string;
@ -1193,7 +1205,7 @@ begin
end;
end;
procedure TCustomTestResolver.ParseProgram;
procedure TCustomTestResolver.ParseMain(ExpectedModuleClass: TPasModuleClass);
var
aFilename: String;
aRow, aCol: Integer;
@ -1208,7 +1220,7 @@ begin
aRow:=E.Row;
aCol:=E.Column;
WriteSources(aFilename,aRow,aCol);
writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message,
writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Parser: '+E.ClassName+':'+E.Message,
' Scanner at'
+' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
+' Line="'+Scanner.CurLine+'"');
@ -1225,17 +1237,22 @@ begin
ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol);
end;
WriteSources(aFilename,aRow,aCol);
writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message
writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' PasResolver: '+E.ClassName+':'+E.Message
+' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')');
Fail(E.Message);
end;
on E: Exception do
begin
writeln('ERROR: TTestResolver.ParseProgram Exception: '+E.ClassName+':'+E.Message);
writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Exception: '+E.ClassName+':'+E.Message);
Fail(E.Message);
end;
end;
TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine);
end;
procedure TCustomTestResolver.ParseProgram;
begin
ParseMain(TPasProgram);
AssertEquals('Has program',TPasProgram,Module.ClassType);
AssertNotNull('Has program section',PasProgram.ProgramSection);
AssertNotNull('Has initialization section',PasProgram.InitializationSection);
@ -1245,39 +1262,18 @@ begin
CheckReferenceDirectives;
end;
procedure TCustomTestResolver.ParseLibrary;
begin
ParseMain(TPasLibrary);
AssertEquals('Has library',TPasLibrary,Module.ClassType);
AssertNotNull('Has library section',PasLibrary.LibrarySection);
AssertNotNull('Has initialization section',PasLibrary.InitializationSection);
CheckReferenceDirectives;
end;
procedure TCustomTestResolver.ParseUnit;
begin
FFirstStatement:=nil;
try
ParseModule;
except
on E: EParserError do
begin
writeln('ERROR: TTestResolver.ParseUnit Parser: '+E.ClassName+':'+E.Message
+' File='+Scanner.CurFilename
+' LineNo='+IntToStr(Scanner.CurRow)
+' Col='+IntToStr(Scanner.CurColumn)
+' Line="'+Scanner.CurLine+'"'
);
Fail(E.Message);
end;
on E: EPasResolve do
begin
writeln('ERROR: TTestResolver.ParseUnit PasResolver: '+E.ClassName+':'+E.Message
+' File='+Scanner.CurFilename
+' LineNo='+IntToStr(Scanner.CurRow)
+' Col='+IntToStr(Scanner.CurColumn)
+' Line="'+Scanner.CurLine+'"'
);
Fail(E.Message);
end;
on E: Exception do
begin
writeln('ERROR: TTestResolver.ParseUnit Exception: '+E.ClassName+':'+E.Message);
Fail(E.Message);
end;
end;
TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine);
ParseMain(TPasModule);
AssertEquals('Has unit',TPasModule,Module.ClassType);
AssertNotNull('Has interface section',Module.InterfaceSection);
AssertNotNull('Has implementation section',Module.ImplementationSection);
@ -2333,6 +2329,16 @@ begin
Add('program '+ExtractFileUnitName(MainFilename)+';');
end;
procedure TCustomTestResolver.StartLibrary(NeedSystemUnit: boolean;
SystemUnitParts: TSystemUnitParts);
begin
if NeedSystemUnit then
AddSystemUnit(SystemUnitParts)
else
Parser.ImplicitUses.Clear;
Add('library '+ExtractFileUnitName(MainFilename)+';');
end;
procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean);
begin
if NeedSystemUnit then
@ -3623,7 +3629,7 @@ begin
' m=low(char)+high(char);',
' n = string(''A'');',
' o = UnicodeString(''A'');',
//' p = ^C''bird'';',
' p = ^C''bird'';',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;
@ -18738,6 +18744,95 @@ begin
CheckAttributeMarkers;
end;
procedure TTestResolver.TestLibrary_Empty;
begin
StartLibrary(false);
Add(['begin']);
ParseLibrary;
end;
procedure TTestResolver.TestLibrary_ExportFunc;
begin
StartLibrary(false);
Add([
'procedure Run;',
'begin',
'end;',
'procedure Fly;',
'begin',
'end;',
'exports',
' Run,',
' Fly name ''FlyHi'';',
'exports',
' Run index 3+4;',
'begin',
'']);
ParseLibrary;
end;
procedure TTestResolver.TestLibrary_ExportFunc_NameIntFail;
begin
StartLibrary(false);
Add([
'procedure Run;',
'begin',
'end;',
'exports',
' Run name 4;',
'begin',
'']);
CheckResolverException('string expected, but Longint found',nXExpectedButYFound);
end;
procedure TTestResolver.TestLibrary_ExportFunc_IndexStringFail;
begin
StartLibrary(false);
Add([
'procedure Run;',
'begin',
'end;',
'exports',
' Run index ''abc'';',
'begin',
'']);
CheckResolverException('integer expected, but String found',nXExpectedButYFound);
end;
procedure TTestResolver.TestLibrary_ExportVar;
begin
exit;
StartLibrary(false);
Add([
'var',
' Size: word; export name ''size'';',
'exports',
' Size,',
' Fly as ''FlyHi'',',
' Run index 3+4;',
'begin',
'']);
ParseLibrary;
end;
procedure TTestResolver.TestLibrary_Initialization_Finalization;
begin
StartLibrary(false);
Add([
'procedure Run(w: word);',
'begin',
'end;',
'exports',
' Run;',
'initialization',
' Run(3);',
'finalization',
' Run(4);',
'']);
ParseLibrary;
end;
initialization
RegisterTests([TTestResolver]);