paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:09:42 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Mattias Gaertner:

Browse Source 
- nicer error handling for resourcestrings
  - resolve 'Result' element always to declaration

git-svn-id: trunk@35613 -
This commit is contained in:
michael 2017-03-17 21:25:35 +00:00
parent 4f24dfb71a
commit ef82aff9cd
4 changed files with 129 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -113,6 +113,7 @@ Works:
ToDo:
- fix slow lookup declaration proc in PParser
- fail to write a loop var inside the loop
- warn: create class with abstract methods
- classes - TPasClassType
@ -466,7 +467,9 @@ type
procedure SetPasElement(AValue: TPasElement);
public
Id: int64;
MsgType: TMessageType;
MsgNumber: integer;
MsgPattern: String;
Args: TMessageArgs;
destructor Destroy; override;
property PasElement: TPasElement read FPasElement write SetPasElement;
@ -1141,7 +1144,7 @@ type
Const Fmt : String; Args : Array of const; Element: TPasElement);
procedure LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: Array of const; PosEl: TPasElement); overload;
procedure RaiseMsg(const id: int64; MsgNumber: integer; const Fmt: String;
procedure RaiseMsg(const Id: int64; MsgNumber: integer; const Fmt: String;
Args: Array of const; ErrorPosEl: TPasElement);
procedure RaiseNotYetImplemented(id: int64; El: TPasElement; Msg: string = ''); virtual;
procedure RaiseInternalError(id: int64; const Msg: string = '');
@ -3786,6 +3789,13 @@ begin
else
RaiseNotYetImplemented(20170203161826,ImplProc);
end;
if DeclProc is TPasFunction then
begin
// replace 'Result'
Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar);
if Identifier.Element is TPasResultElement then
Identifier.Element:=TPasFunction(DeclProc).FuncType.ResultEl;
end;
end;
procedure TPasResolver.CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure
@ -5147,6 +5157,7 @@ begin
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(20160922163522,El);
// Note: El.ProcType is nil !
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikProc);
ProcScope:=TPasProcedureScope(PushScope(El,TPasProcedureScope));
ProcName:=El.Name;
@ -5181,7 +5192,7 @@ begin
else
NeedPop:=false;
CurClassType:=TPasClassType(FindElementWithoutParams(aClassName,El.ProcType,false));
CurClassType:=TPasClassType(FindElementWithoutParams(aClassName,El,false));
if not (CurClassType is TPasClassType) then
begin
aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName));
@ -5245,8 +5256,8 @@ end;
procedure TPasResolver.AddFunctionResult(El: TPasResultElement);
begin
if TopScope.ClassType=TPasProcedureScope then
AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple);
if TopScope.ClassType<>TPasProcedureScope then exit;
AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple);
end;
procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn);
@ -7488,7 +7499,7 @@ begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
FLastMsg := SafeFormat(Fmt,Args);
FLastElement := Element;
CreateMsgArgs(FLastMsgArgs,Args);
{$IFDEF VerbosePasResolver}
@ -7500,15 +7511,17 @@ begin
{$ENDIF}
end;
procedure TPasResolver.RaiseMsg(const id: int64; MsgNumber: integer;
procedure TPasResolver.RaiseMsg(const Id: int64; MsgNumber: integer;
const Fmt: String; Args: array of const; ErrorPosEl: TPasElement);
var
E: EPasResolve;
begin
SetLastMsg(id,mtError,MsgNumber,Fmt,Args,ErrorPosEl);
SetLastMsg(Id,mtError,MsgNumber,Fmt,Args,ErrorPosEl);
E:=EPasResolve.Create(FLastMsg);
E.PasElement:=ErrorPosEl;
E.Id:=Id;
E.MsgType:=mtError;
E.MsgNumber:=MsgNumber;
E.PasElement:=ErrorPosEl;
E.Args:=FLastMsgArgs;
raise E;
end;
@ -7576,7 +7589,7 @@ procedure TPasResolver.LogMsg(const id: int64; MsgType: TMessageType;
begin
SetLastMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl);
if Assigned(CurrentParser.OnLog) then
CurrentParser.OnLog(Self,Format(Fmt,Args));
CurrentParser.OnLog(Self,SafeFormat(Fmt,Args));
end;
function TPasResolver.CheckCallProcCompatibility(ProcType: TPasProcedureType;

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

@ -714,7 +714,7 @@ procedure TPasParser.ParseExc(MsgNumber: integer; const Fmt: String;
Args: array of const);
begin
SetLastMsg(mtError,MsgNumber,Fmt,Args);
raise EParserError.Create(Format(SParserErrorAtToken,
raise EParserError.Create(SafeFormat(SParserErrorAtToken,
[FLastMsg, CurTokenName, Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn])
{$ifdef addlocation}+' ('+inttostr(scanner.currow)+' '+inttostr(scanner.curcolumn)+')'{$endif},
Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
@ -3220,7 +3220,7 @@ begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
FLastMsg := SafeFormat(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;

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

@ -700,6 +700,7 @@ function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
function IsNamedToken(Const AToken : String; Out T : TToken) : Boolean;
procedure CreateMsgArgs(var MsgArgs: TMessageArgs; Args: array of const);
function SafeFormat(const Fmt: string; Args: array of const): string;
implementation
@ -787,7 +788,6 @@ var
begin
SetLength(MsgArgs, High(Args)-Low(Args)+1);
for i:=Low(Args) to High(Args) do
begin
case Args[i].VType of
vtInteger: MsgArgs[i] := IntToStr(Args[i].VInteger);
vtBoolean: MsgArgs[i] := BoolToStr(Args[i].VBoolean);
@ -811,6 +811,26 @@ begin
vtQWord: MsgArgs[i] := IntToStr(Args[i].VQWord^);
vtUnicodeString:MsgArgs[i] := AnsiString(UnicodeString(Args[i].VUnicodeString));
end;
end;
function SafeFormat(const Fmt: string; Args: array of const): string;
var
MsgArgs: TMessageArgs;
i: Integer;
begin
try
Result:=Format(Fmt,Args);
except
Result:='';
MsgArgs:=nil;
CreateMsgArgs(MsgArgs,Args);
for i:=0 to length(MsgArgs)-1 do
begin
if i>0 then
Result:=Result+',';
Result:=Result+MsgArgs[i];
end;
Result:='{'+Fmt+'}['+Result+']';
end;
end;
@ -1310,8 +1330,7 @@ begin
FCurToken:=tkIdentifier;
Result:=FCurToken;
end;
if not PPIsSkipping then
Break;
Break;
end;
else
if not PPIsSkipping then
@ -2291,7 +2310,7 @@ begin
If (TokenStr<>Nil) then
Result := TokenStr - PChar(CurLine)
else
Result:=0;
Result := 0;
end;
procedure TPascalScanner.DoLog(MsgType: TMessageType; MsgNumber: integer;
@ -2352,7 +2371,7 @@ begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
FLastMsg := SafeFormat(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;

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

@ -264,6 +264,7 @@ type
Procedure TestProc_UntypedParam_Forward;
Procedure TestProc_Varargs;
Procedure TestProc_ParameterExprAccess;
Procedure TestProc_FunctionResult_DeclProc;
// ToDo: fail builtin functions in constant with non const param
// record
@ -278,6 +279,7 @@ type
Procedure TestClassForward;
Procedure TestClassForwardNotResolved;
Procedure TestClass_Method;
Procedure TestClass_MethodWithoutClassFail;
Procedure TestClass_MethodWithParams;
Procedure TestClass_MethodUnresolved;
Procedure TestClass_MethodAbstract;
@ -671,14 +673,14 @@ var
end;
function AddMarkerForTokenBehindComment(Kind: TSrcMarkerKind;
const Identifer: string): PSrcMarker;
const Identifier: string): PSrcMarker;
var
TokenStart, p: PChar;
begin
p:=CommentEndP;
ReadNextPascalToken(p,TokenStart,false,false);
Result:=AddMarker(Kind,Filename,LineNumber,
CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifer);
CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifier);
end;
function ReadIdentifier(var p: PChar): string;
@ -3594,6 +3596,70 @@ begin
CheckAccessMarkers;
end;
procedure TTestResolver.TestProc_FunctionResult_DeclProc;
var
aMarker: PSrcMarker;
Elements: TFPList;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
ResultEl: TPasResultElement;
Proc: TPasProcedure;
ProcScope: TPasProcedureScope;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' function MethodA: longint;');
Add(' end;');
Add('function FuncA: longint; forward;');
Add('function TObject.MethodA: longint;');
Add('begin');
Add(' {#MethodA_Result}Result:=1;');
Add('end;');
Add('function FuncA: longint;');
Add(' function SubFuncA: longint; forward;');
Add(' function SubFuncB: longint;');
Add(' begin');
Add(' {#SubFuncB_Result}Result:=2;');
Add(' end;');
Add(' function SubFuncA: longint;');
Add(' begin');
Add(' {#SubFuncA_Result}Result:=3;');
Add(' end;');
Add('begin');
Add(' {#FuncA_Result}Result:=4;');
Add('end;');
Add('begin');
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
writeln('TTestResolver.TestProc_FunctionResult_DeclProc ',GetObjName(Ref.Declaration));
if not (Ref.Declaration is TPasResultElement) then continue;
ResultEl:=TPasResultElement(Ref.Declaration);
Proc:=ResultEl.Parent as TPasProcedure;
ProcScope:=Proc.CustomData as TPasProcedureScope;
if ProcScope.DeclarationProc<>nil then
RaiseErrorAtSrcMarker('expected Result to resolve to declaration at "#'+aMarker^.Identifier+', but was implproc"',aMarker);
break;
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestRecord;
begin
StartProgram(false);
@ -3774,6 +3840,19 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClass_MethodWithoutClassFail;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' end;');
Add('procedure TClassA.ProcA;');
Add('begin');
Add('end;');
Add('begin');
CheckResolverException('identifier not found "TClassA"',nIdentifierNotFound);
end;
procedure TTestResolver.TestClass_MethodWithParams;
begin
StartProgram(false);