File: testoldfpcbugs.pas

package info (click to toggle)
castle-game-engine 5.0.0-3
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 164,776 kB
  • ctags: 30,841
  • sloc: pascal: 168,882; cpp: 1,340; objc: 730; makefile: 492; sh: 477; xml: 434; php: 1
file content (230 lines) | stat: -rw-r--r-- 6,094 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
{
  Copyright 2004-2014 Michalis Kamburelis.

  This file is part of "Castle Game Engine".

  "Castle Game Engine" is free software; see the file COPYING.txt,
  included in this distribution, for details about the copyright.

  "Castle Game Engine" is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

  ----------------------------------------------------------------------------
}

{ A really old test unit, testing some FPC 1.0.x bugs (or, sometimes,
  just some less-visible features that I wanted to make sure work right,
  and they did). They are all fixed, since a long long time. }
unit TestOldFPCBugs;

interface

uses
  fpcunit, testutils, testregistry;

type
  TTestOldFPCBugs = class(TTestCase)
  published
    procedure TestInherited;
    procedure TestMethodPass;
    procedure TestCompareMemBug;
    procedure TestFormatIncompatibility;
    procedure TestSizeOfObject;
    procedure TestOthers;
    procedure TestSwapEndian;
  end;

implementation

uses SysUtils;

{ TestInherited -------------------------------------------------------------- }

{ sprawdzalem tylko czy freepascal na pewno dziala tak :
  - wywolanie kontruktora/destruktora z wnetrza obiektu nie powoduje
    zadnej alokacji/dealokacji pamieci na obiekt czy na jego VMT.
    Wywoluje to tylko zawarty tam normalny kod.
  - dopiero wywolanie konstrukt/destrukt z zewnatrz powoduje ze
    najpierw przydzielana jest pamiec dla obiektu, jego VMT i czego tam
      jeszcze trzeba, a POTEM wywolywany jest kod konstruktora obiektu
      (w ktorym moze ale de facto nie musi byc wywolanie inherited -
      to malo eleganckie pisac obiekty ktore nie wywoluja inherited
      w konstrukt/destrukt, ale jesli wiesz ze kod w inherited konstrukt/destrukt
      nie jest ci potrzebny to nie musisz wywolywac inherited)
    analogicznie dla destruktora
}

type
  TObj=class
    a:integer;
    constructor Create;
    destructor Destroy; override;
  end;

constructor TObj.Create;
begin
 a:=42;
 inherited;
end;

destructor TObj.Destroy;
var s:string;
begin
 inherited;

 {do some memory allocs/frees}
 s:='blablabla';
 if s<>'' then s:='popoty ' + s ;

 {check value of a}
 Assert(a=42);
end;

procedure TTestOldFPCBugs.TestInherited;
var obj:TObj;
begin
 obj:=TObj.Create;
 FreeAndNil(obj);
end;

{ TestAbsProc ---------------------------------------------------------------- }

{ fails in 1.0.6 (corrected in 1.0.7/10) }

{ TestAbsProc needs not to be called, it will fail at compilation. }
procedure TestAbsProc(mm:TProcedure);
var m2:array[0..1]of Pointer absolute mm;
begin
 { do something on "m2" variable }
 if m2[0]=nil then Exit;
end;

{ MethodPass ----------------------------------------------------------------- }

{ fails in 1.0.10; reported to fpc-devel lists }

type
  TProcOfObj=procedure of object;
  PMethod = ^TMethod;

{ we could write the procedure below as
    procedure Proc(mm:TProcOfObj);
    var m2:TMethod absolute mm;
    begin
     Assert(m2.Code <> nil);
    end;
  but it would require TEST_ABSOLUTE_PROCEDURE to pass (and we want to
  test these two things _separately_.)
}
procedure Proc(mm:TProcOfObj);
begin
 Assert(PMethod(@mm)^.Code <> nil);
end;

type
  TObjMM=class
    procedure MyMethod;
    procedure CallProcWithMyMethod;
  end;

procedure TObjMM.MyMethod; begin end;
procedure TObjMM.CallProcWithMyMethod; begin Proc(@MyMethod) end;

procedure TTestOldFPCBugs.TestMethodPass;
var o:TObjMM;
begin
 o:=TObjMM.Create;
 try
  o.CallProcWithMyMethod;
 finally o.Free end;
end;

{ TestCallFuncOfObject ------------------------------------------------------- }

{ fails in 1.1 (snapshot at 23.07.2003); submitted to bug form }

{$warnings off}
procedure TestCallFuncOfObject;
{ this is a compile-time bug; do not call this procedure }
type
  TFuncByObject = function(i:Integer):boolean of object;
var F:TFuncByObject;
begin
 F(1);
end;
{$warnings on}

{ TestCompareMemBug ---------------------------------------------------------- }

procedure TTestOldFPCBugs.TestCompareMemBug;
var b1,b2:array[0..1000]of byte;
begin
 { if CompareMem(p1, p2, 0) would work good then values for p1 and p2
   should be ignored. But, since there is a bug, they will not be ignored
   so we have to provide valid pointers for p1 and p2 or we will get
   AccessViolation. }
 Assert(CompareMem(@b1, @b2, 0));
end;

procedure TTestOldFPCBugs.TestFormatIncompatibility;
begin
 Assert(Format('%d %d %0:d %d', [0, 1, 2, 3]) = '0 1 0 1');
end;

{ TestSizeOfObject ----------------------------------------------------------- }

{ fails in some 1.0.7 versions and in 1.0.10
  Reported to fpc-devel lists. }

const D = SizeOf(TObject);
procedure TTestOldFPCBugs.TestSizeOfObject;
begin
  Assert(D = SizeOf(Pointer));
end;

{ TestOthers ----------------------------------------------------------------- }

{ przeciazanie procedur gdy jedna wersja nie bierze zadnych arg.
  To dziala tylko pod 1.1, 1.0.x musza byc odpowiednio zmodyfikowane
  aby to dzialalo. (wiele mojego kodu wymaga zeby to dzialalo,
  juz CastleUtils.) }
function TestProc(arg:integer):boolean; overload; begin result:=true  end;
function TestProc             :boolean; overload; begin result:=false end;

procedure TTestOldFPCBugs.TestOthers;
var b1,b2:array[0..1000]of byte;
begin
 Assert(not TestProc);
 Assert(TestProc(2));

 Assert(SizeOf(AnsiString) = SizeOf(Pointer));
 Assert(SizeOf(String) = SizeOf(Pointer));

 { some set operations }
 Assert([0,1] = [0,1]);
 Assert([0] <= [0]);
 Assert([0] <= [0,1,2,3,4]);
 Assert(not ([0] <= []));
 Assert([0] >= []);

 { test is CompareMem(..., ..., 0) bug fixed }
 Assert(CompareMem(@b1, @b2, 0));
 { test is "Format incompatible with Delphi" bug fixed }
 Assert(Format('%d %d %0:d %d', [0, 1, 2, 3]) = '0 1 0 1');
end;

procedure TTestOldFPCBugs.TestSwapEndian;
const
  A1: QWord = $0123456789ABCDEF;
var
  A2: QWord;
begin
  A2 := QWord($EFCDAB8967452301);
  Assert(SwapEndian(A1) = A2);
  Assert(SwapEndian(A2) = A1);
end;

initialization
 RegisterTest(TTestOldFPCBugs);
end.