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
|
{ Source provided for Free Pascal Bug Report 3973 }
{ Submitted by "alphax" on 2005-05-16 }
{ e-mail: graphcoloring@yahoo.com.cn }
program fpc_test_3;
{$APPTYPE CONSOLE}
{$IFDEF FPC}
{$MODE objfpc}
{$ENDIF}
uses
SysUtils, Variants;
var
FailureCount: Integer;
procedure TestOpenArray;
procedure p(const a: array of const);
procedure Check(
const TypeName: string;
const aVarRec: TVarRec;
const aExpectedVType: Byte
);
begin
Write('VType of ', TypeName, ' element is: ', aVarRec.VType, '--------');
if aVarRec.VType = aExpectedVType then
WriteLn('Ok')
else
begin
Inc(FailureCount);
WriteLn('Failure');
end;
end;
begin
Check('Currency', a[0], vtCurrency);
Check('Interface(nil)', a[1], vtInterface);
Check('Interface', a[2], vtInterface);
{ TObject is a class as well! }
Check('Class Object(nil)', a[3], vtObject);
Check('Class', a[4], vtClass);
{$IFDEF FPC}
Check('QWord', a[5], vtQWord);
{$ENDIF}
{ I WISH FPC Introduce a vtDateTime for the TDatetime parameter }
end;
var
C: Currency;
DT: TDateTime;
IntfNil, Intf: IInterface;
Obj: TObject;
{$IFDEF FPC}
Quad: QWord;
{$ENDIF}
begin
C := 0;
IntfNil := nil;
Intf := TInterfacedObject.Create();
Obj := nil;
{$IFDEF FPC}
Quad := 0;
p([C, IntfNil, Intf, Obj, TObject, Quad]);
{$ELSE}
p([C, IntfNil, Intf, Obj, TObject]);
{$ENDIF}
end;
procedure TestVarType;
procedure Check(
const aTypeName: string;
const V: Variant;
const aExpectedVarType: TVarType);
var
VT: TVarType;
begin
VT := VarType(V);
Write('VarType of ', aTypeName, ' variant is: ', VT, '--------');
if VT = aExpectedVarType then
Writeln('Ok')
else
begin
WriteLn('Failure');
Inc(FailureCount);
end;
end;
var
C: Currency;
DT: TDateTime;
Intf: IInterface;
{$IFDEF FPC}
Quad: QWord;
{$ENDIF}
begin
C := 0;
DT := 0;
Intf := TInterfacedObject.Create();
{$IFDEF FPC}
Quad := 0;
{$ENDIF}
Check('Currency', C, varCurrency);
Check('Datetime', DT, varDate);
Check('Interface', Intf, varUnknown);
{$IFDEF FPC}
Check('QWord', Quad, varQWord);
{$ENDIF}
end;
procedure TestFormat;
var
uLong: Longword;
Longlong: Int64;
{$IFDEF FPC}
Quad: QWord;
{$ENDIF}
begin
uLong := High(uLong);
Writeln(Format('high of longword is: %u', [uLong]), ' ', IntToHex(ulong, 8));
Longlong := High(Longlong);
Writeln(Format('high of int64 is: %d', [Longlong]), ' ', IntToHex(Longlong, 16));
{$IFDEF FPC}
Quad := High(Quad);
Writeln(Format('high of quadword is: %u', [Quad]), ' ', IntToHex(int64(Quad), 16));
{$ENDIF}
end;
begin
TestOpenArray();
TestVarType();
TestFormat();
WriteLn;
if FailureCount = 0 then
WriteLn('All passed')
else
begin
WriteLn(FailureCount, 'Failures');
halt(1);
end;
end.
|
