git-svn-id: trunk@9 -

.gitattributes

@@ -6128,6 +6128,7 @@ tests/webtbs/tw3893.pp -text
 tests/webtbs/tw3898.pp -text
 tests/webtbs/tw3899.pp -text
 tests/webtbs/tw3900.pp -text
+tests/webtbs/tw3973.pp -text
 tests/webtbs/ub1873.pp -text
 tests/webtbs/ub1883.pp -text
 tests/webtbs/uw0555.pp -text

tests/webtbs/tw3973.pp

@@ -0,0 +1,143 @@
+{ 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);
+      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(Quad, 16));
+    {$ENDIF}
+  end;
+
+begin
+  TestOpenArray();
+  TestVarType();
+  TestFormat();
+  WriteLn;
+  if FailureCount = 0 then
+    WriteLn('All passed')
+  else WriteLn(FailureCount, 'Failures');
+  ReadLn;
+end.