fcl-passrc: $warn directive

git-svn-id: trunk@39315 -

packages/fcl-passrc/src/pasresolver.pp

@@ -263,7 +263,7 @@ unit PasResolver;
 interface
 
 uses
-  Classes, SysUtils, Math, contnrs,
+  Classes, SysUtils, Math, Types, contnrs,
   PasTree, PScanner, PParser, PasResolveEval;
 
 const
@@ -1232,6 +1232,8 @@ type
       OnlyScope: TPasScope): TPasProcedure;
   protected
     procedure SetCurrentParser(AValue: TPasParser); override;
+    procedure ScannerWarnDirective(Sender: TObject; Identifier: string;
+      State: TWarnMsgState; var Handled: boolean); virtual;
     procedure SetRootElement(const AValue: TPasModule); virtual;
     procedure CheckTopScope(ExpectedClass: TPasScopeClass; AllowDescendants: boolean = false);
     function AddIdentifier(Scope: TPasIdentifierScope;
@@ -1602,6 +1604,8 @@ type
       Const Fmt : String; Args : Array of const; PosEl: TPasElement);
     procedure LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer;
       const Fmt: String; Args: Array of const; PosEl: TPasElement); overload;
+    class function GetWarnIdentifierNumbers(Identifier: string;
+      out MsgNumbers: TIntegerDynArray): boolean; virtual;
     procedure GetIncompatibleTypeDesc(const GotType, ExpType: TPasResolverResult;
       out GotDesc, ExpDesc: String); overload;
     procedure GetIncompatibleTypeDesc(const GotType, ExpType: TPasType;
@@ -4225,7 +4229,23 @@ begin
   Clear;
   inherited SetCurrentParser(AValue);
   if CurrentParser<>nil then
+    begin
     CurrentParser.Options:=CurrentParser.Options+po_Resolver;
+    if (CurrentParser.Scanner<>nil) and (CurrentParser.Scanner.OnWarnDirective=nil) then
+      CurrentParser.Scanner.OnWarnDirective:=@ScannerWarnDirective;
+    end;
+end;
+
+procedure TPasResolver.ScannerWarnDirective(Sender: TObject;
+  Identifier: string; State: TWarnMsgState; var Handled: boolean);
+var
+  MsgNumbers: TIntegerDynArray;
+  i: Integer;
+begin
+  if not GetWarnIdentifierNumbers(Identifier,MsgNumbers) then exit;
+  Handled:=true;
+  for i:=0 to length(MsgNumbers)-1 do
+    TPascalScanner(Sender).WarnMsgState[MsgNumbers[i]]:=State;
 end;
 
 procedure TPasResolver.CheckTopScope(ExpectedClass: TPasScopeClass;
@@ -15232,11 +15252,44 @@ end;
 procedure TPasResolver.LogMsg(const id: int64; MsgType: TMessageType;
   MsgNumber: integer; const Fmt: String; Args: array of const;
   PosEl: TPasElement);
+var
+  Scanner: TPascalScanner;
+  State: TWarnMsgState;
+  {$IFDEF VerbosePasResolver}
+  s: String;
+  {$ENDIF}
 begin
-  if (FStep<prsFinishingModule)
-      and (CurrentParser.Scanner<>nil)
-      and (CurrentParser.Scanner.IgnoreMsgType(MsgType)) then
-    exit; // during parsing consider directives like $Hints on|off
+  Scanner:=CurrentParser.Scanner;
+  if (Scanner<>nil) then
+    begin
+    if (FStep<prsFinishingModule)
+        and (Scanner.IgnoreMsgType(MsgType)) then
+      exit; // during parsing consider directives like $Hints on|off
+    if MsgType>=mtWarning then
+      begin
+      State:=Scanner.WarnMsgState[MsgNumber];
+      case State of
+      wmsOff:
+        begin
+        {$IFDEF VerbosePasResolver}
+        {AllowWriteln}
+        write('TPasResolver.LogMsg ignoring ',id,' ',GetElementSourcePosStr(PosEl),' ');
+        s:='';
+        str(MsgType,s);
+        write(s);
+        writeln(': [',MsgNumber,'] ',SafeFormat(Fmt,Args));
+        {AllowWriteln-}
+        {$ENDIF}
+        exit; // ignore
+        end;
+      wmsError:
+        begin
+        RaiseMsg(id,MsgNumber,Fmt,Args,PosEl);
+        exit;
+        end;
+      end;
+      end;
+    end;
 
   SetLastMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl);
   if Assigned(OnLog) then
@@ -15245,6 +15298,53 @@ begin
     CurrentParser.OnLog(Self,FLastMsg);
 end;
 
+class function TPasResolver.GetWarnIdentifierNumbers(Identifier: string; out
+  MsgNumbers: TIntegerDynArray): boolean;
+
+  procedure SetNumber(Number: integer);
+  begin
+    {$IF FPC_FULLVERSION>=30101}
+    MsgNumbers:=[Number];
+    {$ELSE}
+    Setlength(MsgNumbers,1);
+    MsgNumbers[0]:=Number;
+    {$ENDIF}
+  end;
+
+begin
+  if Identifier='' then exit(false);
+  if Identifier[1] in ['0'..'9'] then exit(false);
+
+  Result:=true;
+  case UpperCase(Identifier) of
+  // FPC:
+  'CONSTRUCTING_ABSTRACT': SetNumber(nConstructingClassXWithAbstractMethodY); //  Constructing an instance of a class with abstract methods.
+  //'IMPLICIT_VARIANTS': ; //  Implicit use of the variants unit.
+  // useanalyzer: 'NO_RETVAL': ; // Function result is not set.
+  'SYMBOL_DEPRECATED': SetNumber(nSymbolXIsDeprecated); //   Deprecated symbol.
+  'SYMBOL_EXPERIMENTAL': SetNumber(nSymbolXIsExperimental); //   Experimental symbol
+  'SYMBOL_LIBRARY': SetNumber(nSymbolXBelongsToALibrary); //   Not used.
+  'SYMBOL_PLATFORM': SetNumber(nSymbolXIsNotPortable); //   Platform-dependent symbol.
+  'SYMBOL_UNIMPLEMENTED': SetNumber(nSymbolXIsNotImplemented); //   Unimplemented symbol.
+  //'UNIT_DEPRECATED': ; //   Deprecated unit.
+  //'UNIT_EXPERIMENTAL': ; //   Experimental unit.
+  //'UNIT_LIBRARY': ; //
+  //'UNIT_PLATFORM': ; //   Platform dependent unit.
+  //'UNIT_UNIMPLEMENTED': ; //   Unimplemented unit.
+  //'ZERO_NIL_COMPAT': ; //   Converting 0 to NIL
+  //'IMPLICIT_STRING_CAST': ; // Implicit string type conversion
+  //'IMPLICIT_STRING_CAST_LOSS': ; // Implicit string typecast with potential data loss from ”$1” to ”$2”
+  //'EXPLICIT_STRING_CAST': ; //   Explicit string type conversion
+  //'EXPLICIT_STRING_CAST_LOSS': ; //   Explicit string typecast with potential data loss from ”$1” to ”$2”
+  //'CVT_NARROWING_STRING_LOST': ; //   Unicode constant cast with potential data loss
+
+  // Delphi:
+  'HIDDEN_VIRTUAL': SetNumber(nMethodHidesMethodOfBaseType); // method hides virtual method of ancestor
+  else
+    Result:=false;
+  end;
+end;
+
 procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
   ExpType: TPasResolverResult; out GotDesc, ExpDesc: String);
 begin

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -44,7 +44,7 @@ unit PasUseAnalyzer;
 interface
 
 uses
