fcl-passrc: resolver: parse library

git-svn-id: trunk@47936 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -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}

packages/fcl-passrc/src/pasresolver.pp

@@ -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

packages/fcl-passrc/src/pastree.pp

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

packages/fcl-passrc/src/pparser.pp

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

packages/fcl-passrc/tests/tcresolver.pas

@@ -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]);