Merge branch 'upstream' into litezarus

components/fpdebug/fpdbgclasses.pp

@@ -292,6 +292,7 @@   TDbgProcess = class(TDbgInstance)
     function  RunTo(ASourceFile: string; ALineNr: integer): boolean;
 
     function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; virtual;
+    function ReadAddress(const AAdress: TDbgPtr; out AData: TDBGPtr): Boolean; virtual;
     function ReadOrdinal(const AAdress: TDbgPtr; out AData): Boolean; virtual;
     function ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean; virtual;
     function ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean; virtual;
@@ -775,6 +776,25 @@ function TDbgProcess.ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out
   result := false
 end;
 
+function TDbgProcess.ReadAddress(const AAdress: TDbgPtr; out AData: TDBGPtr): Boolean;
+var
+  dw: DWord;
+  qw: QWord;
+begin
+  case GMode of
+    dm32:
+      begin
+        result := ReadData(AAdress, sizeof(dw), dw);
+        AData:=dw;
+      end;
+    dm64:
+      begin
+        result := ReadData(AAdress, sizeof(qw), qw);
+        AData:=qw;
+      end;
+  end;
+end;
+
 function TDbgProcess.ReadOrdinal(const AAdress: TDbgPtr; out AData): Boolean;
 begin
   Result := ReadData(AAdress, 4, AData);

components/fpdebug/fpimgreadermacho.pas

@@ -112,7 +112,7 @@ procedure TDbgMachoDataSource.ParseSymbolTable(AfpSymbolInfo: TfpSymbolList);
       if (SymbolArr^[i].n_type and $0e)=$e then
       begin
         // Section-index is ignored for now...
-        AfpSymbolInfo.AddObject(pchar(SymbolStr+SymbolArr^[i].n_un.n_strx), TObject(SymbolArr^[i].n_value));
+        AfpSymbolInfo.AddObject(pchar(SymbolStr+SymbolArr^[i].n_un.n_strx), TObject(PtrUInt(SymbolArr^[i].n_value)));
       end
     end;
   end;

components/ideintf/ideexterntoolintf.pas

@@ -286,7 +286,11 @@   TFPCParser = class(TExtToolParser)
                            read FHideHintsUnitNotUsedInMainSource
                            write FHideHintsUnitNotUsedInMainSource default true;
   end;
+  TFPCParserClass = class of TFPCParser;
+var
+  IDEFPCParser: TFPCParserClass = nil;
 
+type
   { TMakeParser - standard parser for 'make' messages, implemented by IDE }
 
   TMakeParser = class(TExtToolParser)
@@ -594,6 +598,7 @@   TIDEExternalToolOptions = class
     FCustomMacroFunction: TETMacroFunction;
     FEnvironmentOverrides: TStringList;
     FExecutable: string;
+    FHint: string;
     FQuiet: boolean;
     FResolveMacros: boolean;
     FScanners: TStrings;
@@ -609,6 +614,7 @@   TIDEExternalToolOptions = class
     procedure Clear;
 
     property Title: string read fTitle write fTitle;
+    property Hint: string read FHint write FHint;
     property Executable: string read FExecutable write FExecutable;
     property Filename: string read FExecutable write FExecutable; deprecated;
     property CmdLineParams: string read fCmdLineParams write fCmdLineParams;

components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas

@@ -50,6 +50,11 @@   TFpDebugDebugger = class(TDebuggerIntf)
     FDbgController: TDbgController;
     FFpDebugThread: TFpDebugThread;
     FQuickPause: boolean;
+    FRaiseExceptionBreakpoint: FpDbgClasses.TDBGBreakPoint;
+    function GetClassInstanceName(AnAddr: TDBGPtr): string;
+    function ReadAnsiString(AnAddr: TDbgPtr): string;
+    function SetSoftwareExceptionBreakpoint: boolean;
+    procedure HandleSoftwareException(var AnExceptionLocation: TDBGLocationRec; var continue: boolean);
     procedure FreeDebugThread;
     procedure FDbgControllerHitBreakpointEvent(var continue: boolean; const Breakpoint: FpDbgClasses.TDbgBreakpoint);
     procedure FDbgControllerCreateProcessEvent(var continue: boolean);
