* Patch from Mattias Gaertner:

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

git-svn-id: trunk@35613 -

packages/fcl-passrc/src/pasresolver.pp

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

packages/fcl-passrc/src/pparser.pp

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

packages/fcl-passrc/src/pscanner.pp

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

packages/fcl-passrc/tests/tcresolver.pas

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