fcl-passrc: scanner: $Message directive, option po_StopOnErrorDirective

git-svn-id: trunk@37821 -

packages/fcl-passrc/src/pasresolver.pp

@@ -86,6 +86,7 @@ Works:
   - function pred(ordinal): ordinal
   - function high(ordinal): ordinal
   - cast integer to enum, enum to integer
+  - $ScopedEnums
 - sets - TPasSetType
   - set of char
   - set of integer
@@ -171,14 +172,13 @@ Works:
 - var modifier 'absolute'
 
 ToDo:
-- for..in..do
-   - operator
+- $pop, $push
+- $writableconst off $J-
+- $RTTI inherited|explicit
 - range checking:
   - indexedprop[param]
   - case-of unique
   - defaultvalue
-- scoped enum
-- $writableconst off $J-
 - fail to write a loop var inside the loop
 - warn: create class with abstract methods
 - nested classes
@@ -200,10 +200,13 @@ ToDo:
 - generics
 - futures
 - operator overload
+   - operator enumerator
 - attributes
 - anonymous functions
 - TPasFileType
 - labels
+- $warn identifier ON|off|error|default
+- $zerobasedstrings on|off
 
 Debug flags: -d<x>
   VerbosePasResolver
@@ -929,6 +932,14 @@ type
     );
   TPasResolverOptions = set of TPasResolverOption;
 
+  TPasResolverStep = (
+    prsInit,
+    prsParsing,
+    prsFinishingModule,
+    prsFinishedModule
+    );
+  TPasResolverSteps = set of TPasResolverStep;
+
   { TPasResolver }
 
   TPasResolver = Class(TPasTreeContainer)
@@ -966,6 +977,7 @@ type
     FScopeClass_WithExpr: TPasWithExprScopeClass;
     FScopeCount: integer;
     FScopes: array of TPasScope; // stack of scopes
+    FStep: TPasResolverStep;
     FStoreSrcColumns: boolean;
     FSubScopeCount: integer;
     FSubScopes: array of TPasScope; // stack of scopes
@@ -1480,6 +1492,7 @@ type
     // parsed values
     property DefaultNameSpace: String read FDefaultNameSpace;
     property RootElement: TPasModule read FRootElement;
+    property Step: TPasResolverStep read FStep;
     // scopes
     property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; {
        If true Line and Column is mangled together in TPasElement.SourceLineNumber.
@@ -3415,6 +3428,8 @@ begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.FinishModule START ',CurModule.Name);
   {$ENDIF}
+  FStep:=prsFinishingModule;
+
   CurModuleClass:=CurModule.ClassType;
   if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then
     begin
@@ -3447,6 +3462,7 @@ begin
   CheckTopScope(TPasModuleScope);
   PopScope;
 
+  FStep:=prsFinishedModule;
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.FinishModule END ',CurModule.Name);
   {$ENDIF}
@@ -10163,7 +10179,11 @@ begin
   El.SourceFilename:=ASrcPos.FileName;
   El.SourceLinenumber:=SrcY;
   if FRootElement=nil then
+    begin
     FRootElement:=NoNil(Result) as TPasModule;
+    if FStep=prsInit then
+      FStep:=prsParsing;
+    end;
 
   if IsElementSkipped(El) then exit;
 
@@ -11592,6 +11612,11 @@ procedure TPasResolver.LogMsg(const id: int64; MsgType: TMessageType;
   MsgNumber: integer; const Fmt: String; Args: array of const;
   PosEl: TPasElement);
 begin
+  if (FStep<prsFinishingModule)
+      and (CurrentParser.Scanner<>nil)
+      and (CurrentParser.Scanner.IgnoreMsgType(MsgType)) then
+    exit; // during parsing consider directives like $Hints on|off
+
   SetLastMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl);
   if Assigned(OnLog) then
     OnLog(Self,FLastMsg)

packages/fcl-passrc/src/pparser.pp

@@ -4047,6 +4047,8 @@ Var
   Msg : String;
 
 begin
+  if (Scanner<>nil) and Scanner.IgnoreMsgType(MsgType) then
+    exit;
   SetLastMsg(MsgType,MsgNumber,Fmt,Args);
   If Assigned(FOnLog) then
     begin

