* test programs previously having extension .pas renamed to .pp so that they are found during testsuite runs

git-svn-id: trunk@30024 -

.gitattributes

@@ -10254,6 +10254,7 @@ tests/tbs/tb0466.pp svneol=native#text/plain
 tests/tbs/tb0467.pp svneol=native#text/plain
 tests/tbs/tb0468.pp svneol=native#text/plain
 tests/tbs/tb0468a.pas svneol=native#text/plain
+tests/tbs/tb0468a.pp svneol=native#text/plain
 tests/tbs/tb0469.pp svneol=native#text/plain
 tests/tbs/tb0470.pp svneol=native#text/plain
 tests/tbs/tb0471.pp svneol=native#text/plain
@@ -10361,6 +10362,7 @@ tests/tbs/tb0568.pp svneol=native#text/plain
 tests/tbs/tb0569.pp svneol=native#text/pascal
 tests/tbs/tb0570.pp svneol=native#text/plain
 tests/tbs/tb0571.pas svneol=native#text/plain
+tests/tbs/tb0571.pp svneol=native#text/plain
 tests/tbs/tb0572.pp svneol=native#text/plain
 tests/tbs/tb0573.pp svneol=native#text/plain
 tests/tbs/tb0574.pp svneol=native#text/pascal
@@ -12140,6 +12142,7 @@ tests/test/tover1.pp svneol=native#text/plain
 tests/test/tover2.pp svneol=native#text/plain
 tests/test/tover3.pp svneol=native#text/plain
 tests/test/tover4.pas svneol=native#text/plain
+tests/test/tover4.pp svneol=native#text/plain
 tests/test/tpackrec.pp svneol=native#text/plain
 tests/test/tparray1.pp svneol=native#text/plain
 tests/test/tparray10.pp svneol=native#text/plain
@@ -12653,6 +12656,7 @@ tests/test/units/system/tslice2.pp svneol=native#text/plain
 tests/test/units/system/tstr1.pp svneol=native#text/pascal
 tests/test/units/system/tstring.pp svneol=native#text/plain
 tests/test/units/system/ttrig.pas svneol=native#text/plain
+tests/test/units/system/ttrig.pp svneol=native#text/plain
 tests/test/units/system/ttrunc.pp svneol=native#text/plain
 tests/test/units/system/tval.inc svneol=native#text/plain
 tests/test/units/system/tval.pp svneol=native#text/plain
@@ -12936,6 +12940,7 @@ tests/webtbf/tw2128.pp svneol=native#text/plain
 tests/webtbf/tw2129.pp svneol=native#text/plain
 tests/webtbf/tw21363.pp svneol=native#text/pascal
 tests/webtbf/tw21466.pas svneol=native#text/pascal
+tests/webtbf/tw21466.pp svneol=native#text/pascal
 tests/webtbf/tw2154.pp svneol=native#text/plain
 tests/webtbf/tw21566.pp svneol=native#text/pascal
 tests/webtbf/tw2174.pp svneol=native#text/plain
@@ -13140,6 +13145,7 @@ tests/webtbf/tw8588.pp svneol=native#text/plain
 tests/webtbf/tw8591.pp svneol=native#text/plain
 tests/webtbf/tw8717.pp svneol=native#text/plain
 tests/webtbf/tw8738.pas svneol=native#text/plain
+tests/webtbf/tw8738.pp svneol=native#text/plain
 tests/webtbf/tw8777a.pp svneol=native#text/plain
 tests/webtbf/tw8777b.pp svneol=native#text/plain
 tests/webtbf/tw8777c.pp svneol=native#text/plain
@@ -13761,6 +13767,7 @@ tests/webtbs/tw17838.pp svneol=native#text/pascal
 tests/webtbs/tw17846.pp svneol=native#text/plain
 tests/webtbs/tw17862.pp svneol=native#text/plain
 tests/webtbs/tw17904.pas svneol=native#text/plain
+tests/webtbs/tw17904.pp svneol=native#text/plain
 tests/webtbs/tw17907/main/main.pas svneol=native#text/plain
 tests/webtbs/tw17907/test.bat svneol=native#text/plain
 tests/webtbs/tw17907/unit1/unit0001.pas svneol=native#text/plain
@@ -13866,6 +13873,7 @@ tests/webtbs/tw19651.pp svneol=native#text/plain
 tests/webtbs/tw19697.pp svneol=native#text/pascal
 tests/webtbs/tw19700.pp svneol=native#text/plain
 tests/webtbs/tw19701.pas svneol=native#text/plain