-  Classes, SysUtils, AVL_Tree,
+  Classes, SysUtils, Types, AVL_Tree,
   PasTree, PScanner, PasResolveEval, PasResolver;
 
 const
@@ -247,9 +247,11 @@ type
     function IsExport(El: TPasElement): boolean;
     function IsIdentifier(El: TPasElement): boolean;
     function IsImplBlockEmpty(El: TPasImplBlock): boolean;
-    procedure EmitMessage(const Id: int64; const MsgType: TMessageType;
+    procedure EmitMessage(Id: int64; MsgType: TMessageType;
       MsgNumber: integer; Fmt: String; const Args: array of const; PosEl: TPasElement);
     procedure EmitMessage(Msg: TPAMessage);
+    class function GetWarnIdentifierNumbers(Identifier: string;
+      out MsgNumbers: TIntegerDynArray): boolean; virtual;
     function GetUsedElements: TFPList; virtual; // list of TPAElement
     property OnMessage: TPAMessageEvent read FOnMessage write FOnMessage;
     property Options: TPasAnalyzerOptions read FOptions write SetOptions;
@@ -2469,19 +2471,21 @@ begin
   Result:=false;
 end;
 
-procedure TPasAnalyzer.EmitMessage(const Id: int64;
-  const MsgType: TMessageType; MsgNumber: integer; Fmt: String;
-  const Args: array of const; PosEl: TPasElement);
+procedure TPasAnalyzer.EmitMessage(Id: int64; MsgType: TMessageType;
+  MsgNumber: integer; Fmt: String; const Args: array of const;
+  PosEl: TPasElement);
 var
   Msg: TPAMessage;
   El: TPasElement;
   ProcScope: TPasProcedureScope;
   ModScope: TPasModuleScope;
+  Scanner: TPascalScanner;
+  State: TWarnMsgState;
 begin
   {$IFDEF VerbosePasAnalyzer}
   //writeln('TPasAnalyzer.EmitMessage [',Id,'] ',MsgType,': (',MsgNumber,') Fmt={',Fmt,'} PosEl='+GetElModName(PosEl));
   {$ENDIF}
-  if MsgType in [mtHint,mtNote,mtWarning] then
+  if MsgType>=mtWarning then
     begin
     El:=PosEl;
     while El<>nil do
@@ -2510,6 +2514,25 @@ begin
         end;
       El:=El.Parent;
       end;
+    if (Resolver<>nil) and (Resolver.CurrentParser<>nil) then
+      begin
+      Scanner:=Resolver.CurrentParser.Scanner;
+      if Scanner<>nil then
+        begin
+        State:=Scanner.WarnMsgState[MsgNumber];
+        case State of
+        wmsOff:
+          begin
+          {$IFDEF VerbosePasAnalyzer}
+          writeln('TPasAnalyzer.EmitMessage ignoring [',Id,'] ',MsgType,': (',MsgNumber,') Fmt={',Fmt,'} PosEl='+GetElModName(PosEl));
+          {$ENDIF}
+          exit;
+          end;
+        wmsError:
+          MsgType:=mtError;
+        end;
+        end;
+      end;
     end;
   Msg:=TPAMessage.Create;
   Msg.Id:=Id;
@@ -2541,6 +2564,32 @@ begin
   end;
 end;
 
+class function TPasAnalyzer.GetWarnIdentifierNumbers(Identifier: string; out
+  MsgNumbers: TIntegerDynArray): boolean;
+
+  procedure SetNumber(Number: integer);
+  begin
+    {$IF FPC_FULLVERSION>=30101}
+    MsgNumbers:=[Number];
+    {$ELSE}
+    Setlength(MsgNumbers,1);
+    MsgNumbers[0]:=Number;
+    {$ENDIF}
+  end;
+
+begin
+  if Identifier='' then exit(false);
+  if Identifier[1] in ['0'..'9'] then exit(false);
+
+  Result:=true;
+  case UpperCase(Identifier) of
+  // Delphi+FPC
+  'NO_RETVAL': SetNumber(nPAFunctionResultDoesNotSeemToBeSet); // Function result is not set.
+  else
+    Result:=false;
+  end;
+end;
+
 function TPasAnalyzer.GetUsedElements: TFPList;
 var
   Node: TAVLTreeNode;

packages/fcl-passrc/src/pscanner.pp

@@ -607,6 +607,7 @@ type
   TPScannerDirectiveEvent = procedure(Sender: TObject; Directive, Param: String;
     var Handled: boolean) of object;
   TPScannerFormatPathEvent = function(const aPath: string): string of object;
+  TPScannerWarnEvent = procedure(Sender: TObject; Identifier: string; State: TWarnMsgState; var Handled: boolean) of object;
 
   TPascalScanner = class
   private
@@ -645,6 +646,7 @@ type
     FOnEvalFunction: TCEEvalFunctionEvent;
     FOnEvalVariable: TCEEvalVarEvent;
     FOnFormatPath: TPScannerFormatPathEvent;
+    FOnWarnDirective: TPScannerWarnEvent;
     FOptions: TPOptions;
     FLogEvents: TPScannerLogEvents;
     FOnLog: TPScannerLogHandler;
@@ -716,7 +718,7 @@ type
     function HandleMacro(AIndex: integer): TToken; virtual;
     procedure HandleInterfaces(const Param: String); virtual;
     procedure HandleWarn(Param: String); virtual;
-    procedure HandleWarnIdentifier(IdentifierLoCase, ValueLoCase: String); virtual;
+    procedure HandleWarnIdentifier(Identifier, Value: String); virtual;
     procedure PushStackItem; virtual;
     function DoFetchTextToken: TToken;
     function DoFetchToken: TToken;
@@ -792,6 +794,7 @@ type
     property ConditionEval: TCondDirectiveEvaluator read FConditionEval;
     property OnEvalVariable: TCEEvalVarEvent read FOnEvalVariable write FOnEvalVariable;
     property OnEvalFunction: TCEEvalFunctionEvent read FOnEvalFunction write FOnEvalFunction;
+    property OnWarnDirective: TPScannerWarnEvent read FOnWarnDirective write FOnWarnDirective;
 
     property LastMsg: string read FLastMsg write FLastMsg;
     property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
@@ -2807,69 +2810,72 @@ 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);
+  while (p<=length(Param)) and (Param[p] in ['a'..'z','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);
+  while (p<=length(Param)) and (Param[p] in ['a'..'z','A'..'Z','_']) do inc(p);
   Value:=copy(Param,StartPos,p-StartPos);
   HandleWarnIdentifier(Identifier,Value);
 end;
 
-procedure TPascalScanner.HandleWarnIdentifier(IdentifierLoCase,
-  ValueLoCase: String);
+procedure TPascalScanner.HandleWarnIdentifier(Identifier,
+  Value: String);
 var
   Number: LongInt;
   State: TWarnMsgState;
+  Handled: Boolean;
 begin
-  if IdentifierLoCase='' then
+  if Identifier='' then
     Error(nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,['']);
-  if IdentifierLoCase[1] in ['0'..'9'] then
+  if Value='' then
+    begin
+    DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,['']);
+    exit;
+    end;
+  case lowercase(Value) of
+  'on': State:=wmsOn;
+  'off': State:=wmsOff;
+  'default': State:=wmsDefault;
+  'error': State:=wmsError;
+  else
+    DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[Value]);
+    exit;
+  end;
+
+  if Assigned(OnWarnDirective) then
+    begin
+    Handled:=false;
+    OnWarnDirective(Self,Identifier,State,Handled);
+    if Handled then
+      exit;
+    end;
+
+  if Identifier[1] in ['0'..'9'] then
     begin
     // fpc number