packages/fcl-passrc/src/pscanner.pp

@@ -271,12 +271,16 @@ type
 
   // switches, that can be 'on' or 'off' and have no corresponding letter switch
   TBoolSwitch = (
+    bsHints,
+    bsNotes,
+    bsWarnings,
     bsMacro,
     bsScopedEnums
     );
   TBoolSwitches = set of TBoolSwitch;
 const
-  bsAll = [bsMacro..bsScopedEnums];
+  bsAll = [low(TBoolSwitch)..high(TBoolSwitch)];
+  FPCModeBoolSwitches = [bsHints,bsNotes,bsWarnings,bsMacro];
 
 type
   TTokenOption = (toForceCaret,toOperatorToken);
@@ -487,7 +491,7 @@ type
   TPascalScannerPPSkipMode = (ppSkipNone, ppSkipIfBranch, ppSkipElseBranch, ppSkipAll);
 
   TPOption = (
-    po_delphi,               // DEPRECATED Delphi mode: forbid nested comments
+    po_delphi,               // DEPRECATED since fpc 3.1.1: Delphi mode: forbid nested comments
     po_KeepScannerError,     // default: catch EScannerError and raise an EParserError instead
     po_CAssignments,         // allow C-operators += -= *= /=
     po_ResolveStandardTypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
@@ -497,7 +501,8 @@ type
     po_ArrayRangeExpr,       // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
     po_SelfToken,            // Self is a token. For backward compatibility.
     po_CheckModeSwitches,    // stop on unknown modeswitch with an error
-    po_CheckCondFunction    // stop on unknown function in conditional expression, default: return '0'
+    po_CheckCondFunction,    // stop on unknown function in conditional expression, default: return '0'
+    po_StopOnErrorDirective  // stop on user $Error, $message error|fatal
     );
   TPOptions = set of TPOption;
 
@@ -576,8 +581,6 @@ type
       Value: string): boolean;
     procedure SetAllowedBoolSwitches(const AValue: TBoolSwitches);
     procedure SetAllowedModeSwitches(const AValue: TModeSwitches);
-    procedure SetCurrentBoolSwitches(const AValue: TBoolSwitches);
-    procedure SetCurrentModeSwitches(AValue: TModeSwitches);
     procedure SetMacrosOn(const AValue: boolean);
     procedure SetOptions(AValue: TPOptions);
     procedure SetReadOnlyBoolSwitches(const AValue: TBoolSwitches);
@@ -603,6 +606,7 @@ type
     procedure HandleENDIF(const AParam: String);
     procedure HandleDefine(Param: String); virtual;
     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;
@@ -615,6 +619,8 @@ type
     procedure ClearFiles;
     Procedure ClearMacros;
     Procedure SetCurTokenString(AValue : string);
+    procedure SetCurrentBoolSwitches(const AValue: TBoolSwitches); virtual;
+    procedure SetCurrentModeSwitches(AValue: TModeSwitches); virtual;
     function LogEvent(E : TPScannerLogEvent) : Boolean; inline;
   public
     constructor Create(AFileResolver: TBaseFileResolver);
@@ -638,6 +644,7 @@ type
     Procedure SetCompilerMode(S : String);
     function CurSourcePos: TPasSourcePos;
     Function SetForceCaret(AValue : Boolean) : Boolean; // returns old state
+    function IgnoreMsgType(MsgType: TMessageType): boolean; virtual;
     property FileResolver: TBaseFileResolver read FFileResolver;
     property CurSourceFile: TLineReader read FCurSourceFile;
     property CurFilename: string read FCurFilename;