+tests/webtbs/tw19701.pp svneol=native#text/plain
 tests/webtbs/tw19851a.pp svneol=native#text/pascal
 tests/webtbs/tw19851b.pp svneol=native#text/pascal
 tests/webtbs/tw19864.pp svneol=native#text/pascal

tests/tbs/tb0468a.pp

@@ -0,0 +1,27 @@
+{ %OPT=-Sg }
+
+procedure foo;
+begin
+end;
+
+procedure test;
+label
+  a,b,c,d;
+const
+  x: array[0..3] of pointer=(@a,@b,@c,@d);
+begin
+  foo;
+a:
+  foo;
+b:
+  foo;
+c:
+  foo;
+d:
+  foo;
+end;
+
+
+begin
+end.
+

tests/tbs/tb0571.pp

@@ -0,0 +1,73 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif fpc}
+
+{ Some (delphi) applications expect that the QueryInterface method is invoked as first
+  priority to query for an interface and GetInterface as 2nd priority }
+
+uses
+  sysutils;
+
+type
+  ITest = interface
+     ['{E80B0A2E-96ED-4F38-A6AC-E4E0B59F27F3}']
+  end;
+
+  TTest = class(TObject, IUnknown, ITest)
+  private
+    refcount: integer;
+  public
+    function QueryInterface(const iid : tguid;out obj) : Hresult;stdcall;
+    function _AddRef : longint;stdcall;
+    function _Release : longint;stdcall;
+  end;
+
+var
+  called: Boolean = False;
+
+function TTest.QueryInterface(const IID: TGUID; out Obj): Hresult; stdcall;
+begin
+  called := true;
+  if getinterface(iid,obj) then
+   result:=S_OK
+  else
+   result:=longint(E_NOINTERFACE);
+end;
+
+function TTest._AddRef : longint;stdcall;
+begin
+  Inc(refcount);
+  result := refcount;
+end;
+
+function TTest._Release : longint;stdcall;
+begin
+  Dec(refcount);
+  result := refcount;
+end;
+
+var
+  r: TTest;
+  i: ITest;
+
+procedure get(out obj: ITest);
+begin
+  obj := r as ITest;
+end;
+
+begin
+  r := TTest.Create;
+  r._AddRef;
+
+  if not supports(r, ITest, i) or not called or (r.refcount<>2) then
+    Halt(1);
+  called := false;
+  i := nil;
+
+  get(i);
+  if (i=nil) or not called or (r.refcount<>2) then
+    Halt(1);
+  i := nil;
+
+  r._Release;
+end.

tests/test/tover4.pp

