paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-28 03:40:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

updated memcheck.pas from heaptrc.pp

Browse Source 
git-svn-id: trunk@6225 -
This commit is contained in:
mattias 2004-11-10 15:25:32 +00:00
parent 454f333332
commit d160b3b743
13 changed files with 162 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
components/codetools/laz_dom.pas
View File

@ -923,6 +923,8 @@ var AVLNode: TAVLTreeNode;
begin
Result:=nil;
if FChildNodeTree<>nil then begin
//if FChildNodeTree.ConsistencyCheck<>0 then
// raise exception.Create('TDOMNode_WithChildren.FindNode');
AVLNode:=FChildNodeTree.FindKey(DOMPChar(ANodeName),
@CompareDOMStringWithDOMNode);
if AVLNode<>nil then
@ -949,12 +951,16 @@ begin
FChildNodeTree:=TAVLTree.Create(@CompareDOMNodeWithDOMNode);
if FChildNodeTree.Find(NewNode)=nil then
FChildNodeTree.Add(NewNode);
//if FChildNodeTree.ConsistencyCheck<>0 then
// raise exception.Create('TDOMNode_WithChildren.FindNode');
end;
procedure TDOMNode_WithChildren.RemoveFromChildNodeTree(OldNode: TDOMNode);
begin
if FChildNodeTree<>nil then
FChildNodeTree.Remove(OldNode);
//if (FChildNodeTree<>nil) and (FChildNodeTree.ConsistencyCheck<>0) then
// raise exception.Create('TDOMNode_WithChildren.FindNode');
end;
@ -1633,6 +1639,9 @@ end.
{
$Log$
Revision 1.9 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.8 2004/11/06 19:49:12 mattias
renamed avl_tree.pas to oldavltree.pas for new fpc 1.9.5

30
components/codetools/laz_xmlcfg.pas
View File

@ -139,6 +139,7 @@ var
PathLen: integer;
StartPos, EndPos: integer;
begin
//CheckHeapWrtMemCnt('TXMLConfig.GetValue A '+APath);
Result:=ADefault;
PathLen:=length(APath);
Node := doc.DocumentElement;
@ -147,19 +148,35 @@ begin
EndPos:=StartPos;
while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
if EndPos>PathLen then break;
SetLength(NodeName,EndPos-StartPos);
Move(APath[StartPos],NodeName[1],EndPos-StartPos);
if EndPos>StartPos then begin
NodeName:='';
SetLength(NodeName,EndPos-StartPos);
//UniqueString(NodeName);
Move(APath[StartPos],NodeName[1],EndPos-StartPos);
Child := Node.FindNode(NodeName);
//writeln('TXMLConfig.GetValue C NodeName="',NodeName,'" ',
// PCardinal(Cardinal(NodeName)-8)^,' ',PCardinal(Cardinal(NodeName)-4)^);
//CheckHeapWrtMemCnt('TXMLConfig.GetValue B2');
if not Assigned(Child) then exit;
Node := Child;
end;
StartPos:=EndPos+1;
Child := Node.FindNode(NodeName);
if not Assigned(Child) then exit;
Node := Child;
//CheckHeapWrtMemCnt('TXMLConfig.GetValue D');
end;
if StartPos>PathLen then exit;
//CheckHeapWrtMemCnt('TXMLConfig.GetValue E');
NodeName:='';
SetLength(NodeName,PathLen-StartPos+1);
//CheckHeapWrtMemCnt('TXMLConfig.GetValue F '+IntToStr(length(NodeName))+' '+IntToStr(StartPos)+' '+IntToStr(length(APath))+' '+APath[StartPos]);
//UniqueString(NodeName);
Move(APath[StartPos],NodeName[1],length(NodeName));
//CheckHeapWrtMemCnt('TXMLConfig.GetValue G');
//writeln('TXMLConfig.GetValue G2 NodeName="',NodeName,'"');
Attr := Node.Attributes.GetNamedItem(NodeName);
if Assigned(Attr) then
Result := Attr.NodeValue;
//CheckHeapWrtMemCnt('TXMLConfig.GetValue H');
//writeln('TXMLConfig.GetValue END Result="',Result,'"');
end;
function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer;
@ -355,6 +372,9 @@ end;
end.
{
$Log$
Revision 1.12 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.11 2004/10/28 09:38:16 mattias
fixed COPYING.modifiedLGPL links

102
components/codetools/memcheck.pas
View File

@ -48,12 +48,6 @@ interface
Procedure DumpHeap;
Procedure MarkHeap;
{ define EXTRA to add more
tests :
- keep all memory after release and
check by CRC value if not changed after release
WARNING this needs extremely much memory (PM) }
type
tFillExtraInfoProc = procedure(p : pointer);
tDisplayExtraInfoProc = procedure (var ptext : text;p : pointer);
@ -69,16 +63,16 @@ const
{ tracing level
splitted in two if memory is released !! }
{$ifdef EXTRA}
tracesize = 64; // normal: 16
tracesize = 64; // fpc: 16 (but the LCL needs more than 20)
{$else EXTRA}
tracesize = 32; // normal: 8
tracesize = 32; // fpc: 8 (but the LCL needs more than 20)
{$endif EXTRA}
{ install heaptrc memorymanager }
useheaptrace : boolean = true;
{ less checking }
quicktrace : boolean = true;
{ calls halt() on error }
HaltOnError : boolean = false;
HaltOnError : boolean = true;
{ ExceptOnError: raise gdb catchable exception on error }
ExceptOnError: boolean = true;
{ keepreleased: set this to true if you suspect that memory
@ -581,7 +575,17 @@ end;
function TraceMemSize(p:pointer):ptrint;
var
l : ptrint;
pp : pheap_mem_info;
begin
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
TraceMemSize:=pp^.size;
end;
function TraceFreeMem(p:pointer):ptrint;
var
l : ptrint;
pp : pheap_mem_info;
begin
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
@ -589,23 +593,12 @@ begin
dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
if add_tail then
dec(l,sizeof(ptrint));
TraceMemSize:=l;
end;
function TraceFreeMem(p:pointer):ptrint;
var
size : ptrint;
pp : pheap_mem_info;
begin
pp:=pheap_mem_info(p-sizeof(theap_mem_info));
size:=TraceMemSize(p);
{ this can never happend normaly }
if pp^.size>size then
if pp^.size>l then
begin
dump_wrong_size(pp,size,ptext^);
dump_wrong_size(pp,l,ptext^);
{$ifdef EXTRA}
dump_wrong_size(pp,size,error_file);
dump_wrong_size(pp,l,error_file);
{$endif EXTRA}
end;
TraceFreeMem:=TraceFreeMemSize(p,pp^.size);
@ -619,8 +612,8 @@ end;
function TraceReAllocMem(var p:pointer;size:ptrint):Pointer;
var
newP: pointer;
oldsize,
allocsize,
movesize,
i : ptrint;
bp : pointer;
pl : pdword;
@ -658,7 +651,7 @@ begin
dump_error(pp,error_file);
{$endif EXTRA}
{ don't release anything in this case !! }
if haltonerror then Halt(1);
if haltonerror then halt(1);
exit;
end;
{ save info }
@ -678,11 +671,17 @@ begin
if not SysTryResizeMem(pp,allocsize) then
begin
{ get a new block }
oldsize:=TraceMemSize(p);
newP := TraceGetMem(size);
{ move the data }
if newP <> nil then
move(p^,newP^,oldsize);
begin
movesize:=TraceMemSize(p);
{if the old size is larger than the new size,
move only the new size}
if movesize>size then
movesize:=size;
move(p^,newP^,movesize);
end;
{ release p }
traceFreeMem(p);
{ return the new pointer }
@ -699,8 +698,8 @@ begin
{ Recreate the info block }
pp^.sig:=$DEADBEEF;
pp^.size:=size;
pp^.extra_info_size:=word(oldextrasize);
pp^.exact_info_size:=word(oldexactsize);
pp^.extra_info_size:=oldextrasize;
pp^.exact_info_size:=oldexactsize;
{ add the new extra_info and tail }
if pp^.extra_info_size>0 then
begin
@ -751,23 +750,19 @@ var
edata : longword; external name 'edata';
{$endif go32v2}
{$ifdef win32}
{$ifdef linux}
var
{ I found no symbol for start of text section :(
so we usee the _mainCRTStartup which should be
in wprt0.ow or wdllprt0.ow PM }
text_begin : longword;external name '_mainCRTStartup';
data_end : longword;external name '__data_end__';
etext: ptruint; external name '_etext';
edata : ptruint; external name '_edata';
{$endif}
procedure CheckPointer(p : pointer);[{$IFNDEF NOSAVEREGISTERS}saveregisters,{$ENDIF}public, alias : 'FPC_CHECKPOINTER'];
procedure CheckPointer(p : pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}[public, alias : 'FPC_CHECKPOINTER'];
var
i : ptrint;
pp : pheap_mem_info;
{$if defined(go32v2) or defined(win32)}
get_ebp,stack_top : longword;
data_end : longword;
{$endif}
//get_ebp,stack_top : longword;
//data_end : longword;
label
_exit;
begin
@ -797,14 +792,21 @@ begin
{ I don't know where the stack is in other OS !! }
{$ifdef win32}
{ inside stack ? }
asm
movl %ebp,get_ebp
end;
if (ptruint(p)>get_ebp) and
if (ptruint(p)>ptruint(get_frame)) and
(ptruint(p)<Win32StackTop) then
goto _exit;
{$endif win32}
{$ifdef linux}
{ inside stack ? }
if (ptruint(p)>ptruint(get_frame)) and
(ptruint(p)<$c0000000) then //todo: 64bit!
goto _exit;
{ inside data ? }
if (ptruint(p)>=ptruint(@etext)) and (ptruint(p)<ptruint(@edata)) then
goto _exit;
{$endif linux}
{ first try valid list faster }
{$ifdef EXTRA}
@ -827,7 +829,7 @@ begin
begin
writeln(ptext^,'corrupted heap_mem_info');
dump_error(pp,ptext^);
Halt(1);
halt(1);
end;
end
else
@ -836,7 +838,7 @@ begin
if i>getmem_cnt-freemem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
Halt(1);
halt(1);
end;
end;
i:=0;
@ -862,7 +864,7 @@ begin
if i>getmem_cnt then
begin
writeln(ptext^,'error in linked list of heap_mem_info');
Halt(1);
halt(1);
end;
end;
writeln(ptext^,'pointer $',hexstr(ptrint(p),8),' does not point to valid memory block');
@ -1015,6 +1017,7 @@ end;
{*****************************************************************************
Install MemoryManager
*****************************************************************************}
const
TraceManager:TMemoryManager=(
NeedLock : true;
@ -2318,6 +2321,9 @@ end.
{
$Log$
Revision 1.36 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.35 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk

2
components/codetools/memcheck_laz.inc
View File

@ -21,6 +21,7 @@ procedure Halt(ErrNum: byte); forward;
{$ENDIF MC_ImplementationStart}
{$IFDEF MC_ImplementationEnd}
// override RunError, so we can handle them according to the flags
procedure RunError(RunErrorNumber: word);
begin
if ExceptOnError then begin
@ -31,6 +32,7 @@ begin
System.RunError(RunErrorNumber);
end;
// override RunError, so we can handle them according to the flags
procedure Halt(ErrNum: byte);
begin
if ExceptOnError then begin

78
components/turbopower_ipro/iphtml.pas
View File

@ -7695,7 +7695,7 @@ end;
procedure TIpHtml.SetDefaultProps;
begin
{$IFDEF IP_LAZARUS}
Defaultprops.FontName := 'Default';
Defaultprops.FontName := Graphics.DefFontData.Name;
{$ELSE}
Defaultprops.FontName := 'Times New Roman';
{$ENDIF}
@ -9566,21 +9566,21 @@ var
procedure SetWordInfoLength(NewLength : Integer);
var
NewWordInfoSize: Integer;
{$IFNDEF IP_LAZARUS}
NewWordInfo: PWordList;
{$ENDIF}
begin
if (WordInfo = nil) or (NewLength > WordInfoSize) then begin
NewWordInfoSize := ((NewLength div 256) + 1) * 256;
{$IFDEF IP_LAZARUS code below does not check if WordInfo<>nil}
ReallocMem(WordInfo,NewWordInfoSize * sizeof(TWordInfo));
{$ELSE}
NewWordInfo := AllocMem(NewWordInfoSize * sizeof(TWordInfo));
{$IFDEF IP_LAZARUS Buggy}
if WordInfo<>nil then
{$ENDIF}
move(WordInfo^, NewWordInfo^, WordInfoSize);
WordInfoSize := NewWordInfoSize;
{$IFDEF IP_LAZARUS Buggy}
if WordInfo<>nil then
{$ENDIF}
Freemem(WordInfo);
move(WordInfo^, NewWordInfo^, WordInfoSize);
Freemem(WordInfo);
WordInfo := NewWordInfo;
{$ENDIF}
WordInfoSize := NewWordInfoSize;
end;
end;
@ -9618,7 +9618,7 @@ var
writeln('/////////////////');
end;
*)
begin
if ElementQueue.Count = 0 then exit;
{DumpQueue;} {debug}
@ -17187,7 +17187,7 @@ end;
procedure TIpHtmlCustomPanel.WMGetDlgCode(var Msg: TMessage);
begin
{ we want 'em all! For Lazarus: Then use OnKeyDown }
{ we want 'em all! For Lazarus: Then use OnKeyDown! }
Msg.Result := DLGC_WANTALLKEYS +
DLGC_WANTARROWS +
DLGC_WANTCHARS +
@ -17427,7 +17427,9 @@ end;
procedure TIntArr.SetValue(Index, Value: Integer);
var
{$IFNDEF IP_LAZARUS}
Tmp: PInternalIntArr;
{$ENDIF}
NewSize: Integer;
begin
if Index >= 0 then begin
@ -17436,18 +17438,17 @@ begin
repeat
inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil}
ReallocMem(InternalIntArr,NewSize * sizeof(Integer));
IntArrSize := NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
{$IFDEF IP_LAZARUS Buggy}
if (InternalIntArr<>nil) then
{$ENDIF}
move(InternalIntArr^, Tmp^, IntArrSize * sizeof(Integer));
move(InternalIntArr^, Tmp^, IntArrSize * sizeof(Integer));
IntArrSize := NewSize; {!!.12}
{inc(IntArrSize, NewSize);} {Deleted !!.12}
{$IFDEF IP_LAZARUS Buggy}
if (InternalIntArr<>nil) then
{$ENDIF}
Freemem(InternalIntArr);
Freemem(InternalIntArr);
InternalIntArr := Tmp;
{$ENDIF}
end;
InternalIntArr^[Index] := Value;
end;
@ -17486,7 +17487,9 @@ end;
procedure TRectArr.SetValue(Index: Integer; Value: PRect);
var
{$IFNDEF IP_LAZARUS}
Tmp: PInternalRectArr;
{$ENDIF}
NewSize: Integer;
begin
Assert(Self <> nil);
@ -17496,17 +17499,16 @@ begin
repeat
inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil and set buggy IntArrSize}
ReallocMem(InternalRectArr,NewSize * sizeof(Integer));
IntArrSize:=NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
{$IFDEF IP_LAZARUS buggy}
if InternalRectArr<>nil then
{$ENDIF}
move(InternalRectArr^, Tmp^, IntArrSize * sizeof(Integer));
move(InternalRectArr^, Tmp^, IntArrSize * sizeof(Integer));
inc(IntArrSize, NewSize);
{$IFDEF IP_LAZARUS buggy}
if InternalRectArr<>nil then
{$ENDIF}
Freemem(InternalRectArr);
Freemem(InternalRectArr);
InternalRectArr := Tmp;
{$ENDIF}
end;
InternalRectArr^[Index] := Value;
end;
@ -17539,7 +17541,9 @@ end;
function TRectRectArr.GetValue(Index: Integer): TRectArr;
var
{$IFNDEF IP_LAZARUS}
Tmp: PInternalRectRectArr;
{$ENDIF}
NewSize: Integer;
begin
if Index >= 0 then begin
@ -17548,17 +17552,16 @@ begin
repeat
inc(NewSize, TINTARRGROWFACTOR);
until Index < NewSize;
{$IFDEF IP_LAZARUS code below does not check if InternalIntArr<>nil and set buggy IntArrSize}
ReallocMem(InternalRectRectArr,NewSize * sizeof(Integer));
IntArrSize:=NewSize;
{$ELSE}
Tmp := AllocMem(NewSize * sizeof(Integer));
{$IFDEF IP_LAZARUS buggy}
if InternalRectRectArr<>nil then
{$ENDIF}
move(InternalRectRectArr^, Tmp^, IntArrSize * sizeof(Integer));
move(InternalRectRectArr^, Tmp^, IntArrSize * sizeof(Integer));
inc(IntArrSize, NewSize);
{$IFDEF IP_LAZARUS buggy}
if InternalRectRectArr<>nil then
{$ENDIF}
Freemem(InternalRectRectArr);
Freemem(InternalRectRectArr);
InternalRectRectArr := Tmp;
{$ENDIF}
end;
Result := InternalRectRectArr^[Index];
if Result = nil then begin
@ -17592,6 +17595,9 @@ initialization
InitScrollProcs;
{
$Log$
Revision 1.17 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.16 2004/10/04 09:36:22 mattias
fixed compilation of ipro

89
ide/compileroptions.pp
View File

@ -257,95 +257,6 @@ type
property XMLConfigFile: TXMLConfig read FXMLConfig write FXMLConfig;
property Loaded: Boolean read fLoaded write fLoaded;
{ // search paths:
property IncludeFiles: String read fIncludeFiles write SetIncludeFiles;
property Libraries: String read fLibraries write SetLibraries;
property OtherUnitFiles: String read fOtherUnitFiles write SetOtherUnitFiles;
property ObjectPath: string read FObjectPath write SetObjectPath;
property SrcPath: string read FSrcPath write SetSrcPath;
property UnitOutputDirectory: string read fUnitOutputDir write SetUnitOutputDir;
property DebugPath: string read FDebugPath write SetDebugPath;
property LCLWidgetType: string read fLCLWidgetType write fLCLWidgetType;
// parsing:
property AssemblerStyle: Integer read fAssemblerStyle write fAssemblerStyle;
property D2Extensions: Boolean read fD2Ext write fD2Ext;
property CStyleOperators: Boolean read fCStyleOp write fCStyleOp;
property IncludeAssertionCode: Boolean
read fIncludeAssertionCode write fIncludeAssertionCode;
property DelphiCompat: Boolean read fDelphiCompat write fDelphiCompat;
property AllowLabel: Boolean read fAllowLabel write fAllowLabel;
property UseAnsiStrings: Boolean read fUseAnsiStr write fUseAnsiStr;
property CPPInline: Boolean read fCPPInline write fCPPInline;
property CStyleMacros: Boolean read fCMacros write fCMacros;
property TPCompatible: Boolean read fTPCompat write fTPCompat;
property GPCCompat: Boolean read fGPCCompat write fGPCCompat;
property InitConstructor: Boolean read fInitConst write fInitConst;
property StaticKeyword: Boolean read fStaticKwd write fStaticKwd;
// code generation:
property UnitStyle: Integer read fUnitStyle write fUnitStyle;
property IOChecks: Boolean read fIOChecks write fIOChecks;
property RangeChecks: Boolean read fRangeChecks write fRangeChecks;
property OverflowChecks: Boolean read fOverflowChecks write fOverflowChecks;
property StackChecks: Boolean read fStackChecks write fStackChecks;
property EmulatedFloatOpcodes: boolean read FEmulatedFloatOpcodes
write FEmulatedFloatOpcodes;
property HeapSize: Integer read fHeapSize write fHeapSize;
property VerifyObjMethodCall: boolean read FEmulatedFloatOpcodes
write FEmulatedFloatOpcodes;
property Generate: TCompilationGenerateCode read fGenerate write fGenerate;
property TargetCPU: string read fTargetCPU write SetTargetCPU; // general type
property TargetProcessor: Integer read fTargetProc write SetTargetProc; // specific
property TargetOS: string read fTargetOS write SetTargetOS;
property VariablesInRegisters: Boolean read fVarsInReg write fVarsInReg;
property UncertainOptimizations: Boolean read fUncertainOpt write fUncertainOpt;
property OptimizationLevel: Integer read fOptLevel write fOptLevel;
// linking:
property GenerateDebugInfo: Boolean read fGenDebugInfo write fGenDebugInfo;
property GenerateDebugDBX: Boolean read fGenDebugDBX write fGenDebugDBX;
property UseLineInfoUnit: Boolean read fUseLineInfoUnit write fUseLineInfoUnit;
property UseHeaptrc: Boolean read fUseHeaptrc write fUseHeaptrc;
property UseValgrind: Boolean read fUseValgrind write fUseValgrind;
property GenGProfCode: Boolean read fGenGProfCode write fGenGProfCode;
property StripSymbols: Boolean read fStripSymbols write fStripSymbols;
property LinkStyle: Integer read fLinkStyle write fLinkStyle;
property PassLinkerOptions: Boolean read fPassLinkerOpt write fPassLinkerOpt;
property LinkerOptions: String read fLinkerOptions write SetLinkerOptions;
property Win32GraphicApp: boolean read FWin32GraphicApp write FWin32GraphicApp;
// messages:
property ShowErrors: Boolean read fShowErrors write fShowErrors;
property ShowWarn: Boolean read fShowWarn write fShowWarn;
property ShowNotes: Boolean read fShowNotes write fShowNotes;
property ShowHints: Boolean read fShowHints write fShowHints;
property ShowGenInfo: Boolean read fShowGenInfo write fShowGenInfo;
property ShowLineNum: Boolean read fShowLineNum write fShowLineNum;
property ShowAll: Boolean read fShowAll write fShowAll;
property ShowAllProcsOnError: Boolean
read fShowAllProcsOnError write fShowAllProcsOnError;
property ShowDebugInfo: Boolean read fShowDebugInfo write fShowDebugInfo;
property ShowUsedFiles: Boolean read fShowUsedFiles write fShowUsedFiles;
property ShowTriedFiles: Boolean read fShowTriedFiles write fShowTriedFiles;
property ShowDefMacros: Boolean read fShowDefMacros write fShowDefMacros;
property ShowCompProc: Boolean read fShowCompProc write fShowCompProc;
property ShowCond: Boolean read fShowCond write fShowCond;
property ShowNothing: Boolean read fShowNothing write fShowNothing;
property ShowHintsForUnusedUnitsInMainSrc: Boolean
read fShowHintsForUnusedUnitsInMainSrc write fShowHintsForUnusedUnitsInMainSrc;
property WriteFPCLogo: Boolean read fWriteFPCLogo write fWriteFPCLogo;
property StopAfterErrCount: integer
read fStopAfterErrCount write fStopAfterErrCount;
// other
property DontUseConfigFile: Boolean read fDontUseConfigFile
write fDontUseConfigFile;
property AdditionalConfigFile: Boolean read fAdditionalConfigFile
write fAdditionalConfigFile;
property ConfigFilePath: String read fConfigFilePath write fConfigFilePath;
property CustomOptions: string read fCustomOptions write SetCustomOptions;}
// compilation
property CompilerPath: String read fCompilerPath write SetCompilerPath;
property ExecuteBefore: TCompilationTool read fExecuteBefore;

2
ide/compileroptionsdlg.pp
View File

@ -1403,7 +1403,7 @@ begin
with chkChecksStack do
begin
Parent := grpChecks;
Caption := dlgCOStack+' (-Cs)';
Caption := dlgCOStack+' (-Ct)';
Top := 27;
Left := 102;
Width := 100;

5
ide/lazarus.pp
View File

@ -40,7 +40,7 @@ program Lazarus;
{$R *.res}
{$ENDIF}
{ $DEFINE IDE_MEM_CHECK}
{off $DEFINE IDE_MEM_CHECK}
uses
//cmem,
@ -99,6 +99,9 @@ end.
{
$Log$
Revision 1.63 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.62 2004/09/17 20:04:34 vincents
replaced writeln by DebugLn

20
lcl/extgraphics.pas
View File

@ -25,7 +25,7 @@ unit ExtGraphics;
interface
uses Classes, Graphics, math;
uses Classes, LCLProc, Graphics, math;
type
TShapeDirection = (atUp, atDown, atLeft, atRight);
@ -49,7 +49,7 @@ procedure PaintFivePointLineStar(Canvas: TCanvas; const PaintRect: TRect);
procedure PaintStarN(Canvas: TCanvas;cx,cy,r,n,a:Integer);
procedure CalculatePentagonPoints(PentagonRect:TRect;var P1,P2,P3,P4,P5:TPoint);
procedure CalculatePentagonPoints(const PentagonRect:TRect;var P1,P2,P3,P4,P5:TPoint);
function LinesPointOfIntersection(const Line1a,Line1b,Line2a,line2b:TPoint):TPoint;
implementation
@ -338,7 +338,7 @@ begin
do begin
if (i mod 2)=0 then r0:=r else r0:=r1;
alpha:=a+(0.5+i/n)*Pi;
cs:=Round(r0*cos(alpha));
cs:=RoundToInt(r0*cos(alpha));
P[i].x:=cx+cs;
P[i].y:=cy-Round(r0*sin(alpha));
end;
@ -350,7 +350,8 @@ begin
Canvas.Polygon(P);
end;
procedure CalculatePentagonPoints(PentagonRect:TRect;var P1,P2,P3,P4,P5:TPoint);
procedure CalculatePentagonPoints(const PentagonRect:TRect;
var P1,P2,P3,P4,P5:TPoint);
var cx,cy,dy,dx:Integer; r:real;
begin
P1.y:=PentagonRect.Top;
@ -359,13 +360,13 @@ begin
P4.y:=PentagonRect.Bottom;
P5.x:=PentagonRect.Right;
P1.x:=(PentagonRect.Right+PentagonRect.Left) div 2;
dy:=round((P1.x-P2.x)*tan(Pi/10));
dy:=RoundToInt((P1.x-P2.x)*tan(Pi/10));
r := sqrt(dy*dy+(P1.x-P2.x)*(P1.x-P2.x));
cx:=P1.x;
cy:=P1.y+round(r);
P2.y:=cy-dy;
P5.y:=P2.y;
dx:=round(r*sin(Pi/5));
dx:=RoundToInt(r*sin(Pi/5));
P3.x:=cx-dx;
P4.x:=cx+dx;
end;
@ -384,8 +385,8 @@ begin
b2:=-k2*x3+y3;
x:=(b1-b2)/(k2-k1);
y:=(k2*b1-k1*b2)/(k2-k1);
p.x:=round(x);
p.y:=round(y);
p.x:=RoundToInt(x);
p.y:=RoundToInt(y);
LinesPointOfIntersection:=p;
end;
@ -395,6 +396,9 @@ end.
{ =============================================================================
$Log$
Revision 1.4 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.3 2004/10/01 13:31:23 mattias
updated finnish translation from Seppo

5
lcl/include/fileutil.inc
View File

@ -857,7 +857,7 @@ var
begin
Result:=false;
if (Filename='') or (Masks='') then exit;
TrimmedFile:=TrimFilename(Filename); // do not expand
TrimmedFile:=TrimFilename(Filename); // only cleanup, do not expand
// try each Mask
MasksLen:=length(Masks);
FileLen:=length(TrimmedFile);
@ -1069,6 +1069,9 @@ end;
{
$Log$
Revision 1.3 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.2 2004/10/01 11:44:32 vincents
Fixed ForceDirectory, if DirectoryName did not end with PathDelim

5
lcl/interfaces/gtk/gtkproc.inc
View File

@ -4930,7 +4930,7 @@ begin
// Send the unmodified keysym ?
if (ssShift in NewModifier)
and ((NewKey < VK_F1) or (NewKey > VK_F24) )
and ((NewKey < VK_F1) or (NewKey > VK_F24))
then GDKKey := GetVKeyInfo(NewKey).KeySym[1]
else GDKKey := GetVKeyInfo(NewKey).KeySym[0];
@ -7792,6 +7792,9 @@ end;
{ =============================================================================
$Log$
Revision 1.318 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.317 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk

2
lcl/interfaces/gtk/gtkwsstdctrls.pp
View File

@ -661,7 +661,7 @@ procedure TGtkWSCustomComboBox.SetMaxLength(
const ACustomComboBox: TCustomComboBox; NewLength: integer);
begin
gtk_entry_set_max_length(PGtkEntry(PGtkCombo(ACustomComboBox.Handle)^.entry),
NewLength);
guint16(NewLength));
end;
procedure TGtkWSCustomComboBox.SetStyle(

5
lcl/lclintf.pas
View File

@ -91,7 +91,7 @@ var
{$IFNDEF Win32}
function GetTickCount: DWord;
begin
Result := Trunc(Now * 24 * 60 * 60 * 1000);
Result := DWord(Trunc(Now * 24 * 60 * 60 * 1000));
end;
{$ENDIF}
@ -179,6 +179,9 @@ end.
{
$Log$
Revision 1.18 2004/11/10 15:25:32 mattias
updated memcheck.pas from heaptrc.pp
Revision 1.17 2004/11/03 22:59:58 marc
* fixed GetTickCount