@@ -849,35 +856,38 @@ const
     );
 
   LetterSwitchNames: array['A'..'Z'] of string=(
-     'ALIGN'          // A
-    ,'BOOLEVAL'       // B
-    ,'ASSERTIONS'     // C
-    ,'DEBUGINFO'      // D
-    ,'EXTENSION'      // E
+     'ALIGN'          // A   align fields
+    ,'BOOLEVAL'       // B   complete boolean evaluation
+    ,'ASSERTIONS'     // C   generate code for assertions
+    ,'DEBUGINFO'      // D   generate debuginfo (debug lines), OR: $description 'text'
+    ,'EXTENSION'      // E   output file extension
     ,''               // F
     ,'IMPORTEDDATA'   // G
-    ,'LONGSTRINGS'    // H
-    ,'IOCHECKS'       // I
-    ,'WRITEABLECONST' // J
+    ,'LONGSTRINGS'    // H   String=AnsiString
+    ,'IOCHECKS'       // I   generate EInOutError
+    ,'WRITEABLECONST' // J   writable typed const
     ,''               // K
-    ,'LOCALSYMBOLS'   // L
-    ,'TYPEINFO'       // M
+    ,'LOCALSYMBOLS'   // L   generate local symbol information (debug, requires $D+)
+    ,'TYPEINFO'       // M   allow published members OR $M minstacksize,maxstacksize
     ,''               // N
-    ,'OPTIMIZATION'   // O
-    ,'OPENSTRINGS'    // P
+    ,'OPTIMIZATION'   // O   enable safe optimizations (-O1)
+    ,'OPENSTRINGS'    // P   deprecated Delphi directive
     ,'OVERFLOWCHECKS' // Q
-    ,'RANGECHECKS'    // R
+    ,'RANGECHECKS'    // R   OR resource
     ,''               // S
-    ,'TYPEADDRESS'    // T
+    ,'TYPEDADDRESS'   // T   enabled: @variable gives typed pointer, otherwise untyped pointer
     ,'SAFEDIVIDE'     // U
-    ,'VARSTRINGCHECKS'// V
-    ,'STACKFRAMES'    // W
-    ,'EXTENDEDSYNTAX' // X
-    ,'REFERENCEINFO'  // Y
+    ,'VARSTRINGCHECKS'// V   strict shortstring checking, e.g. cannot pass shortstring[3] to shortstring
+    ,'STACKFRAMES'    // W   always generate stackframes (debugging)
+    ,'EXTENDEDSYNTAX' // X   deprecated Delphi directive
+    ,'REFERENCEINFO'  // Y   store for each identifier the declaration location
     ,''               // Z
    );
 
   BoolSwitchNames: array[TBoolSwitch] of string = (
+    'Hints',
+    'Notes',
+    'Warnings',
     'Macro',
     'ScopedEnums'
     );
@@ -2218,7 +2228,7 @@ begin
   FAllowedModes:=AllLanguageModes;
   FCurrentModeSwitches:=FPCModeSwitches;
   FAllowedModeSwitches:=msAllFPCModeSwitches;
-  FCurrentBoolSwitches:=[];
+  FCurrentBoolSwitches:=FPCModeBoolSwitches;
   FAllowedBoolSwitches:=bsAll;
   FConditionEval:=TCondDirectiveEvaluator.Create;
   FConditionEval.OnLog:=@OnCondEvalLog;
@@ -2624,12 +2634,41 @@ end;
 
 procedure TPascalScanner.HandleError(Param: String);
 begin
-  if po_CheckCondFunction in Options then
+  if po_StopOnErrorDirective in Options then
     Error(nUserDefined, SUserDefined,[Param])
   else
     DoLog(mtWarning,nUserDefined,SUserDefined+' error',[Param]);
 end;
 
