fcl-passrc: fixed mode delphi static array of char = string literal, started $warn directive

git-svn-id: trunk@39313 -

packages/fcl-passrc/src/pasresolver.pp

@@ -17823,7 +17823,7 @@ function TPasResolver.CheckAssignCompatibilityArrayType(const LHS,
           exit;
           end;
         end
-      else if IsArrayOperatorAdd(Expr) then
+      else if IsArrayOperatorAdd(Expr) and not (Values.BaseType in btAllStrings) then
         begin
         // a:=left+right
         if length(ArrType.Ranges)>0 then

packages/fcl-passrc/src/pscanner.pp

@@ -53,6 +53,7 @@ const
   nLogMacroDefined = 1026; // FPC=3101
   nLogMacroUnDefined = 1027; // FPC=3102
   nWarnIllegalCompilerDirectiveX = 1028;
+  nIllegalStateForWarnDirective = 1027;
 
 // resourcestring patterns of messages
 resourcestring
@@ -77,13 +78,14 @@ resourcestring
   SErrInvalidMode = 'Invalid mode: "%s"';
   SErrInvalidModeSwitch = 'Invalid mode switch: "%s"';
   SErrXExpectedButYFound = '"%s" expected, but "%s" found';
-  sErrRangeCheck = 'range check failed';
-  sErrDivByZero = 'division by zero';
-  sErrOperandAndOperatorMismatch = 'operand and operator mismatch';
+  SErrRangeCheck = 'range check failed';
+  SErrDivByZero = 'division by zero';
+  SErrOperandAndOperatorMismatch = 'operand and operator mismatch';
   SUserDefined = 'User defined: "%s"';
-  sLogMacroDefined = 'Macro defined: %s';
-  sLogMacroUnDefined = 'Macro undefined: %s';
-  sWarnIllegalCompilerDirectiveX = 'Illegal compiler directive "%s"';
+  SLogMacroDefined = 'Macro defined: %s';
+  SLogMacroUnDefined = 'Macro undefined: %s';
+  SWarnIllegalCompilerDirectiveX = 'Illegal compiler directive "%s"';
+  SIllegalStateForWarnDirective = 'Illegal state "%s" for $WARN directive';
 
 type
   TMessageType = (
@@ -354,6 +356,14 @@ const
   vsAllValueSwitches = [low(TValueSwitch)..high(TValueSwitch)];
   DefaultVSInterfaces = 'com';
 
+type
+  TWarnMsgState = (
+    wmsDefault,
+    wmsOn,
+    wmsOff,
+    wmsError
+  );
+
 type
   TTokenOption = (toForceCaret,toOperatorToken);
   TTokenOptions = Set of TTokenOption;
@@ -599,6 +609,13 @@ type
   TPScannerFormatPathEvent = function(const aPath: string): string of object;
 
   TPascalScanner = class
+  private
+    type
+      TWarnMsgNumberState = record
+        Number: integer;
+        State: TWarnMsgState;
+      end;
+      TWarnMsgNumberStateArr = array of TWarnMsgNumberState;
   private
     FAllowedBoolSwitches: TBoolSwitches;
     FAllowedModes: TModeSwitches;
@@ -641,6 +658,7 @@ type
     FTokenStr: PChar;
     FIncludeStack: TFPList;
     FFiles: TStrings;
+    FWarnMsgStates: TWarnMsgNumberStateArr;
 
     // Preprocessor $IFxxx skipping data
     PPSkipMode: TPascalScannerPPSkipMode;
@@ -652,6 +670,7 @@ type
     function GetCurrentValueSwitch(V: TValueSwitch): string;
     function GetForceCaret: Boolean;
     function GetMacrosOn: boolean;
+    function IndexOfWarnMsgState(Number: integer; InsertPos: boolean): integer;
     function OnCondEvalFunction(Sender: TCondDirectiveEvaluator; Name,
       Param: String; out Value: string): boolean;
     procedure OnCondEvalLog(Sender: TCondDirectiveEvaluator;
@@ -690,12 +709,14 @@ type
     procedure HandleError(Param: String); virtual;
     procedure HandleMessageDirective(Param: String); virtual;
     procedure HandleIncludeFile(Param: String); virtual;
-    procedure HandleUnDefine(Param: String);virtual;
-    function HandleInclude(const Param: String): TToken;virtual;
-    procedure HandleMode(const Param: String);virtual;
-    procedure HandleModeSwitch(const Param: String);virtual;
-    function HandleMacro(AIndex: integer): TToken;virtual;
-    procedure HandleInterfaces(const Param: String);virtual;
+    procedure HandleUnDefine(Param: String); virtual;
+    function HandleInclude(const Param: String): TToken; virtual;
+    procedure HandleMode(const Param: String); virtual;
+    procedure HandleModeSwitch(const Param: String); virtual;
+    function HandleMacro(AIndex: integer): TToken; virtual;
+    procedure HandleInterfaces(const Param: String); virtual;
+    procedure HandleWarn(Param: String); virtual;
+    procedure HandleWarnIdentifier(IdentifierLoCase, ValueLoCase: String); virtual;
     procedure PushStackItem; virtual;
     function DoFetchTextToken: TToken;
     function DoFetchToken: TToken;
@@ -705,6 +726,8 @@ type
     procedure SetCurrentBoolSwitches(const AValue: TBoolSwitches); virtual;
     procedure SetCurrentModeSwitches(AValue: TModeSwitches); virtual;
     procedure SetCurrentValueSwitch(V: TValueSwitch; const AValue: string);
+    procedure SetWarnMsgState(Number: integer; State: TWarnMsgState); virtual;
+    function GetWarnMsgState(Number: integer): TWarnMsgState; virtual;
     function LogEvent(E : TPScannerLogEvent) : Boolean; inline;
   public
     constructor Create(AFileResolver: TBaseFileResolver);
@@ -757,6 +780,7 @@ type
     property AllowedValueSwitches: TValueSwitches read FAllowedValueSwitches Write SetAllowedValueSwitches;
     property ReadOnlyValueSwitches: TValueSwitches read FReadOnlyValueSwitches Write SetReadOnlyValueSwitches;// cannot be changed by code
     property CurrentValueSwitch[V: TValueSwitch]: string read GetCurrentValueSwitch Write SetCurrentValueSwitch;
+    property WarnMsgState[Number: integer]: TWarnMsgState read GetWarnMsgState write SetWarnMsgState;
     property Options : TPOptions read FOptions write SetOptions;
     Property SkipWhiteSpace : Boolean Read FSkipWhiteSpace Write FSkipWhiteSpace;
     Property SkipComments : Boolean Read FSkipComments Write FSkipComments;
@@ -2777,6 +2801,79 @@ begin
   CurrentValueSwitch[vsInterfaces]:=NewValue;
 end;
 
+procedure TPascalScanner.HandleWarn(Param: String);
+// $warn identifier on|off|default|error
+var
+  p, StartPos: Integer;
+  Identifier, Value: String;
+begin
+  Param:=lowercase(Param);
+  p:=1;
+  while (p<=length(Param)) and (Param[p] in [' ',#9]) do inc(p);
+  StartPos:=p;
+  while (p<=length(Param)) and (Param[p] in ['a'..'z','0'..'9','_']) do inc(p);
+  Identifier:=copy(Param,StartPos,p-StartPos);
+  while (p<=length(Param)) and (Param[p] in [' ',#9]) do inc(p);
+  StartPos:=p;
+  while (p<=length(Param)) and (Param[p] in ['a'..'z']) do inc(p);
+  Value:=copy(Param,StartPos,p-StartPos);
+  HandleWarnIdentifier(Identifier,Value);
+end;
+
+procedure TPascalScanner.HandleWarnIdentifier(IdentifierLoCase,
+  ValueLoCase: String);
+var
+  Number: LongInt;
+  State: TWarnMsgState;
+begin
+  if IdentifierLoCase='' then
+    Error(nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,['']);
+  if IdentifierLoCase[1] in ['0'..'9'] then
+    begin
+    // fpc number
+    Number:=StrToIntDef(IdentifierLoCase,-1);
+    if Number<0 then
+      begin
+      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[IdentifierLoCase]);
+      exit;
+      end;
+    end
+  else if (IdentifierLoCase[1]='w') and (msDelphi in CurrentModeSwitches) then
+    begin
+    // delphi W number
+    Number:=StrToIntDef(copy(IdentifierLoCase,2,10),-1);
+    if Number<0 then
+      begin
+      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[IdentifierLoCase]);
+      exit;
+      end;
+    Number:=-1;
+    end
+  else
+    begin
+    DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[IdentifierLoCase]);
+    exit;
+    end;
+
+  if ValueLoCase='' then
+    begin
+    DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,['']);
+    exit;
+    end;
+  case ValueLoCase of
+  'on': State:=wmsOn;
+  'off': State:=wmsOff;
+  'default': State:=wmsDefault;
+  'error': State:=wmsError;
+  else
+    DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[ValueLoCase]);
+    exit;
+  end;
+
+  if Number>=0 then
+    SetWarnMsgState(Number,State);
+end;
+
 procedure TPascalScanner.HandleDefine(Param: String);
 
 Var
@@ -3193,6 +3290,8 @@ begin
           DoBoolDirective(bsTypeInfo);
         'UNDEF':
           HandleUnDefine(Param);
+        'WARN':
+          HandleWarn(Param);
         'WARNING':
           DoLog(mtWarning,nUserDefined,SUserDefined,[Param]);
         'WARNINGS':
@@ -3755,6 +3854,34 @@ begin
   Result:=bsMacro in FCurrentBoolSwitches;
 end;
 
+function TPascalScanner.IndexOfWarnMsgState(Number: integer; InsertPos: boolean
+  ): integer;
+var
+  l, r, m, CurNumber: Integer;
+begin
+  l:=0;
+  r:=length(FWarnMsgStates)-1;
+  m:=0;
+  while l<=r do
+    begin
+    m:=(l+r) div 2;
+    CurNumber:=FWarnMsgStates[m].Number;
+    if Number>CurNumber then
+      l:=m+1
+    else if Number<CurNumber then
+      r:=m-1
+    else
+      exit(m);
+    end;
+  if not InsertPos then
+    exit(-1);
+  if length(FWarnMsgStates)=0 then
+    exit(0);
+  if (m<length(FWarnMsgStates)) and (FWarnMsgStates[m].Number<=Number) then
+    inc(m);
+  Result:=m;
+end;
+
 function TPascalScanner.OnCondEvalFunction(Sender: TCondDirectiveEvaluator;
   Name, Param: String; out Value: string): boolean;
 begin
@@ -3922,6 +4049,70 @@ begin
   FCurrentValueSwitches[V]:=AValue;
 end;
 
+procedure TPascalScanner.SetWarnMsgState(Number: integer; State: TWarnMsgState);
+
+  {$IF FPC_FULLVERSION<30101}
+  procedure Delete(var A: TWarnMsgNumberStateArr; Index, Count: integer); overload;
+  var
+    i: Integer;
+  begin
+    if Index<0 then
+      Error(nErrDivByZero,'[20180627142123]');
+    if Index+Count>length(A) then
+      Error(nErrDivByZero,'[20180627142127]');
+    for i:=Index+Count to length(A)-1 do
+      A[i-Count]:=A[i];
+    SetLength(A,length(A)-Count);
+  end;
+
+  procedure Insert(Item: TWarnMsgNumberState; var A: TWarnMsgNumberStateArr; Index: integer); overload;
+  var
+    i: Integer;
+  begin
+    if Index<0 then
+      Error(nErrDivByZero,'[20180627142133]');
+    if Index>length(A) then
+      Error(nErrDivByZero,'[20180627142137]');
+    SetLength(A,length(A)+1);
+    for i:=length(A)-1 downto Index+1 do
+      A[i]:=A[i-1];
+    A[Index]:=Item;
+  end;
+  {$ENDIF}
+
+var
+  i: Integer;
+  Item: TWarnMsgNumberState;
+begin
+  i:=IndexOfWarnMsgState(Number,true);
+  if (i<length(FWarnMsgStates)) and (FWarnMsgStates[i].Number=Number) then
+    begin
+    // already exists
+    if State=wmsDefault then
+      Delete(FWarnMsgStates,i,1)
+    else
+      FWarnMsgStates[i].State:=State;
+    end
+  else if State<>wmsDefault then
+    begin
+    // new state
+    Item.Number:=Number;
+    Item.State:=State;
+    Insert(Item,FWarnMsgStates,i);
+    end;
+end;
+
+function TPascalScanner.GetWarnMsgState(Number: integer): TWarnMsgState;
+var
+  i: Integer;
+begin
+  i:=IndexOfWarnMsgState(Number,false);
+  if i<0 then
+    Result:=wmsDefault
+  else
+    Result:=FWarnMsgStates[i].State;
+end;
+
 procedure TPascalScanner.SetMacrosOn(const AValue: boolean);
 begin
   if AValue then

packages/fcl-passrc/tests/tcresolver.pas

@@ -682,6 +682,7 @@ type
     Procedure TestDynArrayOfLongint;
     Procedure TestStaticArray;
     Procedure TestStaticArrayOfChar;
+    Procedure TestStaticArrayOfCharDelphi;
     Procedure TestStaticArrayOfRangeElCheckFail;
     Procedure TestArrayOfArray;
     Procedure TestArrayOfArray_NameAnonymous;
@@ -801,6 +802,7 @@ type
     Procedure TestHint_ElementHints;
     Procedure TestHint_ElementHintsMsg;
     Procedure TestHint_ElementHintsAlias;
+    Procedure TestHint_ElementHints_WarnOff_SymbolDeprecated;
 
     // attributes
     Procedure TestAttributes_Ignore;
@@ -11795,19 +11797,44 @@ procedure TTestResolver.TestStaticArrayOfChar;
 begin
   ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF8;
   StartProgram(false);
-  Add('type');
-  Add('  TArrA = array[1..3] of char;');
-  Add('const');
-  Add('  A: TArrA = (''p'',''a'',''p'');'); // duplicate allowed, this bracket is not a set
-  Add('  B: TArrA = ''pas'';');
-  Add('  Three = length(TArrA);');
-  Add('  C: array[1..Three] of char = ''pas'';');
-  Add('  D = ''pp'';');
-  Add('  E: array[length(D)..Three] of char = D;');
-  Add('  F: array[1..2] of widechar = ''äö'';');
-  Add('  G: array[1..2] of char = ''ä'';');
-  Add('  H: array[1..4] of char = ''äö'';');
-  Add('begin');
+  Add([
+  'type',
+  '  TArrA = array[1..3] of char;',
+  'const',
+  '  A: TArrA = (''p'',''a'',''p'');', // duplicate allowed, this bracket is not a set
+  '  B: TArrA = ''pas'';',
+  '  Three = length(TArrA);',
+  '  C: array[1..Three] of char = ''pas'';',
+  '  D = ''pp'';',
+  '  E: array[length(D)..Three] of char = D;',
+  '  F: array[1..2] of widechar = ''äö'';',
+  '  G: array[1..2] of char = ''ä'';',
+  '  H: array[1..4] of char = ''äö'';',
+  '  I: array[1..4] of char = ''ä''+''ö'';',
+  'begin']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestStaticArrayOfCharDelphi;
+begin
+  ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF8;
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TArrA = array[1..3] of char;',
+  'const',
+  '  A: TArrA = (''p'',''a'',''p'');', // duplicate allowed, this bracket is not a set
+  '  B: TArrA = ''pas'';',
+  '  Three = length(TArrA);',
+  '  C: array[1..Three] of char = ''pas'';',
+  '  D = ''pp'';',
+  '  E: array[length(D)..Three] of char = D;',
+  '  F: array[1..2] of widechar = ''äö'';',
+  '  G: array[1..2] of char = ''ä'';',
+  '  H: array[1..4] of char = ''äö'';',
+  '  I: array[1..4] of char = ''ä''+''ö'';',
+  'begin']);
   ParseProgram;
 end;
 
@@ -14184,7 +14211,7 @@ begin
   'begin',
   '']);
   ParseProgram;
-  WriteSources('afile.pp',3,4);
+  //WriteSources('afile.pp',3,4);
 
   aMarker:=FirstSrcMarker;
   while aMarker<>nil do
@@ -14197,6 +14224,20 @@ begin
   CheckResolverUnexpectedHints(true);
 end;
 
+procedure TTestResolver.TestHint_ElementHints_WarnOff_SymbolDeprecated;
+begin
+  exit;  // ToDo
+  StartProgram(false);
+  Add([
+  '{$warn symbol_deprecated off}',
+  'type',
+  '  i: byte; deprecated;',
+  'begin',
+  '']);
+  ParseProgram;
+  CheckResolverUnexpectedHints(true);
+end;
+
 procedure TTestResolver.TestAttributes_Ignore;
 begin
   StartProgram(false);