@@ -88,6 +93,7 @@   TFpDebugDebugger = class(TDebuggerIntf)
   public
     constructor Create(const AExternalDebugger: String); override;
     destructor Destroy; override;
+    function GetLocationRec(AnAddress: TDBGPtr=0): TDBGLocationRec;
     function GetLocation: TDBGLocationRec; override;
     class function Caption: String; override;
     class function HasExePath: boolean; override;
@@ -344,7 +350,7 @@ procedure TFPLocals.RequestData(ALocals: TLocals);
     RegList := AController.CurrentProcess.MainThread.RegisterValueList;
   Reg := RegList.FindRegisterByDwarfIndex(8);
   if Reg <> nil then
-    AContext := AController.CurrentProcess.DbgInfo.FindContext(ThreadId, CurStackFrame, Reg.NumValue)
+    AContext := AController.CurrentProcess.DbgInfo.FindContext(CurThreadId, CurStackFrame, Reg.NumValue)
   else
     AContext := nil;
 
@@ -985,6 +991,72 @@ procedure TFpDebugDebugger.ProcessASyncWatches(Data: PtrInt);
     end;
 end;
 
+function TFpDebugDebugger.GetClassInstanceName(AnAddr: TDBGPtr): string;
+var
+  VMTAddr: TDBGPtr;
+  ClassNameAddr: TDBGPtr;
+  b: byte;
+begin
+  // Read address of the vmt
+  FDbgController.CurrentProcess.ReadAddress(AnAddr, VMTAddr);
+  FDbgController.CurrentProcess.ReadAddress(VMTAddr+3*4, ClassNameAddr);
+  // read classname (as shortstring)
+  FDbgController.CurrentProcess.ReadData(ClassNameAddr, 1, b);
+  setlength(result,b);
+  FDbgController.CurrentProcess.ReadData(ClassNameAddr+1, b, result[1]);
+end;
+
+function TFpDebugDebugger.ReadAnsiString(AnAddr: TDbgPtr): string;
+var
+  StrAddr: TDBGPtr;
+  len: integer;
+begin
+  result := '';
+  if not FDbgController.CurrentProcess.ReadAddress(AnAddr, StrAddr) then
+    Exit;
+  FDbgController.CurrentProcess.ReadOrdinal(StrAddr-sizeof(len), len);
+  setlength(result, len);
+  if not FDbgController.CurrentProcess.ReadData(StrAddr, len, result[1]) then
+    result := '';
+end;
+
+function TFpDebugDebugger.SetSoftwareExceptionBreakpoint: boolean;
+var
+  AContext: TFpDbgInfoContext;
+  AValue: TFpDbgValue;
+begin
+  result := false;
+  if assigned(FDbgController.CurrentProcess.SymbolTableInfo) then
+  begin
+    AContext := FDbgController.CurrentProcess.SymbolTableInfo.FindContext(0);
+    if Assigned(AContext) then
+    begin
+      AValue := AContext.FindSymbol('FPC_RAISEEXCEPTION');
+      if assigned(AValue) then
+      begin
+        FRaiseExceptionBreakpoint := FDbgController.CurrentProcess.AddBreak(AValue.Address.Address);
+        if assigned(FRaiseExceptionBreakpoint) then
+          result := True;
+      end;
+    end;
+  end;
+end;
+
+procedure TFpDebugDebugger.HandleSoftwareException(var AnExceptionLocation: TDBGLocationRec;var continue: boolean);
+var
+  AnExceptionObjectLocation: TDBGPtr;
+  ExceptionClass: string;
+  ExceptionMessage: string;
+begin
+  // Using regvar:
+  AnExceptionLocation:=GetLocationRec(FDbgController.CurrentProcess.MainThread.RegisterValueList.FindRegisterByDwarfIndex(2).NumValue);
+  AnExceptionObjectLocation:=FDbgController.CurrentProcess.MainThread.RegisterValueList.FindRegisterByDwarfIndex(0).NumValue;
+  ExceptionClass := GetClassInstanceName(AnExceptionObjectLocation);
+  ExceptionMessage := ReadAnsiString(AnExceptionObjectLocation+4);
+
+  DoException(deInternal, ExceptionClass, AnExceptionLocation, ExceptionMessage, continue);
+end;
+
 procedure TFpDebugDebugger.FreeDebugThread;
 begin
   if FFpDebugThread = nil then
