paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-23 09:29:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@37821 -
This commit is contained in:
Mattias Gaertner 2017-12-26 22:23:01 +00:00
parent 8326543918
commit 96a0c44d9e
4 changed files with 135 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

114
packages/fcl-passrc/src/pscanner.pp
View File

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

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

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