-    Number:=StrToIntDef(IdentifierLoCase,-1);
+    Number:=StrToIntDef(Identifier,-1);
     if Number<0 then
       begin
-      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[IdentifierLoCase]);
+      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[Identifier]);
       exit;
       end;
     end
-  else if (IdentifierLoCase[1]='w') and (msDelphi in CurrentModeSwitches) then
+  else if (Identifier[1] in ['w','W']) and (msDelphi in CurrentModeSwitches) then
     begin
     // delphi W number
-    Number:=StrToIntDef(copy(IdentifierLoCase,2,10),-1);
+    Number:=StrToIntDef(copy(Identifier,2,10),-1);
     if Number<0 then
       begin
-      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[IdentifierLoCase]);
+      DoLog(mtWarning,nIllegalStateForWarnDirective,SIllegalStateForWarnDirective,[Identifier]);
       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;

packages/fcl-passrc/tests/tcresolver.pas

@@ -14226,14 +14226,13 @@ end;
 
 procedure TTestResolver.TestHint_ElementHints_WarnOff_SymbolDeprecated;
 begin
-  exit;  // ToDo
   StartProgram(false);
   Add([
   '{$warn symbol_deprecated off}',
-  'type',
-  '  i: byte; deprecated;',
+  'var',
+  '  i: byte deprecated;',
   'begin',
-  '']);
+  '  if i=3 then ;']);
   ParseProgram;
   CheckResolverUnexpectedHints(true);
 end;

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -91,6 +91,7 @@ type
     procedure TestM_Hint_UnitUsed;
     procedure TestM_Hint_UnitUsedVarArgs;
     procedure TestM_Hint_ParameterNotUsed;