@@ -999,12 +1071,23 @@ procedure TFpDebugDebugger.FreeDebugThread;
 procedure TFpDebugDebugger.FDbgControllerHitBreakpointEvent(var continue: boolean; const Breakpoint: FpDbgClasses.TDbgBreakpoint);
 var
   ABreakPoint: TDBGBreakPoint;
+  ALocationAddr: TDBGLocationRec;
 begin
   if assigned(Breakpoint) then
     begin
-    ABreakPoint := TFPBreakpoints(BreakPoints).Find(Breakpoint);
-    if assigned(ABreakPoint) then
-      ABreakPoint.Hit(continue);
+    if BreakPoint=FRaiseExceptionBreakpoint then
+      begin
+        HandleSoftwareException(ALocationAddr, continue);
+        if continue then
+          exit;
+      end
+    else
+      begin
+        ABreakPoint := TFPBreakpoints(BreakPoints).Find(Breakpoint);
+        if assigned(ABreakPoint) then
+          ABreakPoint.Hit(continue);
+        ALocationAddr := GetLocation;
+      end;
     end
   else if FQuickPause then
     begin
@@ -1013,13 +1096,16 @@ procedure TFpDebugDebugger.FDbgControllerHitBreakpointEvent(var continue: boolea
       exit;
     end;
   SetState(dsPause);
-  DoCurrent(GetLocation);
+  DoCurrent(ALocationAddr);
 end;
 
 procedure TFpDebugDebugger.FDbgControllerCreateProcessEvent(var continue: boolean);
 begin
   // This will trigger setting the breakpoints
   SetState(dsPause);
+
+  if not SetSoftwareExceptionBreakpoint then
+    debugln('Failed to set software-debug breakpoint');
 end;
 
 function TFpDebugDebugger.RequestCommand(const ACommand: TDBGCommand;
@@ -1197,7 +1283,7 @@ destructor TFpDebugDebugger.Destroy;
   inherited Destroy;
 end;
 
-function TFpDebugDebugger.GetLocation: TDBGLocationRec;
+function TFpDebugDebugger.GetLocationRec(AnAddress: TDBGPtr): TDBGLocationRec;
 var
   sym, symproc: TFpDbgSymbol;
 begin
@@ -1208,7 +1294,10 @@ function TFpDebugDebugger.GetLocation: TDBGLocationRec;
     result.SrcFullName:='';
     result.SrcLine:=0;
 
-    result.Address := FDbgController.CurrentProcess.GetInstructionPointerRegisterValue;
+    if AnAddress=0 then
+      result.Address := FDbgController.CurrentProcess.GetInstructionPointerRegisterValue
+    else
+      result.Address := AnAddress;
 
     sym := FDbgController.CurrentProcess.FindSymbol(result.Address);
     if sym = nil then
@@ -1218,17 +1307,18 @@ function TFpDebugDebugger.GetLocation: TDBGLocationRec;
     result.SrcLine := sym.Line;
     result.SrcFullName := sym.FileName;
 
-    debugln('Locatie: '+sym.FileName+':'+sym.Name+':'+inttostr(sym.Line));
-
     symproc := sym;
     while not (symproc.kind in [skProcedure, skFunction]) do
       symproc := symproc.Parent;
 
     if assigned(symproc) then
       result.FuncName:=symproc.Name;
     end
-  else
-    result := inherited;
+end;
+
+function TFpDebugDebugger.GetLocation: TDBGLocationRec;
+begin
+  Result:=GetLocationRec;
 end;
 
 class function TFpDebugDebugger.Caption: String;

docs/xml/lcl/lcltype.xml

@@ -6805,8 +6805,9 @@
       </element>
       <!-- alias type Visibility: default -->
       <element name="TColorRef">
-        <short/>
-        <descr/>
+        <short>TColor, TColorRef</short>
+        <descr>Values from 0..$FFFFFF are BGR colors. The lowest 8 bit are the blue component, the middle 8 bit the green component and the highest 8 bit the red component. Use the functions Red, Green, Blue to extract the components, RedGreenBlue to extract all three components and RGBToColor to convert the three colors to a TColor.
+Values with highest bit set are system colors or themed colors. For example clNone, clBackground, clButton, clWindowText. Their actual value depend on the context (i.e. the used Canvas) and they are not valid in all contexts. For example clWindowText might only work for Font.Color, not for Brush.Color or Pen.Color. clBackground might be a color, gradient, pattern or image, depending on theme and control type. A system color can change during runtime, so do not store them. Use system colors only on LCL control Canvas. They probably are not defined for printer canvas and some are not defined on bitmap canvas.</descr>
         <seealso/>
       </element>
       <!-- constant Visibility: default -->

ide/checkcompileropts.pas

@@ -40,7 +40,7 @@ interface
   CodeToolsStructs,
   // IDEIntf
   ProjectIntf, MacroIntf, IDEExternToolIntf, LazIDEIntf, IDEDialogs,
-  PackageIntf,
+  PackageIntf, IDEMsgIntf,
   // IDE
   Project, PackageSystem, ExtToolEditDlg, IDEProcs, EnvironmentOpts,
   LazarusIDEStrConsts, PackageDefs, CompilerOptions, TransferMacros, LazConf;
@@ -872,9 +872,10 @@ function TCheckCompilerOptsDlg.DoTestAll: TModalResult;
   CompilerFiles:=nil;
   Target_PPUs:=nil;
   FPC_PPUs:=nil;
+  IDEMessagesWindow.Clear;
   Screen.Cursor:=crHourGlass;
   try
-    // do not confuse the user with cached data
+    // make sure there is no invalid cache due to bugs
     InvalidateFileStateCache();
 
     // check for special characters in search paths

ide/compiler.pp

@@ -65,7 +65,8 @@   TCompiler = class(TObject)
     destructor Destroy; override;
     function Compile(AProject: TProject;
                      const WorkingDir, CompilerFilename, CompilerParams: string;
-                     BuildAll, SkipLinking, SkipAssembler: boolean
+                     BuildAll, SkipLinking, SkipAssembler: boolean;
+                     const aCompileHint: string
                     ): TModalResult;
     procedure WriteError(const Msg: string);
     {$IFNDEF EnableNewExtTools}
@@ -269,10 +270,9 @@ destructor TCompiler.Destroy;
 {------------------------------------------------------------------------------
   TCompiler Compile
 ------------------------------------------------------------------------------}
-function TCompiler.Compile(AProject: TProject;
-  const WorkingDir, CompilerFilename, CompilerParams: string;
-  BuildAll, SkipLinking, SkipAssembler: boolean
-  ): TModalResult;
+function TCompiler.Compile(AProject: TProject; const WorkingDir,
+  CompilerFilename, CompilerParams: string; BuildAll, SkipLinking,
+  SkipAssembler: boolean; const aCompileHint: string): TModalResult;
 var
   CmdLine : String;
   Abort : Boolean;
@@ -322,13 +322,14 @@ function TCompiler.Compile(AProject: TProject;
 
   {$IFDEF EnableNewExtTools}
   Tool:=ExternalToolList.Add('Compile Project');
+  Tool.Hint:=aCompileHint;
   Tool.Process.Executable:=CompilerFilename;
   Tool.CmdLineParams:=CmdLine;
   Tool.Process.CurrentDirectory:=WorkingDir;
   FPCParser:=TFPCParser(Tool.AddParsers(SubToolFPC));
   FPCParser.HideHintsSenderNotUsed:=not AProject.CompilerOptions.ShowHintsForSenderNotUsed;
   FPCParser.HideHintsUnitNotUsedInMainSource:=not AProject.CompilerOptions.ShowHintsForUnusedUnitsInMainSrc;
-  if AProject.CompilerOptions.ShowHintsForUnusedUnitsInMainSrc
+  if (not AProject.CompilerOptions.ShowHintsForUnusedUnitsInMainSrc)
   and (AProject.MainFilename<>'') then
     FPCParser.FilesToIgnoreUnitNotUsed.Add(AProject.MainFilename);
   Tool.AddParsers(SubToolMake);