+procedure TPascalScanner.HandleMessageDirective(Param: String);
+var
+  p: Integer;
+  Kind: String;
+  MsgType: TMessageType;
+begin
+  if Param='' then exit;
+  p:=1;
+  while (p<=length(Param)) and (Param[p] in ['a'..'z','A'..'Z']) do inc(p);
+  Kind:=LeftStr(Param,p-1);
+  MsgType:=mtHint;
+  case UpperCase(Kind) of
+  'HINT': MsgType:=mtHint;
+  'NOTE': MsgType:=mtNote;
+  'WARN': MsgType:=mtError;
+  'ERROR': MsgType:=mtError;
+  'FATAL': MsgType:=mtFatal;
+  else
+    // $Message 'hint text'
+    p:=1;
+  end;
+  while (p<=length(Param)) and (Param[p] in [' ',#9]) do inc(p);
+  Delete(Param,1,p-1);
+  if MsgType in [mtFatal,mtError] then
+    HandleError(Param)
+  else
+    DoLog(MsgType,nUserDefined,SUserDefined,[Param])
+end;
+
 procedure TPascalScanner.HandleUnDefine(Param: String);
 begin
   UnDefine(GetMacroName(Param));
@@ -2945,23 +2984,31 @@ begin
         'ERROR':
           HandleError(Param);
         'HINT':
-          DoLog(mtHint,nUserDefined,SUserDefined,[Directive]);
+          DoLog(mtHint,nUserDefined,SUserDefined,[Param]);
+        'HINTS':
+          DoBoolDirective(bsHints);
         'I','INCLUDE':
           Result:=HandleInclude(Param);
         'MACRO':
           DoBoolDirective(bsMacro);
+        'MESSAGE':
+          HandleMessageDirective(Param);
         'MODE':
           HandleMode(Param);
         'MODESWITCH':
           HandleModeSwitch(Param);
         'NOTE':
-          DoLog(mtNote,nUserDefined,SUserDefined,[Directive]);
+          DoLog(mtNote,nUserDefined,SUserDefined,[Param]);
+        'NOTES':
+          DoBoolDirective(bsNotes);
         'SCOPEDENUMS':
           DoBoolDirective(bsScopedEnums);
         'UNDEF':
           HandleUnDefine(Param);
         'WARNING':
-          DoLog(mtWarning,nUserDefined,SUserDefined,[Directive]);
+          DoLog(mtWarning,nUserDefined,SUserDefined,[Param]);
+        'WARNINGS':
+          DoBoolDirective(bsWarnings);
       else
         Handled:=false;
       end;
@@ -3656,6 +3703,7 @@ Var
   Msg : String;
 
 begin
+  if IgnoreMsgType(MsgType) then exit;
   SetCurMsg(MsgType,MsgNumber,Fmt,Args);
   If Assigned(FOnLog) then
     begin
@@ -3841,4 +3889,14 @@ begin
     Exclude(FTokenOptions,toForceCaret)
 end;
 
+function TPascalScanner.IgnoreMsgType(MsgType: TMessageType): boolean;
+begin
+  case MsgType of
+    mtWarning: if not (bsWarnings in FCurrentBoolSwitches) then exit(true);
+    mtNote: if not (bsNotes in FCurrentBoolSwitches) then exit(true);
+    mtHint: if not (bsHints in FCurrentBoolSwitches) then exit(true);
+  end;
+  Result:=false;
+end;
+
 end.

packages/fcl-passrc/tests/tcresolver.pas

@@ -213,9 +213,10 @@ type
     Procedure TestIntegerRange;
     Procedure TestIntegerRangeHighLowerLowFail;
     Procedure TestIntegerRangeLowHigh;
-    Procedure TestAssignIntRangeFail;
-    Procedure TestByteRangeFail;
-    Procedure TestCustomIntRangeFail;
+    Procedure TestAssignIntRangeWarning;
+    Procedure TestByteRangeWarning;
+    Procedure TestByteRangeWarningOff;
+    Procedure TestCustomIntRangeWarning;
     Procedure TestIntSet_Const;
     Procedure TestIntSet_ConstDuplicateElement;
     Procedure TestInt_ForIn;
@@ -2542,7 +2543,7 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
-procedure TTestResolver.TestAssignIntRangeFail;
+procedure TTestResolver.TestAssignIntRangeWarning;
 begin
   StartProgram(false);
   Add([
@@ -2556,7 +2557,7 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
-procedure TTestResolver.TestByteRangeFail;
+procedure TTestResolver.TestByteRangeWarning;
 begin
   StartProgram(false);
   Add([
@@ -2568,7 +2569,18 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
-procedure TTestResolver.TestCustomIntRangeFail;
+procedure TTestResolver.TestByteRangeWarningOff;
+begin
+  StartProgram(false);
+  Add([
+  '{$warnings off}',
+  'var b:byte=300;',
+  'begin']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
+procedure TTestResolver.TestCustomIntRangeWarning;
 begin
   StartProgram(false);
   Add([