+    procedure TestM_Hint_ParameterNotUsedOff;
     procedure TestM_Hint_ParameterInOverrideNotUsed;
     procedure TestM_Hint_ParameterAssignedButNotReadVarParam;
     procedure TestM_Hint_ParameterNotUsed_Abstract;
@@ -1394,6 +1395,18 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_Hint_ParameterNotUsedOff;
+begin
+  StartProgram(true);
+  Add('{$warn '+IntToStr(nPAParameterNotUsed)+' off}');
+  Add('procedure DoIt(i: longint);');
+  Add('begin end;');
+  Add('begin');
+  Add('  DoIt(1);');
+  AnalyzeProgram;
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestM_Hint_ParameterInOverrideNotUsed;
 begin
   StartProgram(true);

utils/pas2js/docs/translation.html

@@ -2805,6 +2805,21 @@ End.
     <li>{$Hint text} : emit a hint</li>
     <li>{$Message hint-text} :  emit a hint</li>
     <li>{$Message hint|note|warn|error|fatal text} : emit a message</li>
+    <li>{$Warn identifier on|off|default|error} : enable or disable a specific hint.<br>
+      Note, that some hints like "Parameter %s not used" are currently using the enable state at the end of the module, not the state at the hint source position.<br>
+      Identifier can be a message number as written by -vq or one of the following case insensitive:<br>
+      <ul>
+        <li>CONSTRUCTING_ABSTRACT: Constructing an instance of a class with abstract methods.</li>
+        <li>IMPLICIT_VARIANTS: Implicit use of the variants unit.</li>
+        <li>NO_RETVAL: Function result is not set</li>
+        <li>SYMBOL_DEPRECATED: Deprecated symbol.</li>
+        <li>SYMBOL_EXPERIMENTAL: Experimental symbol</li>
+        <li>SYMBOL_LIBRARY</li>
+        <li>SYMBOL_PLATFORM:  Platform-dependent symbol.</li>
+        <li>SYMBOL_UNIMPLEMENTED:  Unimplemented symbol.</li>
+        <li>HIDDEN_VIRTUAL: method hides virtual method of ancestor</li>
+      </ul>
+      </li>
     <li>{$M+}, {$TypeInfo on}: switches default visibility for class members from public to published</li>
     <li>{$ScopedEnums on|off} disabled(default): propagate enums to global scope, enable: needs fqn e.g. TEnumType.EnumValue.</li>
     <li>{$C+} generate code for assertions</li>