@@ -0,0 +1,65 @@
+{ %cpu=i386,x86_64 }
+{ %skiptarget=win64 }
+{ Target must actually support Extended type }
+
+function test1(x: single): integer;
+begin
+  test1:=1;
+end;
+
+function test1(x: double): integer;
+begin
+  test1:=2;
+end;
+
+function test1(x: extended): integer;
+begin
+  test1:=3;
+end;
+
+
+function test2(x: single): integer;
+begin
+  test2:=1;
+end;
+
+function test2(x: double): integer;
+begin
+  test2:=2;
+end;
+
+
+function test3(x: single): integer;
+begin
+  test3:=1;
+end;
+
+function test3(x: double): integer;
+begin
+  test3:=2;
+end;
+
+function test3(x: cextended): integer;
+begin
+  test3:=3;
+end;
+
+
+var
+  a: cextended;
+  b: extended;
+begin
+  a:= 123.456;
+  b:= 123.456;
+  { test #1: single/double/extended available, passing cextended must select extended }
+  if test1(a)<>3 then
+    halt(1);
+
+  { test #2: single and double avaiable, passing cextended must select double }
+  if test2(a)<>2 then
+    halt(2);
+
+  { test #3: single/double/cextended available, passing extended must select cextended }
+  if test3(a)<>3 then
+    halt(3);
+end.

tests/test/units/system/ttrig.pp

@@ -0,0 +1,40 @@
+procedure do_error(i : longint);
+  begin
+    writeln('Error near ',i);
+    halt(1);
+  end;
+
+var
+  s0,s1,s2 : single;
+
+
+begin
+  writeln('--- Testing single functions ---');
+
+  // 0.0
+  s0:=0.0;
+
+  s1:=sin(s0);
+  if s1<>0.0 then
+    do_error(1);
+
+  s1:=cos(s0);
+  if s1<>1.0 then
+    do_error(2);
+
+  s1:=arctan(s0);
+  if s1<>0.0 then
+    do_error(3);
+
+  // pi/2
+  s2:=pi/2;
+
+  s1:=sin(s2);
+  if s1<>1.0 then
+    do_error(100);
+
+  s1:=cos(s2);
+  { with single precision, the result is -4.371138829E-08 }
+  if abs(s1-0.0)>4.371138829E-08 then
+    do_error(101);
+end.

tests/webtbf/tw21466.pp

@@ -0,0 +1,9 @@
+{ %fail }
+unit tw21466 deprecated 'blah blah' deprecated 'koko';
+
+interface
+
+implementation
+
+finalization
+end.

tests/webtbf/tw8738.pp

@@ -0,0 +1,8 @@
+{ %fail }
+
+program test;
+
+uses uw8738b;
+
+begin
+end.

tests/webtbs/tw17904.pp

@@ -0,0 +1,198 @@
+
+{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
+{$apptype console}
+
+uses Variants, SysUtils;
+
+type
+  TTest = class(TCustomVariantType)
+    procedure Clear(var V: TVarData); override;
+    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
+    procedure DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override;
+  end;
+
+procedure TTest.Clear(var V: TVarData);
+begin
+end;
+
+procedure TTest.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
+begin
+end;
+
+procedure TTest.DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
+var
+  tmp: Word;
+begin
+  if (CallDesc^.ArgCount =2) and Assigned(Dest) then
+  begin
+    //writeln(HexStr(PPointer(Params)^), ' ', HexStr(PPointer(Params)[1]));
+    WordRec(tmp).Lo := CallDesc^.ArgTypes[0];
+    WordRec(tmp).Hi := CallDesc^.ArgTypes[1];
+    // !! FPC passes args right-to-left, Delphi does same left-to-right
+    // Moreover, IDispatch needs args right-to-left, and Variant Dispatch needs left-to-right. Nice, huh?
+    {$ifdef fpc}
+    tmp := Swap(tmp);
+    {$endif}
+    Variant(Dest^) := tmp;
+  end;  
+end;
+
+type
+  TTestClass=class
+    u8: byte;
+    u16: word;
+    u32: longword;
+{$ifdef fpc}
+    u64: qword;
+{$endif}
+    s8: shortint;
+    s16: smallint;
+    s32: longint;
+    s64: int64;
+
+    cy: currency;
+
+    b: boolean;
+    bb: bytebool;
+    wb: wordbool;
+    lb: longbool;
+
+    sgl: single;
+    dbl: double;
+    ext: extended;
+    dt: TDateTime;
+
+    fsstr: shortstring;
+    fastr: ansistring;
+    fwstr: widestring;
+{$ifdef fpc}
+    fustr: unicodestring;
+{$endif}
+
+    fvar: Variant;
+    fintf: IInterface;
+    fdisp: IDispatch;
+
+    property u8prop: Byte read u8;
+    property u16prop: Word read u16;
+    property u32prop: LongWord read u32;
+{$ifdef fpc}
+    property u64prop: QWord read u64;
+{$endif}
+    property s8prop: ShortInt read s8;
+    property s16prop: SmallInt read s16;
+    property s32prop: LongInt read s32;
+    property s64prop: Int64 read s64;
+
+    property cyprop: currency read cy;
+    property bprop: boolean read b;
+    property bbprop: bytebool read bb;
+    property wbprop: wordbool read wb;
+    property lbprop: longbool read lb;
+
+    property sglprop: single read sgl;
+    property dblprop: double read dbl;
+    property extprop: extended read ext;
+    property dtprop: TDateTime read dt;
+
+    property varprop: Variant read fvar;
+    property intfprop: IInterface read fintf;
+    property dispprop: IDispatch read fdisp;
+
+    property sstr: shortstring read fsstr;
+    property astr: ansistring read fastr;
+    property wstr: widestring read fwstr;
+{$ifdef fpc}
+    property ustr: unicodestring read fustr;
+{$endif}
+  end;
+
+var
+  cv: TCustomVariantType;
+  code: Integer;
+  cl: TTestClass;
+  v: Variant;
+
+// using negative values of Expected to check that arg is passed by-value only
+procedure test(const id: string; const act: Variant; expected: Integer);
+var
+  tmp: word;
+  absexp: Integer;
+begin
+  tmp := act;
+  absexp := abs(expected);
+  write(id, WordRec(tmp).Lo,', ', WordRec(tmp).Hi);
+  if (expected >= 0) and (WordRec(tmp).Lo <> (expected or $80)) then
+  begin
+    write(' BYREF failed');
+    Code := Code or 1;
+  end;  
+  if WordRec(tmp).Hi <> absexp then
+  begin
+    write(' BYVAL failed');
+    Code := Code or 2;
+  end;
+  writeln;
+end;
+
+begin
+  Code := 0;
+  cv := TTest.Create;
+  cl := TTestClass.Create;
+  TVarData(v).vType := cv.VarType;
+
+  test('u8:    ', v.foo(cl.u8, cl.u8prop), varbyte);
+  
+  test('u16:    ', v.foo(cl.u16, cl.u16prop), varword);       // (Uncertain) D7: treated as Integer
+  test('u32:    ', v.foo(cl.u32, cl.u32prop), varlongword);   // (Uncertain) D7: treated as Integer ByRef
+  test('s8:     ', v.foo(cl.s8, cl.s8prop), varshortint);     // (Uncertain) D7: treated as Integer
+
+  test('s16:    ', v.foo(cl.s16, cl.s16prop), varsmallint);
+  test('s32:    ', v.foo(cl.s32, cl.s32prop), varinteger);
+  test('s64:    ', v.foo(cl.s64, cl.s64prop), varint64);
+{$ifdef fpc}
+  test('u64:    ', v.foo(cl.u64, cl.u64prop), varword64);
+{$endif}
+  
+  test('wordbool:', v.foo(cl.wb, cl.wbprop), varBoolean);
+  test('curncy:  ', v.foo(cl.cy, cl.cyprop), varCurrency);
+  
+  test('single:  ', v.foo(cl.sgl, cl.sglprop), varSingle);
+  test('double:  ', v.foo(cl.dbl, cl.dblprop), varDouble);
+  test('extended:', v.foo(cl.ext, cl.extprop), -varDouble);  // not a COM type, passed by value
+  
+  test('date:    ', v.foo(cl.dt, cl.dtprop), varDate);
+
+  test('ansistr: ', v.foo(cl.fastr, cl.astr), varStrArg);
+  test('widestr: ', v.foo(cl.fwstr, cl.wstr), varOleStr);
+{$ifdef fpc}
+  test('unistr:  ', v.foo(cl.fustr, cl.ustr), varUStrArg);
+{$endif}
+  test('variant: ', v.foo(cl.fvar, cl.varprop), varVariant);
+  
+  test('IUnknown:', v.foo(cl.fintf, cl.intfprop), varUnknown);
+  test('IDispatch:', v.foo(cl.fdisp, cl.dispprop), varDispatch);
+  
+  // not an COM type, passed by value; Delphi uses varStrArg
+  test('shortstr:', v.foo(cl.fsstr, cl.sstr), -varOleStr);
+  // not an COM type, passed by value
+  test('longbool:', v.foo(cl.lb, cl.lbprop), -varBoolean);
+
+  // typecasted ordinals (only one arg is actually used)
+  test('u8+cast: ', v.foo(byte(55), byte(55)), -varByte);
+  test('u16+cast:', v.foo(word(55), word(55)), -varWord);
+  test('u32+cast:', v.foo(longword(55), longword(55)), -varLongWord);
+{$ifdef fpc}
+  test('u64+cast:', v.foo(qword(55), qword(55)), -varQWord);
+{$endif}
+  test('s8+cast:', v.foo(shortint(55), shortint(55)), -varShortInt);
+  test('s16+cast:', v.foo(smallint(55), smallint(55)), -varSmallInt);
+  test('s32+cast:', v.foo(longint(55), longint(55)), -varInteger);
+  test('s64+cast:', v.foo(int64(55), int64(55)), -varInt64);
+
+  cl.Free;
+  if Code <> 0 then
+    writeln('Errors: ', Code);
+  Halt(Code);
+
+end.

tests/webtbs/tw19701.pp

@@ -0,0 +1,11 @@
+{ %opt=-gh }
+
+program tw19701;
+{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
+{$ifdef mswindows}{$apptype console}{$endif}
+uses
+ {$ifdef FPC}{$ifdef linux}cthreads,cwstring,{$endif}{$endif}
+ sysutils,uw19701;
+begin
+  HaltOnNotReleased:=True;
+end.