From 1fb4ee52a5965c116caec5081bb2bf4c77c241e5 Mon Sep 17 00:00:00 2001 From: mattias Date: Mon, 23 Jun 2003 09:42:09 +0000 Subject: [PATCH] fixes for debugging lazarus git-svn-id: trunk@4296 - --- components/codetools/basiccodetools.pas | 2 - components/codetools/eventcodetool.pas | 4 +- components/codetools/fileprocs.pas | 17 ------- components/codetools/linkscanner.pas | 4 -- ide/buildlazdialog.pas | 1 + ide/codetoolsoptions.pas | 1 + ide/lazarus.pp | 24 ++++++---- ide/lazarusidestrconsts.pas | 1 + lcl/forms.pp | 30 ++++++++---- lcl/grids.pas | 18 +++---- lcl/include/application.inc | 62 ++++++++++++++++++++----- lcl/include/customform.inc | 5 +- lcl/include/customupdown.inc | 4 +- lcl/include/filectrl.inc | 20 ++------ lcl/include/promptdialog.inc | 11 +++-- lcl/include/toolbar.inc | 18 ++----- lcl/lresources.pp | 5 +- lcl/menus.pp | 7 ++- lcl/stdctrls.pp | 7 ++- packager/packagelinks.pas | 3 -- 20 files changed, 128 insertions(+), 116 deletions(-) diff --git a/components/codetools/basiccodetools.pas b/components/codetools/basiccodetools.pas index 73a77e1f4e..642cf6d2e1 100644 --- a/components/codetools/basiccodetools.pas +++ b/components/codetools/basiccodetools.pas @@ -2084,8 +2084,6 @@ function TrimCodeSpace(const ACode: string): string; // space is combined to one char // space which is not needed is removed. // space is only needed between two words or between 2-char operators -const - NonSpaceSymbols = [',',';','(',')','[',']']; var CodePos, ResultPos, CodeLen, SpaceEndPos: integer; c1, c2: char; begin diff --git a/components/codetools/eventcodetool.pas b/components/codetools/eventcodetool.pas index 49982af2b2..e1ef43ae2d 100644 --- a/components/codetools/eventcodetool.pas +++ b/components/codetools/eventcodetool.pas @@ -97,15 +97,13 @@ type Attr: TProcHeadAttributes): string; end; - -implementation - const MethodKindAsString: array[TMethodKind] of shortstring = ( 'procedure', 'function', 'constructor', 'destructor', 'class procedure', 'class function' ); +implementation { TEventsCodeTool } diff --git a/components/codetools/fileprocs.pas b/components/codetools/fileprocs.pas index 55ae1e14ca..551209550a 100644 --- a/components/codetools/fileprocs.pas +++ b/components/codetools/fileprocs.pas @@ -485,23 +485,6 @@ end; function SearchFileInPath(const Filename, BasePath, SearchPath, Delimiter: string; SearchLoUpCase: boolean): string; - - function FileDoesExists(const AFilename: string): boolean; - var s: string; - begin - s:=ExpandFilename(TrimFilename(AFilename)); - Result:=FileExists(s); - if Result then begin - SearchFileInPath:=s; - exit; - end; - {$IFNDEF Win32} - if SearchLoUpCase then begin - - end; - {$ENDIF} - end; - var p, StartPos, l: integer; CurPath, Base: string; diff --git a/components/codetools/linkscanner.pas b/components/codetools/linkscanner.pas index 36ee6f53a0..a662d0a08f 100644 --- a/components/codetools/linkscanner.pas +++ b/components/codetools/linkscanner.pas @@ -1484,10 +1484,6 @@ function TLinkScanner.GuessMisplacedIfdefEndif(StartCursorPos: integer; TDirectiveType = (dtUnknown, dtIf, dtIfDef, dtIfNDef, dtIfOpt, dtElse, dtEndif); - const - DirectiveTypeLen: array[TDirectiveType] of integer = (0,2,5,6,5,4,5); - - function FindNextToken(const ASrc: string; var AToken: TToken): boolean; var ASrcLen: integer; diff --git a/ide/buildlazdialog.pas b/ide/buildlazdialog.pas index 75be03fd44..c29119bf4b 100644 --- a/ide/buildlazdialog.pas +++ b/ide/buildlazdialog.pas @@ -214,6 +214,7 @@ function SaveIDEMakeOptions(Options: TBuildLazarusOptions; Macros: TTransferMacroList; const PackageOptions: string; Flags: TBuildLazarusFlags): TModalResult; function GetMakeIDEConfigFilename: string; +function GetTranslatedMakeModes(MakeMode: TMakeMode): string; implementation diff --git a/ide/codetoolsoptions.pas b/ide/codetoolsoptions.pas index 6a3ad38ece..18f50e6545 100644 --- a/ide/codetoolsoptions.pas +++ b/ide/codetoolsoptions.pas @@ -235,6 +235,7 @@ var CodeToolsOpts: TCodeToolsOptions; function ShowCodeToolsOptions(Options: TCodeToolsOptions; OnGetSynEditSettings: TNotifyEvent): TModalResult; +function GetTranslatedAtomTypes(a: TAtomType): string; implementation diff --git a/ide/lazarus.pp b/ide/lazarus.pp index bb69898b85..3bf3d91079 100644 --- a/ide/lazarus.pp +++ b/ide/lazarus.pp @@ -62,12 +62,14 @@ begin TMainIDE.ParseCmdLineOptions; // Show splashform - SplashForm := TSplashForm.Create(nil); - with SplashForm do begin - Show; - Paint; + if ShowSplashScreen then begin + SplashForm := TSplashForm.Create(nil); + with SplashForm do begin + Show; + Paint; + end; + Application.ProcessMessages; // process splash paint message end; - Application.ProcessMessages; // process splash paint message Application.CreateForm(TMainIDE, MainIDE); MainIDE.CreateOftenUsedForms; @@ -75,14 +77,17 @@ begin CheckHeapWrtMemCnt('lazarus.pp: TMainIDE created'); {$ENDIF} - SplashForm.StartTimer; + if (SplashForm<>nil) then + SplashForm.StartTimer; try Application.Run; except writeln('lazarus.pp - unhandled exception'); end; - SplashForm.Free; - SplashForm:=nil; + if (SplashForm<>nil) then begin + SplashForm.Free; + SplashForm:=nil; + end; writeln('LAZARUS END - cleaning up ...'); @@ -94,6 +99,9 @@ end. { $Log$ + Revision 1.46 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.45 2003/05/30 12:41:46 mattias added checks and texts for mixing gtk1 and gtk2 diff --git a/ide/lazarusidestrconsts.pas b/ide/lazarusidestrconsts.pas index ee96d188a4..55ef67fc1a 100644 --- a/ide/lazarusidestrconsts.pas +++ b/ide/lazarusidestrconsts.pas @@ -57,6 +57,7 @@ resourcestring lisIDEOptions = 'IDE Options:'; lisCmdLineLCLInterfaceSpecificOptions = 'LCL Interface specific options:'; + lisDoNotShowSplashScreen = 'Do not show splash screen'; lissecondaryConfigDirectoryWhereLazarusSearchesFor = ' secondary config ' +'directory, where Lazarus searches for config template files. Default is '; diff --git a/lcl/forms.pp b/lcl/forms.pp index 90b9a33e17..91fa7177a3 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -643,7 +643,8 @@ type TApplicationFlag = ( AppWaiting, AppIdleEndSent, - AppHandlingException + AppHandlingException, + AppNoExceptionMessages ); TApplicationFlags = set of TApplicationFlag; @@ -719,6 +720,7 @@ type function HelpContext(Context: THelpContext): Boolean; function HelpJump(const JumpID: string): Boolean; function HelpKeyword(const Keyword: String): Boolean; + procedure HideAllFormsWithStayOnTop; function IsWaiting: boolean; procedure CancelHint; procedure HideHint; @@ -878,6 +880,7 @@ procedure FreeInterfaceObject; procedure Register; + implementation @@ -887,6 +890,8 @@ uses var FocusMessages: Boolean; FocusCount: Integer; + HandlingException: boolean; + HaltingProgram: boolean; procedure Register; begin @@ -905,17 +910,20 @@ end; //------------------------------------------------------------------------------ -procedure ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer); -var - Mess : String; +procedure ExceptionOccurred(Sender: TObject; Addr,Frame: Pointer); Begin - Writeln('[FORMS.PP] ExceptionOccurred Procedure'); - Mess := Format(rsErrorOccurredInAtAddressFrame, [Sender.ClassName, #13#10, - HexStr(Cardinal(Addr), 8), #13#10, HexStr(Cardinal(Frame), 8)]); + Writeln('[FORMS.PP] ExceptionOccurred '); + if HaltingProgram or HandlingException then Halt; + HandlingException:=true; + if Sender<>nil then begin + writeln(' Sender=',Sender.ClassName); + if Sender is Exception then + writeln(' Exception=',Exception(Sender).Message); + end else + writeln(' Sender=nil'); if Application<>nil then - Application.MessageBox(PChar(Mess), PChar(rsException), mb_IconError+mb_Ok) - else - writeln(Mess); + Application.HandleException(Sender); + HandlingException:=false; end; //------------------------------------------------------------------------------ @@ -1340,6 +1348,8 @@ end; initialization FocusCount := 0; Focusmessages := True; + HandlingException := false; + HaltingProgram := false; HintWindowClass := THintWindow; LCLProc.OwnerFormDesignerModifiedProc:=@IfOwnerIsFormThenDesignerModified; Screen:= TScreen.Create(nil); diff --git a/lcl/grids.pas b/lcl/grids.pas index 3faf34c34a..543382932b 100644 --- a/lcl/grids.pas +++ b/lcl/grids.pas @@ -685,7 +685,8 @@ DeleteObject(Pen); ReleaseDC(Handle, Dc); FMoveLast:=P; } -Function RndStr:String; + +{Function RndStr:String; Var i: Integer; Begin @@ -693,16 +694,15 @@ Begin For i:=1 to 10 do begin Result:=Result+ Char(Ord('A')+Random(20)); End; -End; +End;} Function PointIgual(Const P1,P2: TPoint): Boolean; begin result:=(P1.X=P2.X)And(P1.Y=P2.Y); End; -Function RectIgual(Const R1,R2: TRect): Boolean; +{Function RectIgual(Const R1,R2: TRect): Boolean; begin Result:=CompareMem(@R1,@R2, SizeOf(R1)); - -End; +End;} Function Min(Const I,J: Integer): Integer; begin If IClientWidth Then - HScrDiv:= (ColCount-FixedRows-1)/(HorzScrollBar.range-ClientWidth); + HScrDiv:= Double(ColCount-FixedRows-1)/(HorzScrollBar.range-ClientWidth); {$Ifdef dbgScroll} Writeln('TotWidth=',GridWidth,'ClientWidth=',ClientWidth,' Horz Range=',HorzScrolLBar.Range); @@ -1248,7 +1248,7 @@ begin End; If VertScrolLBar.Range>ClientHeight Then - VScrDiv:= (RowCount-FixedRows-1)/(VertScrollBar.Range-ClientHeight); + VScrDiv:= Double(RowCount-FixedRows-1)/(VertScrollBar.Range-ClientHeight); {$Ifdef dbgScroll} Writeln('TotHeight=',GridHeight,'ClientHeight=',ClientHeight,' Vert Range=',VertScrolLBar.Range); diff --git a/lcl/include/application.inc b/lcl/include/application.inc index fb53bcc03c..1c5646016a 100644 --- a/lcl/include/application.inc +++ b/lcl/include/application.inc @@ -89,9 +89,7 @@ begin ApplicationActionComponent:=Self; inherited Create(AOwner); - // MG: if you prefer message boxes instead of terminal error messages uncomment - // the following line - //ExceptProc := @ExceptionOccurred; + ExceptProc := @ExceptionOccurred; end; {------------------------------------------------------------------------------} @@ -99,8 +97,11 @@ end; {------------------------------------------------------------------------------} destructor TApplication.Destroy; begin + // shutting down CancelHint; ShowHint := False; + + // destroying ApplicationActionComponent:=nil; FreeThenNil(FIcon); FreeThenNil(FList); @@ -646,16 +647,26 @@ end; ------------------------------------------------------------------------------} procedure TApplication.HandleException(Sender: TObject); begin + if Self=nil then exit; if AppHandlingException in FFlags then begin // there was an exception during showing the exception -> break the circle writeln('TApplication.HandleException: ', - 'there was a second exception during showing the first exception'); + 'there was another exception during showing the first exception'); exit; end; Include(FFlags,AppHandlingException); - if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0); + // before we do anything, write it down if ExceptObject is Exception then begin writeln('TApplication.HandleException ',Exception(ExceptObject).Message); + end; + // release capture and hide all forms with stay on top, so that + // a message can be shown + if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0); + HideAllFormsWithStayOnTop; + // handle the exception + if ExceptObject is Exception then begin + writeln('TApplication.HandleException Handling ', + '"',Exception(ExceptObject).Message,'" ...'); if not (ExceptObject is EAbort) then if Assigned(FOnException) then FOnException(Sender, Exception(ExceptObject)) @@ -723,6 +734,24 @@ begin Result := false; end; +{------------------------------------------------------------------------------ + procedure TApplication.HideAllFormsWithStayOnTop; +------------------------------------------------------------------------------} +procedure TApplication.HideAllFormsWithStayOnTop; +var + i: Integer; + AForm: TCustomForm; +begin + if (Screen=nil) then exit; + for i:=0 to Screen.CustomFormCount-1 do begin + AForm:=Screen.CustomForms[i]; + if AForm.FormStyle=fsStayOnTop then begin + writeln('TApplication.HideAllFormsWithStayOnTop ',AForm.Name,':',AForm.ClassName); + AForm.Hide; + end; + end; +end; + {------------------------------------------------------------------------------ function TApplication.IsWaiting: boolean; ------------------------------------------------------------------------------} @@ -757,8 +786,8 @@ begin end; {------------------------------------------------------------------------------ - TApplication Run - MainForm is loaded and control is passed to event processor. + TApplication Run + MainForm is loaded and control is passed to event processor. ------------------------------------------------------------------------------} procedure TApplication.Run; begin @@ -841,12 +870,20 @@ end; procedure TApplication.ShowException(E: Exception); var Msg: string; + MsgResult: Integer; begin + if AppNoExceptionMessages in FFlags then exit; Msg := E.Message; - if (Msg <> '') and (Msg[length(Msg)] > '.') then Msg := Msg + '.'; - if (not FTerminate) and (Self<>nil) then - MessageBox(PChar(Msg), PChar(GetTitle), MB_OK + MB_ICONERROR) - else + if (Msg <> '') and (Msg[length(Msg)] <> '.') then Msg := Msg + '.'; + if (not FTerminate) and (Self<>nil) then begin + MsgResult:=MessageBox(PChar(Msg),PChar(GetTitle), + MB_OKCANCEL + MB_ICONERROR); + if MsgResult<>mrOk then begin + Include(FFlags,AppNoExceptionMessages); + HaltingProgram:=true; + Halt; + end; + end else SysUtils.ShowException(ExceptObject, ExceptAddr); end; @@ -1027,6 +1064,9 @@ end; { ============================================================================= $Log$ + Revision 1.57 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.56 2003/06/02 21:37:30 mattias fixed debugger stop diff --git a/lcl/include/customform.inc b/lcl/include/customform.inc index 6aadc1e67d..9835e9c3a7 100644 --- a/lcl/include/customform.inc +++ b/lcl/include/customform.inc @@ -315,8 +315,6 @@ end; ShowWindow event handler. ------------------------------------------------------------------------------} procedure TCustomForm.WMShowWindow(var message: TLMShowWindow); -const - SHOW_TEXT: array[Boolean] of string = ('Hide', 'Show'); begin {$IFDEF VerboseFocus} write('TCustomForm.WMShowWindow A ',Name,':',ClassName,' fsShowing=',fsShowing in FFormState,' Msg.Show=',Message.Show); @@ -1434,6 +1432,9 @@ end; { ============================================================================= $Log$ + Revision 1.106 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.105 2003/06/16 23:12:59 mattias fixed TCustomForm.ShowModal when Self=nil diff --git a/lcl/include/customupdown.inc b/lcl/include/customupdown.inc index ff62523dc9..6462f3cf2a 100644 --- a/lcl/include/customupdown.inc +++ b/lcl/include/customupdown.inc @@ -128,7 +128,7 @@ begin aw := width div 2; if (FUpDown.Orientation = udHorizontal) then begin - tmp := (ah+1)/2; + tmp := double(ah+1)/2; if (tmp > aw) then begin ah := 2*aw - 1; aw := (ah+1) div 2; @@ -141,7 +141,7 @@ begin ah := max(ah, 5); end else begin - tmp := (aw+1)/2; + tmp := double(aw+1)/2; if (tmp > ah) then begin aw := 2*ah - 1; diff --git a/lcl/include/filectrl.inc b/lcl/include/filectrl.inc index a54205354c..90f3a39b53 100644 --- a/lcl/include/filectrl.inc +++ b/lcl/include/filectrl.inc @@ -808,23 +808,6 @@ end; ------------------------------------------------------------------------------} function SearchFileInPath(const Filename, BasePath, SearchPath, Delimiter: string; Flags: TSearchFileInPathFlags): string; - - function FileDoesExists(const AFilename: string): boolean; - var s: string; - begin - s:=ExpandFilename(TrimFilename(AFilename)); - Result:=FileExists(s); - if Result then begin - SearchFileInPath:=s; - exit; - end; - {$IFNDEF Win32} - if sffSearchLoUpCase in Flags then begin - - end; - {$ENDIF} - end; - var p, StartPos, l: integer; CurPath, Base: string; @@ -894,6 +877,9 @@ end; { $Log$ + Revision 1.26 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.25 2003/05/28 21:16:47 mattias added a help and a more button tot he package editor diff --git a/lcl/include/promptdialog.inc b/lcl/include/promptdialog.inc index a63df311bd..419483b50a 100644 --- a/lcl/include/promptdialog.inc +++ b/lcl/include/promptdialog.inc @@ -24,12 +24,12 @@ const bkOk, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry, bkIgnore, bkAll, bkCustom, bkCustom); - DialogButtonText : Array[idButtonOK..idButtonNoToAll] of String = ( + {DialogButtonText : Array[idButtonOK..idButtonNoToAll] of String = ( rsmbOk, rsmbCancel, rsmbHelp, rsmbYes, rsmbNo, rsmbClose, rsmbAbort, - rsmbRetry, rsmbIgnore, rsmbAll, rsmbYesToAll, rsmbNoToAll); + rsmbRetry, rsmbIgnore, rsmbAll, rsmbYesToAll, rsmbNoToAll);} - DialogCaption : Array[idDialogWarning..idDialogConfirm] of String = ( - rsMtWarning, rsMtError, rsMtInformation, rsMtConfirmation); + {DialogCaption : Array[idDialogWarning..idDialogConfirm] of String = ( + rsMtWarning, rsMtError, rsMtInformation, rsMtConfirmation);} type TPromptDialog = class(TForm) @@ -379,6 +379,9 @@ end; { $Log$ + Revision 1.5 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.4 2003/03/25 10:45:41 mattias reduced focus handling and improved focus setting diff --git a/lcl/include/toolbar.inc b/lcl/include/toolbar.inc index 7a1aaac10e..4678a0db36 100644 --- a/lcl/include/toolbar.inc +++ b/lcl/include/toolbar.inc @@ -1287,13 +1287,6 @@ begin end; -function ToolMenuGetMsgHook(Code: Integer; WParam: Longint; - var Msg: TMsg): Longint; stdcall; -Begin - // ToDo - Result:=0; -end; - procedure InitToolMenuHooks; begin end; @@ -1302,14 +1295,6 @@ procedure ReleaseToolMenuHooks; begin end; - -function ToolMenuKeyMsgHook(Code: Integer; WParam: Longint; - var Msg: TMsg): Longint; stdcall; -begin - // ToDo - Result:=0; -end; - procedure InitToolMenuKeyHooks; begin end; @@ -1506,6 +1491,9 @@ end; { ============================================================================= $Log$ + Revision 1.11 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.10 2002/12/29 11:10:45 mattias fixed form FActive, cleanups diff --git a/lcl/lresources.pp b/lcl/lresources.pp index 5df161c562..d1d64992c5 100644 --- a/lcl/lresources.pp +++ b/lcl/lresources.pp @@ -296,7 +296,6 @@ end; procedure TLResourceList.Add(const Name,ValueType: AnsiString; Values: array of string); -const ProcName = 'TLResourceList.Add'; var NewLResource: TLResource; i, TotalLen, ValueCount, p: integer; @@ -513,11 +512,11 @@ begin ReadError(rsInvalidPropertyValue); end; -procedure PropertyNotFound(const Name: string); +{procedure PropertyNotFound(const Name: string); begin ReadError(Format(rsPropertyDoesNotExist,[Name])); end; - +} procedure TDelphiReader.SkipBytes(Count: Integer); begin FStream.Position:=FStream.Position+Count; diff --git a/lcl/menus.pp b/lcl/menus.pp index 0e9386a40e..8bb4b89ba4 100644 --- a/lcl/menus.pp +++ b/lcl/menus.pp @@ -314,12 +314,12 @@ implementation var CommandPool: TBits; -function UniqueCommand: Word; +{function UniqueCommand: Word; begin Result := CommandPool.OpenBit; CommandPool[Result] := True; end; - +} function ShortCutToText(ShortCut: TShortCut): string; begin Result:=ShortCutToShortCutText(ShortCut); @@ -374,6 +374,9 @@ end. { $Log$ + Revision 1.45 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.44 2003/06/09 09:20:27 mattias removed menubar.inc diff --git a/lcl/stdctrls.pp b/lcl/stdctrls.pp index 8808030300..d1a2903605 100644 --- a/lcl/stdctrls.pp +++ b/lcl/stdctrls.pp @@ -966,10 +966,6 @@ implementation type - TSelection = record - Startpos, EndPos: Integer; - end; - TMemoStrings = class(TStrings) private FMemo: TCustomMemo; @@ -1463,6 +1459,9 @@ end. { ============================================================================= $Log$ + Revision 1.99 2003/06/23 09:42:09 mattias + fixes for debugging lazarus + Revision 1.98 2003/06/16 22:47:19 mattias fixed keeping TForm.Visible=false diff --git a/packager/packagelinks.pas b/packager/packagelinks.pas index b8da4d0e82..f200d6336c 100644 --- a/packager/packagelinks.pas +++ b/packager/packagelinks.pas @@ -123,9 +123,6 @@ var implementation -const - UserPkgLinkFile = 'packagefiles.xml'; - function ComparePackageLinks(Data1, Data2: Pointer): integer; var Link1: TPackageLink;