diff options
| author | fpc <fpc@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2005-05-16 18:37:41 +0000 |
|---|---|---|
| committer | fpc <fpc@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2005-05-16 18:37:41 +0000 |
| commit | f206a9c2b1ae1d8727ca27a96d448b61fdb4c766 (patch) | |
| tree | f28256ff9964c1fc7c0f7fb00891268a117b745d /tests/tbs | |
| download | fpc-f206a9c2b1ae1d8727ca27a96d448b61fdb4c766.tar.gz | |
initial import
git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@1 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat (limited to 'tests/tbs')
513 files changed, 13619 insertions, 0 deletions
diff --git a/tests/tbs/tb0001.pp b/tests/tbs/tb0001.pp new file mode 100644 index 0000000000..b1d6be095a --- /dev/null +++ b/tests/tbs/tb0001.pp @@ -0,0 +1,88 @@ +{ %CPU=i386 } +{ %OPT=-O2 } +{ Old file: tbs0002.pp } +{ tests for the endless bugs in the optimizer OK 0.9.2 } + +unit tb0001; + + interface + + implementation + +{$message starting hexstr} + function hexstr(val : longint;cnt : byte) : string; + + const + hexval : string[16]=('0123456789ABCDEF'); + + var + s : string; + l2,i : integer; + l1 : longInt; + + begin + s[0]:=char(cnt); + l1:=longint($f) shl (4*(cnt-1)); + for i:=1 to cnt do + begin + l2:=(val and l1) shr (4*(cnt-i)); + l1:=l1 shr 4; + s[i]:=hexval[l2+1]; + end; + hexstr:=s; + end; + +{$message starting dump_stack} + + procedure dump_stack(bp : longint); + +{$message starting get_next_frame} + + function get_next_frame(bp : longint) : longint; + + begin + asm + movl bp,%eax + movl (%eax),%eax + movl %eax,__RESULT + end ['EAX']; + end; + + procedure dump_frame(addr : longint); + + begin + { to be used by symify } + writeln(' 0x',HexStr(addr,8)); + end; + +{$message starting get_addr} + + function get_addr(BP : longint) : longint; + + begin + asm + movl BP,%eax + movl 4(%eax),%eax + movl %eax,__RESULT + end ['EAX']; + end; + +{$message starting main} + + var + i,prevbp : longint; + + begin + prevbp:=bp-1; + i:=0; + while bp > prevbp do + begin + dump_frame(get_addr(bp)); + i:=i+1; + if i>max_frame_dump then exit; + prevbp:=bp; + bp:=get_next_frame(bp); + end; + end; + +end. diff --git a/tests/tbs/tb0002.pp b/tests/tbs/tb0002.pp new file mode 100644 index 0000000000..1f225bffd5 --- /dev/null +++ b/tests/tbs/tb0002.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0003.pp } +{ dito OK 0.9.2 } + +unit tb0002; + + interface + + implementation + + + procedure dump_stack(bp : longint); + + function get_next_frame(bp : longint) : longint; + + begin + end; + + begin + end; + +end. diff --git a/tests/tbs/tb0003.pp b/tests/tbs/tb0003.pp new file mode 100644 index 0000000000..367c87d090 --- /dev/null +++ b/tests/tbs/tb0003.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0004.pp } +{ tests the continue instruction in the for loop OK 0.9.2 } + +var + i : longint; + +begin + for i:=1 to 100 do + begin + writeln('Hello'); + continue; + writeln('ohh'); + Halt(1); + end; +end. + diff --git a/tests/tbs/tb0004.pp b/tests/tbs/tb0004.pp new file mode 100644 index 0000000000..a32e5705d9 --- /dev/null +++ b/tests/tbs/tb0004.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0005.pp } +{ tests the if 1=1 then ... bugs OK 0.9.2 } + +uses + erroru; + +begin + if 1=1 then + begin + Writeln('OK'); + end; + if 1<>1 then + begin + Error; + end; +end. diff --git a/tests/tbs/tb0005.pp b/tests/tbs/tb0005.pp new file mode 100644 index 0000000000..35c1476ab6 --- /dev/null +++ b/tests/tbs/tb0005.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0006.pp } +{ tests the wrong floating point code generation OK 0.9.2 } + +uses + erroru; +var + a,b,c,d,e,f,g,r : double; + +begin + a:=10.0; + b:=11.0; + c:=13.0; + d:=17.0; + e:=19.0; + f:=23.0; + r:=2.0; + a:= a - 2*b*e - 2*c*f - 2*d*g - Sqr(r); + writeln(a,' (must be -1010)'); + if a<>-1010.0 then + Error; +end. diff --git a/tests/tbs/tb0006.pp b/tests/tbs/tb0006.pp new file mode 100644 index 0000000000..fd49e44635 --- /dev/null +++ b/tests/tbs/tb0006.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0007.pp } +{ tests the infinity loop when using byte counter OK 0.9.2 } + +uses + erroru; + +var + count : byte; + test : longint; +begin + test:=0; + for count:=1 to 127 do + begin + inc(test); + writeln(count,'. loop'); + if test>127 then + Error; + end; +end. + diff --git a/tests/tbs/tb0007.pp b/tests/tbs/tb0007.pp new file mode 100644 index 0000000000..9c6df331eb --- /dev/null +++ b/tests/tbs/tb0007.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0009.pp } +{ tests comperations in function calls a(c<0); OK 0.9.2 } + +var c:byte; + + Procedure a(b:boolean); + + begin + if b then writeln('TRUE') else writeln('FALSE'); + end; + + function Test_a(b:boolean) : string; + + begin + if b then Test_a:='TRUE' else Test_a:='FALSE'; + end; + + begin {main program} + a(true); {works} + if Test_a(true)<>'TRUE' then halt(1); + a(false); {works} + if Test_a(false)<>'FALSE' then halt(1); + c:=0; + a(c>0); {doesn't work} + if Test_a(c>0)<>'FALSE' then halt(1); + a(c<0); {doesn't work} + if Test_a(c<0)<>'FALSE' then halt(1); + a(c=0); + if Test_a(c=0)<>'TRUE' then halt(1); + end. diff --git a/tests/tbs/tb0008.pp b/tests/tbs/tb0008.pp new file mode 100644 index 0000000000..2f1d121e67 --- /dev/null +++ b/tests/tbs/tb0008.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0011.pp } +{ tests div/mod bugs, where edx is scrambled, if a called procedure does a div/mod OK 0.9.2 } + +{$message don't know how to make a test from bug0011 (PM)} +var + vga : array[0..320*200-1] of byte; + +procedure test(x,y : longint); + + begin + vga[x+y mod 320]:=random(256); + vga[x+y mod 320]:=random(256); + end; + +begin +end. + diff --git a/tests/tbs/tb0009.pp b/tests/tbs/tb0009.pp new file mode 100644 index 0000000000..fb510e52af --- /dev/null +++ b/tests/tbs/tb0009.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0012.pp } +{ tests type conversation byte(a>b) OK 0.9.9 (FK) } + +var + a,b : longint; + +begin + a:=1; + b:=2; + if byte(a>b)=byte(a<b) then + begin + writeln('Ohhhh'); + Halt(1); + end; +end. + diff --git a/tests/tbs/tb0010.pp b/tests/tbs/tb0010.pp new file mode 100644 index 0000000000..6f2bb8cd5d --- /dev/null +++ b/tests/tbs/tb0010.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0013.pp } +{ } + +procedure test(w : word); + + begin + end; + +begin + test(1234); +end. + diff --git a/tests/tbs/tb0011.pp b/tests/tbs/tb0011.pp new file mode 100644 index 0000000000..97c602499e --- /dev/null +++ b/tests/tbs/tb0011.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0014.pp } +{ } + +type + prec = ^trec; + + trec = record + p : prec; + l : longint; + end; + +function test(p1,p2 : prec) : boolean; + + begin + if p1^.l=12 then + case p1^.l of + 123 : test:=(test(p1^.p,p2^.p) and test(p1^.p,p2^.p)) or + (test(p1^.p,p2^.p) and test(p1^.p,p2^.p)); + 1234 : test:=(test(p1^.p,p2^.p) and test(p1^.p,p2^.p)) or + (test(p1^.p,p2^.p) and test(p1^.p,p2^.p)); + end; + end; + +begin +end. diff --git a/tests/tbs/tb0012.pp b/tests/tbs/tb0012.pp new file mode 100644 index 0000000000..4aa1086cd4 --- /dev/null +++ b/tests/tbs/tb0012.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0015.pp } +{ tests for wrong allocated register for return result of floating function (allocates int register) OK 0.9.2 } + +program test; +type + realgr= array [1..1000] of double; +var + sx :realgr; + i :integer; + stemp :double; +begin + sx[1]:=10; + sx[2]:=-20; + sx[3]:=30; + sx[4]:=-40; + sx[5]:=50; + sx[6]:=-60; + i:=1; + stemp:=1000; + stemp := stemp+abs(sx[i])+abs(sx[i+1])+abs(sx[i+2])+abs(sx[i+3])+ + abs(sx[i+4])+abs(sx[i+5]); + writeln(stemp); + if stemp<>1210.0 then halt(1); +end. diff --git a/tests/tbs/tb0013.pp b/tests/tbs/tb0013.pp new file mode 100644 index 0000000000..0bd3e8d3a0 --- /dev/null +++ b/tests/tbs/tb0013.pp @@ -0,0 +1,196 @@ +{ Old file: tbs0016.pp } +{ } + + uses + crt; + + const + { ... parameters } + w = 10; { max. 10 } + h = 10; { max. 10 } + + type + tp = array[0..w,0..h] of double; + + var + temp : tp; + phi : tp; + Bi : tp; + + boundary : array[0..w,0..h] of double; + + function start_temp(i,j : longint) : double; + + begin + start_temp:=(boundary[i,0]*(h-j)+boundary[i,h]*j+boundary[0,j]*(w-i)+boundary[w,j]*i)/(w+h); + end; + + procedure init; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + temp[i,j]:=start_temp(i,j); + end; + + procedure draw; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + begin + textcolor(white); + gotoxy(i*7+1,j*2+1); + writeln(temp[i,j]:6:0); + textcolor(darkgray); + gotoxy(i*7+1,j*2+2); + writeln(phi[i,j]:6:3); + end; + end; + + procedure calc_phi; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + begin + if (i=0) and (j=0) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=0) and (j=h) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=w) and (j=0) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=w) and (j=h) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if i=0 then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; + end + else if i=w then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; + end + else if j=0 then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; + end + else if j=h then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; + end + else + phi[i,j]:=temp[i,j-1]+temp[i-1,j]-4*temp[i,j]+temp[i+1,j]+temp[i,j+1]; + end; + end; + + procedure adapt(i,j : longint); + + begin + if (i=0) and (j=0) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j])/(1+Bi[i,j]); + end + else if (i=0) and (j=h) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j])/(1+Bi[i,j]); + end + else if (i=w) and (j=0) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j])/(1+Bi[i,j]); + end + else if (i=w) and (j=h) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j])/(1+Bi[i,j]); + end + else if i=0 then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); + end + else if i=w then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); + end + else if j=0 then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); + end + else if j=h then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); + end + else + temp[i,j]:=(temp[i,j-1]+temp[i-1,j]+temp[i+1,j]+temp[i,j+1])/4; + end; + + var + iter,i,j,mi,mj : longint; + habs,sigma_phi : double; + + begin + clrscr; + iter:=0; + { setup boundary conditions } + for i:=0 to w do + for j:=0 to h do + begin + if (i=0) or (i=w) then + bi[i,j]:=100 + else + bi[i,j]:=100; + + if (j=0) then + boundary[i,j]:=1000 + else + boundary[i,j]:=300; + end; + init; + draw; + repeat + calc_phi; + mi:=0; + mj:=0; + sigma_phi:=0; + inc(iter); + habs:=abs(phi[mi,mj]); + for i:=0 to w do + for j:=0 to h do + begin + if abs(phi[i,j])>habs then + begin + mi:=i; + mj:=j; + habs:=abs(phi[mi,mj]); + end; + { calculate error } + sigma_phi:=sigma_phi+abs(phi[i,j]); + end; + adapt(mi,mj); + gotoxy(1,23); + textcolor(white); + writeln(iter,' iterations, sigma_phi=',sigma_phi); + until {keypressed or }(sigma_phi<0.5); + draw; + gotoxy(1,23); + textcolor(white); + writeln(iter,' iterations, sigma_phi=',sigma_phi); + {writeln('press a key'); + if readkey=#0 then + readkey;} + end. diff --git a/tests/tbs/tb0014.pp b/tests/tbs/tb0014.pp new file mode 100644 index 0000000000..9717ddc2e6 --- /dev/null +++ b/tests/tbs/tb0014.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0017.pp } +{ } + +const + nextoptpass : longint = 0; + procedure init; + + const + endofparas : boolean = false; + + procedure getparastring; + + procedure nextopt; + + begin + endofparas:=true; + getparastring; + inc(nextoptpass); + init; + end; + + begin + if not endofparas then + nextopt; + end; + + begin + getparastring; + end; + +begin + init; + if nextoptpass<>1 then Halt(1); +end. + diff --git a/tests/tbs/tb0015.pp b/tests/tbs/tb0015.pp new file mode 100644 index 0000000000..e892e70c1e --- /dev/null +++ b/tests/tbs/tb0015.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0018.pp } +{ tests for the possibility to declare all types using pointers "forward" : type p = ^x; x=byte; OK 0.9.3 } + +type + p = ^x; + x = byte; + +var + b : p; + +begin + new(b); + b^:=12; +end. + diff --git a/tests/tbs/tb0016.pp b/tests/tbs/tb0016.pp new file mode 100644 index 0000000000..10dbbb6731 --- /dev/null +++ b/tests/tbs/tb0016.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0019.pp } +{ } + +type + b = ^x; + + x = byte; + +var + pb : b; + +begin + new(pb); + pb^:=10; +end. + diff --git a/tests/tbs/tb0017.pp b/tests/tbs/tb0017.pp new file mode 100644 index 0000000000..2d193c5914 --- /dev/null +++ b/tests/tbs/tb0017.pp @@ -0,0 +1,42 @@ +{ Old file: tbs0021.pp } +{ tests compatibility of empty sets with other set and the evalution of constant sets OK 0.9.3 } + +{ tests constant set evalution } + +var + a : set of byte; + +const + b : set of byte = [0..255]+[9]; + +type + tcommandset = set of byte; + +const +cmZoom = 10; +cmClose = 5; +cmResize = 8; +cmNext = 12; +cmPrev = 15; + +CONST + CurCommandSet : TCommandSet = ([0..255] - + [cmZoom, cmClose, cmResize, cmNext, cmPrev]); + commands : tcommandset = []; + +var + CommandSetChanged : boolean; + +PROCEDURE DisableCommands (Commands: TCommandSet); + + BEGIN + {$IFNDEF PPC_FPK} { FPK bug } + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> []); { Set changed flag } + {$ENDIF} + CurCommandSet := CurCommandSet - Commands; { Update command set } + END; + +begin + a:=[byte(1)]+[byte(2)]; +end. diff --git a/tests/tbs/tb0018.pp b/tests/tbs/tb0018.pp new file mode 100644 index 0000000000..cdc4737af1 --- /dev/null +++ b/tests/tbs/tb0018.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0022.pp } +{ tests getting the address of a method OK 0.9.3 } + +type + tobject = object + procedure x; + constructor c; + end; + +procedure a; + + begin + end; + +procedure tobject.x; + + begin + end; + +constructor tobject.c; + + begin + end; + +var + p : pointer; + +begin + p:=@a; + p:=@tobject.x; + p:=@tobject.c; +end. diff --git a/tests/tbs/tb0019.pp b/tests/tbs/tb0019.pp new file mode 100644 index 0000000000..3c11d9811d --- /dev/null +++ b/tests/tbs/tb0019.pp @@ -0,0 +1,50 @@ +{ Old file: tbs0023.pp } +{ tests handling of self pointer in nested methods OK 0.9.3 } + +type + tobject = object + a : longint; + procedure t1; + procedure t2;virtual; + constructor init; + end; + +procedure tobject.t1; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + +procedure tobject.t2; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + +constructor tobject.init; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + + +begin +end. diff --git a/tests/tbs/tb0020.pp b/tests/tbs/tb0020.pp new file mode 100644 index 0000000000..b266c03598 --- /dev/null +++ b/tests/tbs/tb0020.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0024.pp } +{ } + + +type + charset=set of char; + + trec=record + junk : array[1..32] of byte; + t : charset; + end; + + var + tr : trec; + tp : ^trec; + + + procedure Crash(const k:charset); + + begin + tp^.t:=[#7..#10]+k; + end; + + begin + tp:=@tr; + Crash([#20..#32]); + end. diff --git a/tests/tbs/tb0021.pp b/tests/tbs/tb0021.pp new file mode 100644 index 0000000000..edb53a5f06 --- /dev/null +++ b/tests/tbs/tb0021.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0025.pp } +{ tests for a wrong uninit. var. warning OK 0.9.3 } + +procedure p1; +type + datetime=record + junk : string; +end; +var + dt : datetime; +begin + fillchar(dt,sizeof(dt),0); +end; + +begin + P1; +end. + diff --git a/tests/tbs/tb0022.pp b/tests/tbs/tb0022.pp new file mode 100644 index 0000000000..3594991f0e --- /dev/null +++ b/tests/tbs/tb0022.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0026.pp } +{ tests for a wrong unused. var. warning OK 0.9.4 } + +const + HexTbl : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); +function HexB(b:byte):string; +begin + HexB[0]:=#2; + HexB[1]:=HexTbl[b shr 4]; + HexB[2]:=HexTbl[b and $f]; +end; + + + +function HexW(w:word):string; +begin + HexW:=HexB(w shr 8)+HexB(w and $ff); +end; + + + +begin + HexW($fff); +end. + diff --git a/tests/tbs/tb0023.pp b/tests/tbs/tb0023.pp new file mode 100644 index 0000000000..e63e82d6ed --- /dev/null +++ b/tests/tbs/tb0023.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0027.pp } +{ tests type enumtype = (One, two, three, forty:=40, fifty); OK 0.9.5 } + +type enumtype = (One, two, three, forty:=40, fifty); + +begin +end. + diff --git a/tests/tbs/tb0024.pp b/tests/tbs/tb0024.pp new file mode 100644 index 0000000000..d99deefff1 --- /dev/null +++ b/tests/tbs/tb0024.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0028.pp } +{ type enumtype = (a); writeln(ord(a)); } + +type + enumtype = (a); + +var + e : enumtype; + +begin + writeln(ord(e)); +end. + diff --git a/tests/tbs/tb0025.pp b/tests/tbs/tb0025.pp new file mode 100644 index 0000000000..56765c3eb1 --- /dev/null +++ b/tests/tbs/tb0025.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0029.pp } +{ tests typeof(object type) OK 0.99.1 (FK) } + +type + TA = object + constructor init; + procedure test;virtual; + end; + + constructor TA.init; + begin + end; + + procedure TA.test; + begin + end; + +var + P: Pointer; + +begin + P := pointer(TypeOf(TA)); +end. diff --git a/tests/tbs/tb0026.pp b/tests/tbs/tb0026.pp new file mode 100644 index 0000000000..389e80e45a --- /dev/null +++ b/tests/tbs/tb0026.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0030.pp } +{ tests type conversations in typed consts OK 0.9.6 } + +const + a : array[0..1] of real = (1,1); + +begin +end. + diff --git a/tests/tbs/tb0027.pp b/tests/tbs/tb0027.pp new file mode 100644 index 0000000000..212f9c4bca --- /dev/null +++ b/tests/tbs/tb0027.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0031.pp } +{ tests array[boolean] of .... OK 0.9.8 } + +var + a : array[boolean] of longint; + +begin + a[true]:=1234; + a[false]:=123; +end. + diff --git a/tests/tbs/tb0028.pp b/tests/tbs/tb0028.pp new file mode 100644 index 0000000000..51fd2d5cc9 --- /dev/null +++ b/tests/tbs/tb0028.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0032.pp } +{ tests for a bugs with the stack OK 0.9.9 } + +var + p : procedure(w : word); + + procedure pp(w :word); + begin + Writeln(w); + end; + +begin + p:=@pp; + p(1234); +end. diff --git a/tests/tbs/tb0029.pp b/tests/tbs/tb0029.pp new file mode 100644 index 0000000000..e3e9b0ecda --- /dev/null +++ b/tests/tbs/tb0029.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0033.pp } +{ tests var p : pchar; begin p:='c'; end. OK 0.9.9 } + +var + p1 : pchar; + p2 : array[0..10] of char; + s : string; + c : char; + +begin + p1:='c'; + s:='c'; + { this isn't allowed + p1:=c; + } +end. diff --git a/tests/tbs/tb0030.pp b/tests/tbs/tb0030.pp new file mode 100644 index 0000000000..356296804d --- /dev/null +++ b/tests/tbs/tb0030.pp @@ -0,0 +1,20 @@ +{ %CPU=i386 } +{ Old file: tbs0034.pp } +{ shows wrong line numbering when asmbler is parsed in direct mode. } + +{ line numbering problem } +{ I don't really know how to test this (PM } + var i : longint; + +begin + asm + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + end ; + i:=0; +end. diff --git a/tests/tbs/tb0031.pp b/tests/tbs/tb0031.pp new file mode 100644 index 0000000000..72105df66f --- /dev/null +++ b/tests/tbs/tb0031.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0035.pp } +{ label at end of block gives error OK 0.9.9 (FK) } + +{$goto on} + +label hallo; + +begin + writeln('Hello'); + begin +hallo: {Error message: Incorrect expression.} + end; + writeln('Hello again'); +end. diff --git a/tests/tbs/tb0032.pp b/tests/tbs/tb0032.pp new file mode 100644 index 0000000000..c4986e4c1e --- /dev/null +++ b/tests/tbs/tb0032.pp @@ -0,0 +1,40 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux } + +{ Old file: tbs0037.pp } +{ tests missing graph.setgraphmode OK RTL (FK) } + +uses + graph, + crt; + +var + gd,gm,res : integer; + +begin + gd:=detect; + initgraph(gd,gm,''); + res := graphresult; + if res <> grOk then + begin + graphErrorMsg(res); + halt(1); + end; + setviewport(0,0,getmaxx,getmaxy,clipon); + line(1,1,100,100); + {readkey;} + setgraphmode(m1024x768); + setviewport(0,0,getmaxx,getmaxy,clipon); + res := graphresult; + if res <> grOk then + begin + closegraph; + graphErrorMsg(res); + { no error, graph mode is simply not supported } + halt(0); + end; + line(100,100,1024,800); + {readkey;} + delay(1000); + closegraph; +end. diff --git a/tests/tbs/tb0033.pp b/tests/tbs/tb0033.pp new file mode 100644 index 0000000000..fb57b2dc28 --- /dev/null +++ b/tests/tbs/tb0033.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0038.pp } +{ tests const ps : ^string = nil; OK 0.9.9 (FK) } + +CONST ps : ^STRING = nil; + +begin +end. + diff --git a/tests/tbs/tb0034.pp b/tests/tbs/tb0034.pp new file mode 100644 index 0000000000..407665a4b9 --- /dev/null +++ b/tests/tbs/tb0034.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0039.pp } +{ shows the else-else problem OK 0.9.9 (FK) } + +VAR a : BYTE; +BEGIN + a := 1; + IF a=0 THEN + IF a=1 THEN a:=2 + ELSE + ELSE a:=3; { "Illegal expression" } +END. + + diff --git a/tests/tbs/tb0035.pp b/tests/tbs/tb0035.pp new file mode 100644 index 0000000000..9bfb24851d --- /dev/null +++ b/tests/tbs/tb0035.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0040.pp } +{ shows the if b1 xor b2 problem where b1,b2 :boolean OK 0.9.9 (FK) } + +{ xor operator bug } +{ needs fix in pass_1.pas line } +{ 706. as well as in the code } +{ generator - secondadd() } +var + b1,b2: boolean; +Begin + b1:=true; + b2:=false; + If (b1 xor b2) Then + begin + end + else + begin + writeln('Problem with bool xor'); + halt; + end; + b1:=true; + b2:=true; + If (b1 xor b2) Then + begin + writeln('Problem with bool xor'); + halt; + end; + writeln('No problem found'); +end. diff --git a/tests/tbs/tb0036.pp b/tests/tbs/tb0036.pp new file mode 100644 index 0000000000..b7e8ee82b1 --- /dev/null +++ b/tests/tbs/tb0036.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0041.pp } +{ shows the if then end. problem OK 0.9.9 (FK) } + +var + b1: boolean; +Begin + begin + If b1 then { illegal expression } + end; + while b1 do +End. diff --git a/tests/tbs/tb0037.pp b/tests/tbs/tb0037.pp new file mode 100644 index 0000000000..334489f44a --- /dev/null +++ b/tests/tbs/tb0037.pp @@ -0,0 +1,12 @@ +{ %CPU=i386 } +{ %OPT= -Rintel } + +{ Old file: tbs0042.pp } +{ shows assembler double operator expression problem OK 0.99.7 (PFV) } + +Begin + asm + mov ax,3*-4 { evaluator stack underflow } + end; { due to two operators following each other } +end. { this will also happen in att syntax. } + diff --git a/tests/tbs/tb0038.pp b/tests/tbs/tb0038.pp new file mode 100644 index 0000000000..6336c3ce59 --- /dev/null +++ b/tests/tbs/tb0038.pp @@ -0,0 +1,51 @@ +{ %CPU=i386 } +{ %TARGET=go32v2,win32,linux } +{ %NOTE=This test requires an installed Nasm } + +{ Old file: tbs0043.pp } +{ shows assembler nasm output fpu opcodes problem OK 0.99.6 (PFV) } + +{$ifdef Unix} + {$output_format nasmelf} +{$endif} +{$ifdef go32v2} + {$output_format nasmcoff} +{$endif} +{$ifdef win32} + {$output_format nasmwin32} +{$endif} + +{$asmmode att} + +{ THE OUTPUT is incorrect but the } +{ parsing is correct. } +{ under nasm output only. } +{ works correctly under tasm/gas } +{ other problems occur with other } +{ things in math.inc } +{ pp -TDOS -Ratt -Anasm bug0043.pp } + procedure frac; + + begin + asm + subl $16,%esp + fnstcw -4(%ebp) + fwait { unknown instruction } + movw -4(%ebp),%cx + orw $0x0c3f,%cx + movw %cx,-8(%ebp) + fldcw -8(%ebp) + fwait { unknown instruction } + fldl 8(%ebp) + frndint + fsubl 8(%ebp) + fabsl + fclex + fldcw -4(%ebp) + leave + ret $8 + end ['ECX']; + end; + +Begin +end. diff --git a/tests/tbs/tb0039.pp b/tests/tbs/tb0039.pp new file mode 100644 index 0000000000..67ec2527e7 --- /dev/null +++ b/tests/tbs/tb0039.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0044.pp } +{ shows $ifdef and comment nesting/directive problem OK 0.99.1 (PFV) } + + { Problem with nested comments -- as you can probably see } + { but it does give out kind of a funny error output :) } + + + {$UNDEF VP} + + {$IFDEF Windows} ssss {$ENDIF} {No Syntax Error} + + {$IFDEF VP} + {$D+}{$R+} + {$ELSE} + {$IFDEF Windows} ssss {$ENDIF} {Syntax Error at: Col 25 } + {$ENDIF} + + BEGIN + END. diff --git a/tests/tbs/tb0040.pp b/tests/tbs/tb0040.pp new file mode 100644 index 0000000000..4c59e93287 --- /dev/null +++ b/tests/tbs/tb0040.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0045.pp } +{ shows problem with virtual private methods (might not be a true bugs but more of an incompatiblity?) the compiler warns now if there is a private and virtual method } + + +TYPE + tmyexample =object + public + constructor init; + destructor done; virtual; + private + procedure mytest;virtual; { syntax error --> should give only a +warning ? } + end; + + constructor tmyexample.init; + begin + end; + + destructor tmyexample.done; + Begin + end; + + procedure tmyexample.mytest; + begin + end; + +Begin +end. + diff --git a/tests/tbs/tb0041.pp b/tests/tbs/tb0041.pp new file mode 100644 index 0000000000..1da708262b --- /dev/null +++ b/tests/tbs/tb0041.pp @@ -0,0 +1,49 @@ +{ Old file: tbs0046.pp } +{ problems with sets with values over 128 due to sign extension (already fixed ) but also for SET_IN_BYTE } + +program test; + +{$R-} + +type byteset = set of byte; + bl = record i,j : longint; + end; +const set1 : byteset = [1,50,220]; + set2 : byteset = [55]; +var i : longint; + b : bl; + + function bi : longint; + + begin + bi:=b.i; + end; + +begin +set1:=set1+set2; +writeln('set 1 = [1,50,55,220]'); +i:=50; +if i in set1 then + writeln(i,' is in set1'); +i:=220; +if i in set1 then + writeln(i,' is in set1'); +i:=$100+220; +if i in set1 then + writeln(i,' is in set1'); +i:=-35; +if i in set1 then + writeln(i,' is in set1'); +b.i:=50; +i:=$100+220; +if i in [50,220] then + writeln(i,' is in [50,220]'); +if Bi in [50,220] then + writeln(b.i,' is in [50,220]'); +b.i:=220; +if bi in [50,220] then + writeln(b.i,' is in [50,220]'); +B.i:=-36; +if bi in [50,220] then + writeln(B.i,' is in [50,220]'); +end. diff --git a/tests/tbs/tb0042.pp b/tests/tbs/tb0042.pp new file mode 100644 index 0000000000..baaf17b574 --- /dev/null +++ b/tests/tbs/tb0042.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0047.pp } +{ compiling with -So crashes the compiler OK 0.99.1 (CEC) } + +procedure test; + + begin + end; + +var + p1 : procedure; + p2 : pointer; + +begin + p1:=@test; + p2:=@test; +end. diff --git a/tests/tbs/tb0043.pp b/tests/tbs/tb0043.pp new file mode 100644 index 0000000000..cf74ee2f7a --- /dev/null +++ b/tests/tbs/tb0043.pp @@ -0,0 +1,36 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux } + +{ Old file: tbs0048.pp } +{ shows a problem with putimage on some computers OK 0.99.13 (JM) } + +uses + graph,crt; + +var + gd,gm : integer; + i,size : longint; + p : pointer; + +begin + gd:=detect; + initgraph(gd,gm,''); + setcolor(brown); + line(0,0,getmaxx,0); + {readkey;}delay(1000); + size:=imagesize(0,0,getmaxx,0); + getmem(p,size); + getimage(0,0,getmaxx,0,p^); + cleardevice; + for i:=0 to getmaxy do + begin + putimage(0,i,p^,xorput); + end; + {readkey;}delay(1000); + for i:=0 to getmaxy do + begin + putimage(0,i,p^,xorput); + end; + {readkey;}delay(1000); + closegraph; +end. diff --git a/tests/tbs/tb0044.pp b/tests/tbs/tb0044.pp new file mode 100644 index 0000000000..3a512620b8 --- /dev/null +++ b/tests/tbs/tb0044.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0050.pp } +{ can't set a function result in a nested procedure of a function OK 0.99.7 (PM) } + +function Append : Boolean; + + procedure DoAppend; + begin + Append := true; + end; + +begin + Append:=False; + DoAppend; +end; + +begin + If not Append then + begin + Writeln('TBS0050 fails'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0045.pp b/tests/tbs/tb0045.pp new file mode 100644 index 0000000000..6fbf8b651b --- /dev/null +++ b/tests/tbs/tb0045.pp @@ -0,0 +1,64 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux } + +{ Old file: tbs0051.pp } +{ Graph, shows a problem with putpixel OK 0.99.9 (PM) } + +{$ifdef go32v2} + {define has_colors_equal} +{$endif go32v2} + +uses crt,graph; + +{$ifndef has_colors_equal} + function ColorsEqual(c1, c2 : longint) : boolean; + begin + ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or + ((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or + ((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or + ((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF))); + end; + +{$endif not has_colors_equal} + +var gd,gm,gError,yi,i : integer; + col: longint; + error : word; + +BEGIN + if paramcount=0 then + gm:=$111 {640x480/64K HiColor} + else + begin + val(paramstr(1),gm,error); + if error<>0 then + gm:=$111; + end; + gd:=detect; + + InitGraph(gd,gm,''); + gError := graphResult; + IF gError <> grOk + THEN begin + writeln ('graphDriver=',gd,' graphMode=',gm, + #13#10'Graphics error: ',gError); + halt(1); + end; + + for i := 0 to 255 + do begin + { new grpah unit used word type for colors } + col := {i shl 16 + }(i) shl 8 + (i div 2); + for yi := 0 to 20 do + PutPixel (i,yi,col); + SetColor (col); + Line (i,22,i,42); + end; + + for i:=0 to 255 do + if not ColorsEqual(getpixel(i,15),getpixel(i,30)) then + Halt(1); + {readkey;}delay(1000); + + closegraph; +END. diff --git a/tests/tbs/tb0046.pp b/tests/tbs/tb0046.pp new file mode 100644 index 0000000000..36c041b8f1 --- /dev/null +++ b/tests/tbs/tb0046.pp @@ -0,0 +1,41 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux} + +{ Old file: tbs0052.pp } +{ Graph, collects missing graph unit routines OK 0.99.9 (PM) } + +uses + crt,graph; + +const + Triangle: array[1..3] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), + (X: 150; Y: 150)); + Rect : array[1..4] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), + (X: 75; Y: 150), (X: 80; Y : 50)); + Penta : array[1..5] of PointType = ((X: 250; Y: 100), (X: 300; Y:100), + (X: 275; Y: 150), (X: 280; Y : 50), (X:295; Y : 80) ); + +var Gd, Gm: Integer; +begin + Gd := Detect; + InitGraph(Gd, Gm, 'c:\bp\bgi'); + if GraphResult <> grOk then + Halt(1); + drawpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); + {readln;}delay(1000); + setcolor(red); + fillpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); + {readln;}delay(1000); + SetFillStyle(SolidFill,blue); + Bar(0,0,GetMaxX,GetMaxY); + Rectangle(25,25,GetMaxX-25,GetMaxY-25); + setViewPort(25,25,GetMaxX-25,GetMaxY-25,true); + clearViewPort; + setcolor(magenta); + SetFillStyle(SolidFill,red); + fillpoly(SizeOf(Rect) div SizeOf(PointType), Rect); + fillpoly(SizeOf(Penta) div SizeOf(PointType), Penta); + graphdefaults; + {readln;}delay(1000); + CloseGraph; +end. diff --git a/tests/tbs/tb0047.pp b/tests/tbs/tb0047.pp new file mode 100644 index 0000000000..2b23112b55 --- /dev/null +++ b/tests/tbs/tb0047.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0053.pp } +{ shows a problem with open arrays OK 0.99.1 (FK) } + +procedure abc(var a : array of char); + + begin + // error: a:='asdf'; + end; + +var + c : array[0..10] of char; + +begin + abc(c); + writeln(c); + // error: writeln(a); +end. + diff --git a/tests/tbs/tb0048.pp b/tests/tbs/tb0048.pp new file mode 100644 index 0000000000..0f3bfb5ccc --- /dev/null +++ b/tests/tbs/tb0048.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0054.pp } +{ wordbool and longbool types are missed OK 0.99.6 (PFV) } + +var + wb : wordbool; + wl : longbool; + +begin +end. diff --git a/tests/tbs/tb0049.pp b/tests/tbs/tb0049.pp new file mode 100644 index 0000000000..f56cf46a3d --- /dev/null +++ b/tests/tbs/tb0049.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0055.pp } +{ internal error 10 (means too few registers OK 0.99.1 (FK) } + +type + tarraysingle = array[0..1] of single; + +procedure test(var a : tarraysingle); + +var + i,j,k : integer; + +begin + a[i]:=a[j]-a[k]; +end; + +begin +end. + diff --git a/tests/tbs/tb0050.pp b/tests/tbs/tb0050.pp new file mode 100644 index 0000000000..12134b01f0 --- /dev/null +++ b/tests/tbs/tb0050.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0056.pp } +{ shows a _very_ simple expression which generates OK 0.99.1 (FK) } + +PROGRAM ShowBug; + +(* This will compile +VAR N, E: Integer;*) + +(* This will NOT compile*) +VAR N, E: LongInt; + +BEGIN + E := 2; + WriteLn(E); + N := 44 - E; + WriteLn(N); +END. diff --git a/tests/tbs/tb0051.pp b/tests/tbs/tb0051.pp new file mode 100644 index 0000000000..639ffd257a --- /dev/null +++ b/tests/tbs/tb0051.pp @@ -0,0 +1,26 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux } + +{ Old file: tbs0057.pp } +{ Graph, shows a crash with switch graph/text/graph OK 0.99.9 (PM) } + +uses + graph,crt; + +var + gd,gm : integer; + +begin + gd:=detect; + gm:=$103; + initgraph(gd,gm,''); + setcolor(white); + line(1,1,100,100); + {readkey;}delay(1000); + closegraph; + initgraph(gd,gm,''); + line(100,100,1,100); + {readkey;}delay(1000); + closegraph; + writeln('OK'); +end. diff --git a/tests/tbs/tb0052.pp b/tests/tbs/tb0052.pp new file mode 100644 index 0000000000..3e8cf6c184 --- /dev/null +++ b/tests/tbs/tb0052.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0058.pp } +{ causes an internal error 10 (problem with getregisterOK 0.99.1 (FK) } + +{$r+} +var + a1 : array[0..1,0..1] of word; + a2 : array[0..1,0..1] of longint; + i,j,l,n : longint; + +begin + a1[i,j]:=a2[l,n]; +end. diff --git a/tests/tbs/tb0053.pp b/tests/tbs/tb0053.pp new file mode 100644 index 0000000000..b7af245695 --- /dev/null +++ b/tests/tbs/tb0053.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0059.pp } +{ shows the problem with syntax error with ordinal OK 0.99.1 (FK) } + +Program ConstBug; + +Const + S = ord('J'); + t: byte = ord('J'); + + +Begin +end. diff --git a/tests/tbs/tb0054.pp b/tests/tbs/tb0054.pp new file mode 100644 index 0000000000..eaa543612d --- /dev/null +++ b/tests/tbs/tb0054.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0061.pp } +{ shows wrong errors when compiling (NOT A bugs) OK 0.99.1 } + +var + r : double; + s : string; + +begin + r:=1234.0; + str(r,s); +end. diff --git a/tests/tbs/tb0055.pp b/tests/tbs/tb0055.pp new file mode 100644 index 0000000000..16575312f7 --- /dev/null +++ b/tests/tbs/tb0055.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0062.pp } +{ shows illegal type conversion for boolean OK 0.99.6 (PFV) } + +Program Bug0062; + + +var + myvar:boolean; +Begin + { by fixing this we also start partly implementing LONGBOOL/WORDBOOL } + myvar:=boolean(1); { illegal type conversion } +end. diff --git a/tests/tbs/tb0056.pp b/tests/tbs/tb0056.pp new file mode 100644 index 0000000000..b37349f39c --- /dev/null +++ b/tests/tbs/tb0056.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0063.pp } +{ shows problem with ranges in sets for variables OK 0.99.7 (PFV) } + +{ may also crash/do weird error messages with the compiler } +var + min: char; + max: char; + i: char; +begin + min:='c'; + max:='z'; + if i in [min..max] then + Begin + end; +end. + diff --git a/tests/tbs/tb0057.pp b/tests/tbs/tb0057.pp new file mode 100644 index 0000000000..0f4dd2df82 --- /dev/null +++ b/tests/tbs/tb0057.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0064.pp } +{ shows other types of problems with case statements OK 0.99.1 (FK) } + +var + i: byte; + j: integer; + c: char; +Begin + case i of + Ord('x'): ; + end; + case j of + Ord('x'): ; + end; + case c of + Chr(112): ; + end; +end. diff --git a/tests/tbs/tb0058.pp b/tests/tbs/tb0058.pp new file mode 100644 index 0000000000..62c9b90739 --- /dev/null +++ b/tests/tbs/tb0058.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0065.pp } +{ shows that frac() doesn't work correctly. OK 0.99.1 (PFV) } + +Program Example27; + +{ Program to demonstrate the Frac function. } + +Var R : Real; + +begin + Writeln (Frac (123.456):0:3); { Prints O.456 } + Writeln (Frac (-123.456):0:3); { Prints -O.456 } +end. diff --git a/tests/tbs/tb0059.pp b/tests/tbs/tb0059.pp new file mode 100644 index 0000000000..5c004d7829 --- /dev/null +++ b/tests/tbs/tb0059.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0066.pp } +{ shows that Round doesn't work correctly. (NOT A bugs) OK 0.99.1 } + +Program Example54; + +{ Program to demonstrate the Round function. } + +begin + Writeln (Round(123.456)); { Prints 124 } + Writeln (Round(-123.456)); { Prints -124 } + Writeln (Round(12.3456)); { Prints 12 } + Writeln (Round(-12.3456)); { Prints -12 } +end. diff --git a/tests/tbs/tb0060.pp b/tests/tbs/tb0060.pp new file mode 100644 index 0000000000..e3581cc6ee --- /dev/null +++ b/tests/tbs/tb0060.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0067b.pp } +{ (Work together) OK 0.99.1 } + +unit tb0060; + +interface + + +type + tlong=record + a : longint; + end; + +procedure p(var l:tlong); + +implementation + +uses ub0060; + +{ the tlong parameter is taken from unit bug0067, + and not from the interface part of this unit. + setting the uses clause in the interface part + removes the problem } + +procedure p(var l:tlong); +begin + ub0060.p(ub0060.tlong(l)); +end; + +end. diff --git a/tests/tbs/tb0062.pp b/tests/tbs/tb0062.pp new file mode 100644 index 0000000000..135404e10f --- /dev/null +++ b/tests/tbs/tb0062.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0068.pp } +{ Shows incorrect type of ofs() OK 0.99.1 (PFV and FK) } + +var + p : pointer; + l : smallint; +begin + l:=Ofs(p); { Ofs returns a pointer type !? } + +end. diff --git a/tests/tbs/tb0063.pp b/tests/tbs/tb0063.pp new file mode 100644 index 0000000000..749f8ace2e --- /dev/null +++ b/tests/tbs/tb0063.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0069.pp } +{ Shows problem with far qualifier in units OK 0.99.1 (CEC) } + +Unit tb0063; + +Interface + +Procedure MyTest;Far; { IMPLEMENTATION expected error. } + +{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } +{ Therefore the bugfix should only be for the FAR keyword. } +(* Procedure MySecondTest;Near; *) + +Implementation + +{ near and far are not allowed here, but maybe we don't care since they are ignored by } +{ FPC. } +Procedure MyTest; +Begin +end; + +Procedure MySecondTest; +Begin +end; + + + +end. diff --git a/tests/tbs/tb0064.pp b/tests/tbs/tb0064.pp new file mode 100644 index 0000000000..a6dd5229ff --- /dev/null +++ b/tests/tbs/tb0064.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0070.pp } +{ shows missing include and exclude from rtl OK 0.99.6 (MVC) } + +Program Test; + +type + myenum = (YES,NO,MAYBE); +var + myvar:set of myenum; +Begin + Include(myvar,Yes); + Exclude(myvar,No); +end. diff --git a/tests/tbs/tb0065.pp b/tests/tbs/tb0065.pp new file mode 100644 index 0000000000..766f469fa0 --- /dev/null +++ b/tests/tbs/tb0065.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0072.pp } +{ causes an internal error 10 ( i386 ONLY ) OK 0.99.1 (FK) } + +type + tarraysingle = array[0..1] of single; + +procedure test(var a : tarraysingle); + +var + i,j,k : integer; + +begin + a[i]:=a[j]-a[k]; +end; + +begin +end. + diff --git a/tests/tbs/tb0066.pp b/tests/tbs/tb0066.pp new file mode 100644 index 0000000000..0308aca880 --- /dev/null +++ b/tests/tbs/tb0066.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0073.pp } +{ shows incompatiblity with bp for distance qualifiers OK 0.99.6 (PFV) } + +Unit tb0066; + +Interface + + +Procedure MyTest;Far; { IMPLEMENTATION expected error. } + +{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } +{ Therefore the bugfix should only be for the FAR keyword. } + Procedure MySecondTest; + +Implementation + +{ near and far are not allowed here, but maybe we don't care since they are ignored by } +{ FPC. } +Procedure MyTest; +Begin +end; + + + +Procedure MySecondTest;Far; +Begin +end; + + + + + +end. diff --git a/tests/tbs/tb0067.pp b/tests/tbs/tb0067.pp new file mode 100644 index 0000000000..cbeb471231 --- /dev/null +++ b/tests/tbs/tb0067.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0074.pp } +{ shows MAJOR bugs when trying to compile valid code OK 0.99.1 (PM/CEC) } + +type + tmyobject = object + constructor init; + procedure callit; virtual; + destructor done; virtual; + end; + + + constructor tmyobject.init; + Begin + end; + + destructor tmyobject.done; + Begin + end; + + procedure tmyobject.callit; + Begin + WriteLn('Hello...'); + end; + + var + obj: tmyobject; + Begin + obj.init; + obj.callit; +{ obj.done;} + end. diff --git a/tests/tbs/tb0068.pp b/tests/tbs/tb0068.pp new file mode 100644 index 0000000000..64b2ccca7c --- /dev/null +++ b/tests/tbs/tb0068.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0076.pp } +{ bugs in intel asm generator. was already fixed OK 0.99.1 (FK) } + +program bug0076; + +{Generates wrong code when compiled with output set to intel asm. + + Reported from mailinglist by Vtech Kavan. + + 15 Januari 1998, Daniel Mantione} + +type TVtx2D = record x,y:longint end; + +var Vtx2d:array[0..2] of TVtx2D; + +function SetupScanLines(va,vb,vc:word):single; +var dx3d,dx2d,dy2d,dz,ex3d,ex2d,ez:longint; + r:single; +begin + dy2d := Vtx2d[vb].y; + r := (dy2d-Vtx2d[va].y); {this line causes error!!!!!!!!!!!!!!!!!!!} +end; + +begin + SetupScanLines(1,2,3); +end. + diff --git a/tests/tbs/tb0069.pp b/tests/tbs/tb0069.pp new file mode 100644 index 0000000000..61eeee52f4 --- /dev/null +++ b/tests/tbs/tb0069.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0077.pp } +{ shows a bugs with absolute in interface part of unit OK 0.99.1 (FK) } + +uses + ub0069; + +begin + b:=89; + writeln(a); +end. + + diff --git a/tests/tbs/tb0071.pp b/tests/tbs/tb0071.pp new file mode 100644 index 0000000000..bfa0a7b6b6 --- /dev/null +++ b/tests/tbs/tb0071.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0078.pp } +{ Shows problems with longint constant in intel asm OK 0.99.1 (CEC) } + +{ shows error with asm_size_mismatch } +Begin +{$ifdef CPUI386} +{$asmmode intel } + asm + mov eax, 2147483647 + mov eax, 2000000000 + end; +{$endif CPUI386} +{$ifdef CPU68K} + asm + move.l #2147483647,d0 + move.l #2000000000,d1 + end; +{$endif CPU68K} +end. diff --git a/tests/tbs/tb0072.pp b/tests/tbs/tb0072.pp new file mode 100644 index 0000000000..8132eae22b --- /dev/null +++ b/tests/tbs/tb0072.pp @@ -0,0 +1,59 @@ +{ Old file: tbs0079.pp } +{ Shows problems with stackframe with assembler keyword OK 0.99.1 (CEC) } +{ This test does not really + give a good result + because you need to look into + the assembler to see if there is an error or not :( PM } + +{$ifdef CPUI386} +{$asmmode intel} +{$endif CPUI386} + +procedure nothing(x,y: longint);assembler; +{$ifdef CPUI386} +asm + mov eax,x + mov ebx,y +end; +{$endif CPUI386} +{$ifdef CPU68K} +asm + move.l x,d0 + move.l y,d1 +end; +{$endif CPU68K} +{$ifdef CPUPOWERPC} +asm + mr r5,x + mr r6,y +end; +{$endif CPUPOWERPC} +{$ifdef CPUARM} +asm + mov r2,x + mov r3,y +end; +{$endif CPUARM} +{$ifdef CPUX86_64} +asm + movl x,%eax + movl y,%ecx +end; +{$endif CPUX86_64} +{$ifdef CPUSPARC} +asm + mov x,%i0 + mov y,%i1 +end; +{$endif CPUSPARC} + +{procedure nothing(x,y: longint); +begin + asm + mov eax,x + mov ebx,y + end; +end; } + +Begin +end. diff --git a/tests/tbs/tb0073.pp b/tests/tbs/tb0073.pp new file mode 100644 index 0000000000..235536b346 --- /dev/null +++ b/tests/tbs/tb0073.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0080.pp } +{ Shows Missing High() (internal) function. OK 0.99.6 (MVC) } + +program bug0080; + +type + + tHugeArray = array [ 1 .. High(Word) ] of byte; + +begin +end. diff --git a/tests/tbs/tb0074.pp b/tests/tbs/tb0074.pp new file mode 100644 index 0000000000..40b42c9cb2 --- /dev/null +++ b/tests/tbs/tb0074.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0081.pp } +{ Shows incompatibility with borland's 'array of char'. OK 0.99.1 (FK) } + +program bug0081; + +const + EOL : array [1..2] of char = #13 + #10; + +begin +end. diff --git a/tests/tbs/tb0075.pp b/tests/tbs/tb0075.pp new file mode 100644 index 0000000000..4d888f0829 --- /dev/null +++ b/tests/tbs/tb0075.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0082.pp } +{ Shows incompatibility with BP : Multiple destructors. OK 0.99.1 (FK) } + +Unit tb0075; + +interface + +Type T = OBject + Constructor Init; + Destructor Free; virtual; + Destructor Destroy; virtual; + end; + +implementation + +constructor T.INit; + +begin +end; + +Destructor t.Free; + +begin +end; + +Destructor t.Destroy; + +begin +end; + + +end. diff --git a/tests/tbs/tb0076.pp b/tests/tbs/tb0076.pp new file mode 100644 index 0000000000..54cdd17105 --- /dev/null +++ b/tests/tbs/tb0076.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0083.pp } +{ shows missing "dynamic" set constructor OK 0.99.7 (PFV) } + + +var + s1 : set of char; + c1,c2,c3 : char; + +begin + s1:=[c1..c2,c3]; +end. diff --git a/tests/tbs/tb0077.pp b/tests/tbs/tb0077.pp new file mode 100644 index 0000000000..6d17d601a4 --- /dev/null +++ b/tests/tbs/tb0077.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0084.pp } +{ no more pascal type checking OK 0.99.1 (FK) } + +{$R-} + +{ Basic Pascal principles gone done the drain... !!!! } + +var + v: word; + w: shortint; + z: byte; + y: integer; +Begin + y:=64000; + z:=32767; + w:=64000; + v:=-1; +end. diff --git a/tests/tbs/tb0078.pp b/tests/tbs/tb0078.pp new file mode 100644 index 0000000000..7e27ee9aa2 --- /dev/null +++ b/tests/tbs/tb0078.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0090.pp } +{ shows PChar comparison problem OK 0.99.7 (PFV) } + +{$X+} +var + mystr : array[0..4] of char; + +Begin + if mystr = #0#0#0#0 then + Begin + end; + mystr:=#0#0#0#0; +end. diff --git a/tests/tbs/tb0079.pp b/tests/tbs/tb0079.pp new file mode 100644 index 0000000000..588d8d1377 --- /dev/null +++ b/tests/tbs/tb0079.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0091.pp } +{ missing standard functions in constant expressions OK 0.99.7 (PFV) } + +{ Page 22 of The Language Guide of Turbo Pascal } +var + t: byte; +const + a = Trunc(1.3); + b = Round(1.6); + c = abs(-5); + ErrStr = 'Hello!'; + d = Length(ErrStr); + e = Lo($1234); + f = Hi($1234); + g = Chr(34); + h = Odd(1); + i = Ord('3'); + j = Pred(34); + l = Sizeof(t); + m = Succ(9); + n = Swap($1234); + o = ptr(0,0); +Begin +end. + + diff --git a/tests/tbs/tb0080.pp b/tests/tbs/tb0080.pp new file mode 100644 index 0000000000..f109b8ddf4 --- /dev/null +++ b/tests/tbs/tb0080.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0092.pp } +{ The unfixable bugs. Maybe we find a solution one day. OK 0.99.6 (FK) } + +{The unfixable bug. Maybe we get an idea when we keep looking at it. + Daniel Mantione 5 februari 1998.} + +const + a:1..4=2; {Crash 1.} + b:set of 1..4=[2,3]; {Also crashes, but is the same bug.} + +begin + writeln(a); +end. diff --git a/tests/tbs/tb0081.pp b/tests/tbs/tb0081.pp new file mode 100644 index 0000000000..c41ca82793 --- /dev/null +++ b/tests/tbs/tb0081.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0093.pp } +{ Two Cardinal type bugss 0K 0.99.1 (FK/MvC) } + +{ Two cardinal type bugs } +var + c : cardinal; + l : longint; + b : byte; + s : shortint; + w : word; +begin + b:=123; + w:=s; + l:=b; + c:=b; {generates movzbl %eax,%edx instead of movzbl %al,%edx} + + c:=123; + writeln(c); {Shows '0' outline right! instead of '123' outlined left} + c:=$7fffffff; + writeln(c); {Shows '0' outline right! instead of '123' outlined left} +end. diff --git a/tests/tbs/tb0082.pp b/tests/tbs/tb0082.pp new file mode 100644 index 0000000000..4c636daa12 --- /dev/null +++ b/tests/tbs/tb0082.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0095.pp } +{ case with ranges starting with #0 bugss OK 0.99.1 (FK) } + +var + ch : char; +begin + ch:=#3; + case ch of + #0..#31 : ; + else + writeln('bug'); + end; + case ch of + #0,#1,#3 : ; + else + writeln('bug'); + end; +end. diff --git a/tests/tbs/tb0083.pp b/tests/tbs/tb0083.pp new file mode 100644 index 0000000000..1732a92b3d --- /dev/null +++ b/tests/tbs/tb0083.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0096.pp } +{ problem with objects as parameters OK 0.99.6 (PM) } + +type + TParent = object + end; + + PParent = ^TParent; + + TChild = object(TParent) + end; + +procedure aProc(const x : TParent ); +begin +end; + +procedure anotherProc(var x : TParent ); +begin +end; + +var + y : TChild; + + begin + aProc(y); + anotherProc(y); + end. diff --git a/tests/tbs/tb0084.pp b/tests/tbs/tb0084.pp new file mode 100644 index 0000000000..1a7061f628 --- /dev/null +++ b/tests/tbs/tb0084.pp @@ -0,0 +1,55 @@ +{ Old file: tbs0098.pp } +{ File type casts are not allowed (works in TP7) OK 0.99.1 (FK) } + +program Test; +{ Show how to seek to an OFFSET (not a line number) in a textfile, } +{ without using asm. Arne de Bruijn, 1994, PD } +uses Dos; { For TextRec and FileRec } +var + F:text; + L:longint; + S:string; +begin + { Create temp } + assign(F,'tb0084.tmp'); { Assign F to itself } + rewrite(f); + for l:=1 to 100 do + writeln('Hello world'); + close(f); + + assign(F,'tb0084.tmp'); { Assign F to itself } + reset(F); { Open it (as a textfile) } + ReadLn(F); { Just read some lines } + ReadLn(F); + ReadLn(F); + FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } + { (The (@F)^ part is to let TP 'forget' the type of the structure, so } + { you can type-caste it to everything (note that with and without (@X)^ } + { can give a different value, longint(bytevar) gives the same value as } + { bytevar, while longint((@bytevar)^) gives the same as } + { longint absolute Bytevar (i.e. all 4 bytes in a longint are readed } + { from memory instead of 3 filled with zeros))) } + FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} + L:=(FilePos(File((@F)^))-TextRec(F).BufEnd)+TextRec(F).BufPos; +{... This line didn't work the last time I tried, it chokes on the "File" +typecasting thing.} + + { Get the fileposition, subtract the already readed buffer, and add the } + { position in that buffer } + TextRec(F).Mode:=fmInput; { Set back to text mode } + TextRec(F).BufSize:=SizeOf(TextBuf); { BufSize overwritten by RecSize } + { Doesn't work with SetTextBuf! } + ReadLn(F,S); { Read the next line } + WriteLn('Next line:',S); { Display it } + FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } + FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} + Seek(File((@F)^),L); { Do the seek } +{... And again here.} + + TextRec(F).Mode:=fmInput; { Set back to text mode } + TextRec(F).BufSize:=SizeOf(TextBuf); { Doesn't work with SetTextBuf! } + TextRec(F).BufPos:=0; TextRec(F).BufEnd:=0; { Reset buffer counters } + ReadLn(F,S); { Show that it worked, the same } + WriteLn('That line again:',S); { line readed again! } + Close(F); { Close it } +end. diff --git a/tests/tbs/tb0085.pp b/tests/tbs/tb0085.pp new file mode 100644 index 0000000000..e5638b81eb --- /dev/null +++ b/tests/tbs/tb0085.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0099.pp } +{ wrong assembler code is genereatoed for range check OK 0.99.1 (?) } + + +{$R+} +var w:word; + s:Shortint; +begin + w := s; +end. diff --git a/tests/tbs/tb0086.pp b/tests/tbs/tb0086.pp new file mode 100644 index 0000000000..ece25c8fab --- /dev/null +++ b/tests/tbs/tb0086.pp @@ -0,0 +1,24 @@ +{ %CPU=m68k } + +{ Old file: tbs0102.pp } +{ page fault when trying to compile under ppcm68k OK 0.99.1 } + +{ assembler reader of m68k for register ranges } + +unit tb0086; + interface + + implementation + +{$ifdef M68K} + procedure int_help_constructor; + + begin + asm + movem.l d0-a7,-(sp) + end; + end; +{$endif M68K} + + + end. diff --git a/tests/tbs/tb0087.pp b/tests/tbs/tb0087.pp new file mode 100644 index 0000000000..7ac377e809 --- /dev/null +++ b/tests/tbs/tb0087.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0103.pp } +{ problems with boolean typecasts (other type) OK 0.99.6 (PFV) } + + +Var + out: boolean; + int: byte; +Begin + { savesize is different! } + out:=boolean((int AND $20) SHL 4); +end. diff --git a/tests/tbs/tb0088.pp b/tests/tbs/tb0088.pp new file mode 100644 index 0000000000..538d12fb2a --- /dev/null +++ b/tests/tbs/tb0088.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0104.pp } +{ cardinal greater than $7fffffff aren't written OK 0.99.1 (FK) } + +{ Two cardinal type bugs } +var + c : cardinal; +begin + c:=$80000000; + writeln(c); + c:=$80001234; + writeln(c); + c:=$ffffffff; + writeln(c); +end. diff --git a/tests/tbs/tb0089.pp b/tests/tbs/tb0089.pp new file mode 100644 index 0000000000..e96d058854 --- /dev/null +++ b/tests/tbs/tb0089.pp @@ -0,0 +1,52 @@ +{ %TARGET=go32v2,linux } +{ %SKIPEMU=qemu-arm } + +{ Old file: tbs0105.pp } +{ typecasts are now ignored problem (NOT A bugs) OK 0.99.1 } + +{ Win32 signal support is still missing ! } + +{$ifdef go32v2} + uses dpmiexcp; +{$endif go32v2} +{$ifdef unix} + {$ifdef ver1_0} + uses linux; + {$else} + uses baseunix; + {$endif} +{$endif unix} + + function our_sig(l : longint) : longint;{$ifdef unix}cdecl;{$endif} + begin + { If we land here the program works correctly !! } + Writeln('Sigsegv signal recieved'); + our_sig:=0; + Halt(0); + end; + +Var + Sel: Word; + v: pointer; +Begin + {$ifdef unix} + {$ifdef ver1_0} + Signal(SIGSEGV,signalhandler(@our_sig)); + {$else} + fpSignal(SIGSEGV,signalhandler(@our_sig)); + {$endif} + {$else} + Signal(SIGSEGV,signalhandler(@our_sig)); + {$endif} + { generate a sigsegv by writing to null-address } + sel:=0; + v:=nil; +{$ifdef go32v2} + { on win9X no zero page protection :( } + v:=pointer(-2); +{$endif go32v2} + word(v^):=sel; + { we should not go to here } + Writeln('Error : signal not called'); + Halt(1); +end. diff --git a/tests/tbs/tb0090.pp b/tests/tbs/tb0090.pp new file mode 100644 index 0000000000..49c546c4a8 --- /dev/null +++ b/tests/tbs/tb0090.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0106.pp } +{ typecasts are now ignored problem (NOT A bugs) OK 0.99.1 } + +{$R-} + +{ I think this now occurs with most type casting... } +{ I think type casting is no longer considered?? } + +Var + Sel: Word; + Sel2: byte; +Begin + Sel:=word($7fffffff); + Sel2:=byte($7fff); +end. diff --git a/tests/tbs/tb0091.pp b/tests/tbs/tb0091.pp new file mode 100644 index 0000000000..79e0118488 --- /dev/null +++ b/tests/tbs/tb0091.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0107.pp } +{ shows page fault problem (run in TRUE DOS mode) OK ??.?? } + +{ PAGE FAULT PROBLEM ... TEST UNDER DOS ONLY! Not windows... } +{ -Cr -g flags } + +Program Test1; + +type + myObject = object + constructor init; + procedure v;virtual; + end; + + constructor myobject.init; + Begin + end; + + procedure myobject.v; + Begin + WriteLn('Hello....'); + end; + +var + my: myobject; +Begin + my.init; + my.v; +end. diff --git a/tests/tbs/tb0092.pp b/tests/tbs/tb0092.pp new file mode 100644 index 0000000000..e6d8c543b0 --- /dev/null +++ b/tests/tbs/tb0092.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0109.pp } +{ syntax error not detected when using a set as pointer OK 0.99.1 (FK) } + +Type T = (aa,bb,cc,dd,ee,ff,gg,hh); + Tset = set of t; + +Var a: Tset; + +Begin + If (aa in a) Then begin end; + {it seems that correct code is generated, but the syntax is wrong} +End. diff --git a/tests/tbs/tb0093.pp b/tests/tbs/tb0093.pp new file mode 100644 index 0000000000..58499305d8 --- /dev/null +++ b/tests/tbs/tb0093.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0111.pp } +{ blockread(typedfile,...) is not allowed in TP7 } + +var + ft : text; + f : file of word; + i : word; + buf : string; +begin + assign(ft,'tbs0111.tmp'); + rewrite(ft); + for i:=1 to 40 do + Writeln(ft,'Dummy text to test bug 111'); + close(ft); + assign(f,'tbs0111.tmp'); + reset(f); + blockread(f,buf[1],127,i); { This is not allowed in BP7 } + buf[0]:=chr(i*2); + close(f); + writeln(i); + writeln(buf); + erase(f); +end. diff --git a/tests/tbs/tb0094.pp b/tests/tbs/tb0094.pp new file mode 100644 index 0000000000..c9ee0d6286 --- /dev/null +++ b/tests/tbs/tb0094.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0112.pp } +{ still generates an internal error 10 OK 0.99.1 (FK) } + +type + TextBuf=array[0..127] of char; + TextRec=record + BufPtr : ^textbuf; + BufPos : word; + end; + +Function ReadNumeric(var f:TextRec;var s:string;base:longint):Boolean; +{ + Read Numeric Input, if buffer is empty then return True +} +begin + while ((base>=10) and (f.BufPtr^[f.BufPos] in ['0'..'9'])) or + ((base=16) and (f.BufPtr^[f.BufPos] in ['A'..'F'])) or + ((base=2) and (f.BufPtr^[f.BufPos] in ['0'..'1'])) do + Begin + End; +end; + +begin +end. diff --git a/tests/tbs/tb0095.pp b/tests/tbs/tb0095.pp new file mode 100644 index 0000000000..cade856486 --- /dev/null +++ b/tests/tbs/tb0095.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0113.pp } +{ point initialization problems OK 0.99.1 (PM/FK) } + +program test; + +type pRecord = ^aRecord; + aRecord = record + next : pRecord; + a, b, c : integer; + end; + +const rec1 : aRecord = (next : nil; a : 10; b : 20; c : 30); + rec2 : aRecord = (next : @rec1; a : 20; b : 30; c : 40); + +begin +end. diff --git a/tests/tbs/tb0096.pp b/tests/tbs/tb0096.pp new file mode 100644 index 0000000000..1512913fa0 --- /dev/null +++ b/tests/tbs/tb0096.pp @@ -0,0 +1,6 @@ +{ Old file: tbs0114.pp } +{ writeln problem (by Pavel Ozerski) OK 0.99.1 (PFV) } + +begin + write{ln}(0.997:0:2); +end. diff --git a/tests/tbs/tb0097.pp b/tests/tbs/tb0097.pp new file mode 100644 index 0000000000..d61f6ffb3d --- /dev/null +++ b/tests/tbs/tb0097.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0115.pp } +{ missing writeln for comp data type OK 0.99.6 (FK) } + +var + c : comp; + +begin + c:=1234; + writeln(c); + {readln(c);} + c:=-258674; + writeln(c); +end. + diff --git a/tests/tbs/tb0098.pp b/tests/tbs/tb0098.pp new file mode 100644 index 0000000000..9b41c3a548 --- /dev/null +++ b/tests/tbs/tb0098.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0116.pp } +{ when local variable size is > $ffff, enter can't be used to create the stack frame, but it is with -Og } + +Procedure test; +{compile with -Og to show bug} + +Var a: Array[1..4000000] of longint; +Begin +End; + +Begin +End. diff --git a/tests/tbs/tb0099.pp b/tests/tbs/tb0099.pp new file mode 100644 index 0000000000..f06e1f80d5 --- /dev/null +++ b/tests/tbs/tb0099.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0118.pp } +{ Procedural vars cannot be assigned nil ? OK 0.99.6 (FK) } + +program Test1; + + type + ExampleProc = procedure; + + var + Eg: ExampleProc; + + begin + Eg := nil; { This produces a compiler error } + end. diff --git a/tests/tbs/tb0100.pp b/tests/tbs/tb0100.pp new file mode 100644 index 0000000000..50ec4ce6f6 --- /dev/null +++ b/tests/tbs/tb0100.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0119.pp } +{ problem with methods OK 0.99.6 (FK) } + +program ObjTest; + uses crt; + + type + ObjectA = object + procedure Greetings; + procedure DoIt; + end; + ObjectB = object (ObjectA) + procedure Greetings; + procedure DoIt; + end; + + procedure ObjectA.Greetings; + begin + writeln(' A'); + end; + procedure ObjectA.DoIt; + begin + writeln('A '); + Greetings; + end; + + procedure ObjectB.Greetings; + begin + writeln(' B'); + end; + procedure ObjectB.DoIt; + begin + writeln('B'); + Greetings; + end; + + var + A: ObjectA; + B: ObjectB; + + begin + A.DoIt; + B.DoIt; + writeln; writeln('Now doing it directly:'); + A.Greetings; + B.Greetings; + end. diff --git a/tests/tbs/tb0101.pp b/tests/tbs/tb0101.pp new file mode 100644 index 0000000000..5707e44e36 --- /dev/null +++ b/tests/tbs/tb0101.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0120.pp } +{ inc/dec(enumeration) doesn't work OK 0.99.6 (MVC) } + +type + te = (enum1,enum2,enum3); + +var + e,f : te; + +begin + e:=enum1; + inc(e); + f:=enum3; + dec(f); + if e<>f then + halt(1); +end. diff --git a/tests/tbs/tb0102.pp b/tests/tbs/tb0102.pp new file mode 100644 index 0000000000..09457be669 --- /dev/null +++ b/tests/tbs/tb0102.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0121.pp } +{ cardinal -> byte conversion not work (and crashes) OK 0.99.6 (FK) } + +{$R+} +var + + c : cardinal; + i : integer; + w : word; + b : byte; + si : shortint; + +begin + w:=c; + i:=c; + b:=c; + b:=si; +end. + + + diff --git a/tests/tbs/tb0103.pp b/tests/tbs/tb0103.pp new file mode 100644 index 0000000000..34c49758ec --- /dev/null +++ b/tests/tbs/tb0103.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0122.pp } +{ exit() gives a warning that the result is not set OK 0.99.6 (FK) } + + +function f:longint; +begin + exit(1); +end; + +begin + writeln(f); +end. diff --git a/tests/tbs/tb0104.pp b/tests/tbs/tb0104.pp new file mode 100644 index 0000000000..8c4f7b5476 --- /dev/null +++ b/tests/tbs/tb0104.pp @@ -0,0 +1,22 @@ +{ %CPU=i386 } +{ Old file: tbs0123.pp } +{ Asm, problem with intel assembler (shrd) OK 0.99.11 (PM) } + +{ bug for shrd assemblerreader } +begin + if false then + begin +{$asmmode intel} + asm + SHRD [ESI-8], EAX, CL + SHLD EBX,ECX,5 + IMUL ECX,dword [EBP-8],5 + end; +{$asmmode att} + asm + shrdl %cl,%eax,-8(%esi) + shldl $5,%ecx,%ebx + imull $5,-8(%ebp),%ecx + end; + end; +end. diff --git a/tests/tbs/tb0105.pp b/tests/tbs/tb0105.pp new file mode 100644 index 0000000000..1cca59c9fc --- /dev/null +++ b/tests/tbs/tb0105.pp @@ -0,0 +1,43 @@ +{ %TARGET=linux,go32v2 } +{ %CPU=i386 } +{ %OPT= -Aas } + +{ Old file: tbs0124.pp } +{ Asm, problem with -Rintel switch and indexing OK 0.99.11 (PM/PFV) } + +{ this problem comes from the fact that + L is a static variable, not a local one !! + but the static variable symtable is the localst of the + main procedure (PM) + It must be checked if we are at main level or not !! } + +var + l : longint; + + procedure error; + begin + Writeln('Error in tbs0124'); + Halt(1); + end; + +begin + l:=5; +{$asmmode att} + asm + movl l,%eax + addl $2,%eax + movl %eax,l + end; + if l<>7 then error; +{$asmmode intel} + { problem here is that l is replaced by BP-offset } + { relative to stack, and the parser thinks all wrong } + { because of this. } + asm + mov eax,l + add eax,5 + mov l,eax + end; + if l<>12 then error; + Writeln('tbs0124 OK'); +end. diff --git a/tests/tbs/tb0106.pp b/tests/tbs/tb0106.pp new file mode 100644 index 0000000000..6d26ec4f02 --- /dev/null +++ b/tests/tbs/tb0106.pp @@ -0,0 +1,25 @@ +{ %CPU=i386 } +{ Old file: tbs0124b.pp } +{ } + +{$asmmode intel} +var + i : byte; + l : array[0..7] of longint; +begin + { problem here is that l is replaced by BP-offset } + { relative to stack, and the parser thinks all wrong } + { because of this. } + + for i:=0 to 7 do + l[i]:=35; + asm + mov eax,3 + mov byte ptr l[eax*4],55 + end; + if l[3]<>55 then + begin + Writeln('Error in parsing assembler'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0107.pp b/tests/tbs/tb0107.pp new file mode 100644 index 0000000000..896c8b9ee3 --- /dev/null +++ b/tests/tbs/tb0107.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0125.pp } +{ wrong colors with DOS CRT unit OK 0.99.6 (PFV) } + +uses +crt; +var +i:integer; +begin +clrscr; +textcolor(blue); +writeln('ole'); +textcolor(red); +writeln('rasmussen'); +writeln(i); +end. diff --git a/tests/tbs/tb0108.pp b/tests/tbs/tb0108.pp new file mode 100644 index 0000000000..a734bccb42 --- /dev/null +++ b/tests/tbs/tb0108.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0126.pp } +{ packed array isn't allowed OK 0.99.6 (FK) } + +type + myarray = packed array[0..10] of longint; + +begin +end. diff --git a/tests/tbs/tb0109.pp b/tests/tbs/tb0109.pp new file mode 100644 index 0000000000..ea0d97f340 --- /dev/null +++ b/tests/tbs/tb0109.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0128.pp } +{ problem with ^[ OK 0.99.6 (PFV) } + +{ ^ followed by a letter must be interpreted differently + depending on context } + +const + ArrowKeysOrFirstLetter='arrow keys '^]^r^z' or First letter. '; + +begin + writeln(ord(^))); +end. diff --git a/tests/tbs/tb0110.pp b/tests/tbs/tb0110.pp new file mode 100644 index 0000000000..93e02e9ab0 --- /dev/null +++ b/tests/tbs/tb0110.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0129.pp } +{ endless loop with while/continue OK 0.99.6 (FK) } + +var + e:boolean; + a:integer; +begin + e:=true; + a:=3; + while (a<5) and e do begin + e:=false; + write('*'); + continue; + end; +end. diff --git a/tests/tbs/tb0111.pp b/tests/tbs/tb0111.pp new file mode 100644 index 0000000000..1b0bc50866 --- /dev/null +++ b/tests/tbs/tb0111.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0130.pp } +{ in [..#255] problem OK 0.99.6 (PFV) } + +var + c : char; +begin + c:=#91; + if c in [#64..#255] then + writeln('boe'); + c:=#32; + if c in [#64..#255] then + writeln('boe'); +end. + diff --git a/tests/tbs/tb0112.pp b/tests/tbs/tb0112.pp new file mode 100644 index 0000000000..9ad527bb7f --- /dev/null +++ b/tests/tbs/tb0112.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0131.pp } +{ internal error 10 with highdimension arrays OK 0.99.6 (MVC) } + +type TA = Array[1..2,1..2,1..2,1..2,1..2,1..2,1..3,1..3,1..3,1..3] of Byte; + TA2 = Array[1..2,1..2,1..2] of Byte; + +var v,w: ta; + x: ta2; + e: longint; + +Begin + e :=1; + x[e,e,e]:=1; + v[e,e,e,e,e,e,e,e,e,e] :=1; + w[e,e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,v[e,e,e,e,e,e,v[e,v[e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,e,e],e,e,e,e,e,e,e,e],e,e,e]] := v [e,e,e,e,e,e,e,e,e,e]; + writeln(w[e,e,e,e,e,e,e,e,e,e]); + if w[e,e,e,e,e,e,e,e,e,e]<>1 then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0113.pp b/tests/tbs/tb0113.pp new file mode 100644 index 0000000000..f671a920cd --- /dev/null +++ b/tests/tbs/tb0113.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0132.pp } +{ segmentation fault with type loop OK 0.99.7 (FK) } + +type + + p=^p2; + p2 = ^p; + + var a:p; + a2:p2; + + begin + a:=@a2; + a2:=@a; + a:=a2^; + end. diff --git a/tests/tbs/tb0114.pp b/tests/tbs/tb0114.pp new file mode 100644 index 0000000000..795f39220f --- /dev/null +++ b/tests/tbs/tb0114.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0133.pp } +{ object type declaration not 100% compatibile with TP7 } + +type + t=object + f : longint; + procedure p; + g : longint; { Not allowed in BP7 } + end; + + procedure t.p; + begin + end; + + begin + end. + diff --git a/tests/tbs/tb0115.pp b/tests/tbs/tb0115.pp new file mode 100644 index 0000000000..a434a56641 --- /dev/null +++ b/tests/tbs/tb0115.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0134.pp } +{ 'continue' keyword is bugsgy. OK 0.99.6 (FK) } + +{ +In this simple examply, the even loop is wrong. When continue; is called, +it should go back to the top and check the loop conditions and exit when i = +4, but continue skips checking the loop conditions and does i=5 too, then it +is odd, doesn't run the continue, and the loop terminates properly. +} + + +procedure demoloop( max:integer ); +var i : integer; +begin +i := 1; +while (i <= max) do + begin + if (i mod 2 = 0) then + begin + writeln('Even ',i,' of ',max); + inc(i); + continue; + end; + writeln('Odd ',i,' of ',max); + inc(i); + end; +end; + +begin +writeln('Odd loop (continue is *not* last call):'); +demoloop(3); +writeln('Even loop (continue is last call):'); +demoloop(4); +end. diff --git a/tests/tbs/tb0116.pp b/tests/tbs/tb0116.pp new file mode 100644 index 0000000000..c73f9a349f --- /dev/null +++ b/tests/tbs/tb0116.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0135.pp } +{ Unsupported subrange type construction. OK 0.99.6 } + +program test; +const + A = 0; + B = 1; + C = 2; + +type D = A..C; + +begin +end. diff --git a/tests/tbs/tb0117.pp b/tests/tbs/tb0117.pp new file mode 100644 index 0000000000..53627e5aec --- /dev/null +++ b/tests/tbs/tb0117.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0137.pp } +{ Cannot assign child object variable to parent objcet type variable OK 0.99.6 } + +program OO_Test; + +Type TVater = Object + Constructor Init; + Procedure Gehen; Virtual; + Procedure Laufen; Virtual; + End; + + TSohn = Object(TVater) + Procedure Gehen; Virtual; + End; + +Var V : TVater; + S : TSohn; + +Constructor TVater.Init; +Begin +End; + +Procedure TVater.Gehen; +Begin + Writeln('langsam gehen'); +End; + +Procedure TVater.Laufen; +Begin + Gehen; + Gehen; +End; + +Procedure TSohn.Gehen; +Begin + Writeln('schnell gehen'); +End; + +Begin + V.Init; + S.Init; + V.Laufen; + Writeln; + S.Laufen; + Writeln; + V := S; + V.Gehen; +End. diff --git a/tests/tbs/tb0118.pp b/tests/tbs/tb0118.pp new file mode 100644 index 0000000000..53aa887a5d --- /dev/null +++ b/tests/tbs/tb0118.pp @@ -0,0 +1,76 @@ +{ %maxversion=1.0.99 } + +{ Old file: tbs0138.pp } +{ with problem, %esi can be crushed and is not restored OK 0.99.6 (PM) } + +{program p; uncomment for a crash} +type + tpt=^tpo; + tpo=object + constructor init; + procedure pi1; + procedure pi2; + end; +constructor tpo.init; +begin +end; +procedure tpo.pi1; +begin +end; +procedure tpo.pi2; +begin +end; +procedure crushesi;assembler; +{$ifdef CPUI386} +asm + movl %eax,%esi +end ['EAX','ESI']; +{$endif CPUI386} +{$ifdef CPU68K} +asm + move.l d0,a5 +end ['d0','a5']; +{$endif CPU68K} +{$ifdef CPUPOWERPC} +asm + // doesn't matter, there is no static register used anymore for self, + // and self is now loaded on-demand instead of always + li r0,0 + li r3,0 + li r4,0 + li r5,0 + li r6,0 + li r7,0 + li r8,0 + li r9,0 + li r10,0 + li r11,0 + li r12,0 +end; +{$endif CPUPOWERPC} +{$ifdef CPUARM} +asm + // doesn't matter, there is no static register used anymore for self, + // and self is now loaded on-demand instead of always + mov r0,0 + mov r1,0 + mov r2,0 + mov r3,0 +end; +{$endif CPUARM} + + +var + p1 : tpt; +begin + p1:=new(tpt,init); + with p1^ do + begin + pi1; + crushesi; { After this the %esi should be reloaded from the tempvariable } + pi1; + end; +{ There is here already a tempvar for %esi, why not use it here too ? } + p1^.pi2; + p1^.pi2; +end. diff --git a/tests/tbs/tb0119.pp b/tests/tbs/tb0119.pp new file mode 100644 index 0000000000..5d46a8a993 --- /dev/null +++ b/tests/tbs/tb0119.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0139.pp } +{ Cannot access protected method of ancestor class from other unit. OK 0.99.6 } + +unit tb0119; + +{$mode objfpc} + + interface + uses + ub0119; + + type + AnotherClass=class(SomeClass) + protected + procedure doSomething; override; + end ; + + implementation + + procedure AnotherClass.doSomething; + begin + inherited doSomething; // this causes the error: " can not call protected + // method from here " ( or something similar ) + end ; + +end. diff --git a/tests/tbs/tb0120.pp b/tests/tbs/tb0120.pp new file mode 100644 index 0000000000..5c92571b5f --- /dev/null +++ b/tests/tbs/tb0120.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0140.pp } +{ Shows that interdependent units still are not OK. OK 0.99.6 (PFV) } + +unit tb0120; + +{ + The first compilation runs fine. + A second compilation (i.e; .ppu files exist already) crashes the compiler !! +} + +interface + +type + TObject = object + constructor Init(aPar:byte); + end; + +implementation + +uses ub0120; + +constructor TObject.Init(aPar:byte); + begin + if aPar=0 then Message(Self); + end; + +end. diff --git a/tests/tbs/tb0122.pp b/tests/tbs/tb0122.pp new file mode 100644 index 0000000000..e9b2c8a71a --- /dev/null +++ b/tests/tbs/tb0122.pp @@ -0,0 +1,71 @@ +{ %OPT= -S2 } + +{ Old file: tbs0141.pp } +{ Wrong Class sizes when using forwardly defined classes. OK 0.99.6 } + +program bug; + +{ uses objpas; not with -S2 !! } +type + // + TObjectAB = class; + TObjectABCD = class; + TObjectABCDEF = class; + // } + TObjectAB = class(tobject) + a, b: integer; + end ; + TObjectABCD = class(TObjectAB) + c, d: integer; + end ; + TObjectABCDEF = class(TObjectABCD) + e, f: integer; + end ; + +var + a, b, c: TObject; + +begin +a := TObjectAB.Create; +WriteLn(a.InstanceSize, ' Should be: 12'); +if a.InstanceSize + SizeOf(integer)*2 <> TObjectABCD.InstanceSize then + Halt(1); +b := TObjectABCD.Create; +if b.InstanceSize + SizeOf(integer)*2 <> TObjectABCDEF.InstanceSize then + Halt(1); +WriteLn(b.InstanceSize, ' Should be: 20'); +c := TObjectABCDEF.Create; +WriteLn(c.InstanceSize, ' Should be: 28'); +end. + +{ +Here are the VMT tables from the assembler file: + +.globl VMT_TD$_TOBJECTAB +VMT_TD$_TOBJECTAB: + .long 12,-12 + .long VMT_OBJPAS$_TOBJECT + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +.globl VMT_TD$_TOBJECTABCD +VMT_TD$_TOBJECTABCD: + .long 12,-12 + .long VMT_TD$_TOBJECTAB + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +.globl VMT_TD$_TOBJECTABCDEF +VMT_TD$_TOBJECTABCDEF: + .long 12,-12 + .long VMT_TD$_TOBJECTABCD + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +} diff --git a/tests/tbs/tb0123.pp b/tests/tbs/tb0123.pp new file mode 100644 index 0000000000..4b2d9a184b --- /dev/null +++ b/tests/tbs/tb0123.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0142.pp } +{ sizeof(object) is not tp7 compatible when no constructor is used OK 0.99.9 (PM) } + + +{$PACKRECORDS 1} + +type +Time = object + h,m,s:byte; +end; + +var OT:Time; + l : longint; +begin + l:=SizeOf(OT); +end. diff --git a/tests/tbs/tb0124.pp b/tests/tbs/tb0124.pp new file mode 100644 index 0000000000..afe44f160a --- /dev/null +++ b/tests/tbs/tb0124.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0143.pp } +{ cannot concat string and array of char in $X+ mode OK 0.99.7 (PFV) } + + + +const + string1 : string = 'hello '; + string2 : array[1..5] of char = 'there'; +var + s : string; +begin + s:=string1+string2; + writeln(string1+string2); +end. diff --git a/tests/tbs/tb0125.pp b/tests/tbs/tb0125.pp new file mode 100644 index 0000000000..fd554b2cbd --- /dev/null +++ b/tests/tbs/tb0125.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0144.pp } +{ problem with 'with object do' OK 0.99.7 (PFV) } + +program done_bug; + +type +TObject = object + Constructor Init; + Destructor Done; +end; +PObject = ^TObject; + +Constructor TObject.Init; +begin end; +Destructor TObject.Done; +begin end; + +var P:PObject; + +begin +New(P,Init); +with P^ do Done; { Compiler PANIC here ! } +Dispose(P); +end. diff --git a/tests/tbs/tb0126.pp b/tests/tbs/tb0126.pp new file mode 100644 index 0000000000..d03df30d81 --- /dev/null +++ b/tests/tbs/tb0126.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0145.pp } +{ typed files with huges records (needs filerec.size:longint) OK 0.99.7 (PFV) } + +{$I+} +const + Mb=512; + siz=1024*Mb; + +type + buf=array[1..siz] of byte; + +var + fin, + fout : file of buf; + b1,a1 : buf; + +begin + fillchar(a1,sizeof(a1),1); + assign(fout,'tmp.tmp'); + rewrite(fout); + write(fout,a1); + close(fout); + + assign(fin,'tmp.tmp'); + reset(fin); + read(fin,b1); + close(fin); + if not b1[512*Mb]=1 then + begin + writeln('data err'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0127.pp b/tests/tbs/tb0127.pp new file mode 100644 index 0000000000..439489df25 --- /dev/null +++ b/tests/tbs/tb0127.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0146.pp } +{ no sizeof() for var arrays and the size is pushed incorrect OK 0.99.7 (PFV) } + + +procedure myfunction(var t : array of char); +begin + writeln(sizeof(t)); { should be 51 } + if sizeof(t)<>51 then halt(1); +end; + +var + mycharstring : array[0..50] of char; + +begin + myfunction(mycharstring); + if sizeof(mycharstring)<>51 then halt(1); +end. diff --git a/tests/tbs/tb0128.pp b/tests/tbs/tb0128.pp new file mode 100644 index 0000000000..b9da11245c --- /dev/null +++ b/tests/tbs/tb0128.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0147.pp } +{ function b; is not allowed in implementation OK 0.99.7 (PFV) } + +{$mode tp} +unit tb0128; +interface + +function b:boolean; + +implementation + +function b; +begin +end; + +end. diff --git a/tests/tbs/tb0129.pp b/tests/tbs/tb0129.pp new file mode 100644 index 0000000000..49f7ed4cc8 --- /dev/null +++ b/tests/tbs/tb0129.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0149b.pp } +{ } + +{there is no crash when tset or c from unit a are used in OuterProcedure, + it's only a problem when using them in a nested procedure/function} + +unit tb0129; + +interface + +uses ub0129; + +implementation + +Procedure OuterProcedure; + + function t(a: byte): byte; + begin + if a = c then t := a else t := 0; + if a in tset {probably same bug} + then t := a + else t := 0 + end; + +Begin +End; + +end. diff --git a/tests/tbs/tb0130.pp b/tests/tbs/tb0130.pp new file mode 100644 index 0000000000..193657c39f --- /dev/null +++ b/tests/tbs/tb0130.pp @@ -0,0 +1,30 @@ +{ %RESULT=227 } +{ Old file: tbs0150.pp } +{ Shows that the assert() macro is missing under Delphi OK 0.99.9 (PFV) } + +{ + bug to show that there is no assert() macro and directive +} + +var B : boolean; + i : integer; + +begin + b:=true; + i:=0; + // First for assert messages should not give anything. + // First two generate code, but are OK. + // second two don't generate code ($C- !) +{$c+} + assert (b); + assert (I=0); +{$c-} + assert (not(b)); + assert (i<>0); +{$c+} + // This one should give the normal assert message. + assert (not(b)); + // This one should give a custom assert message. + // you must uncomment the previous one to see this one. + assert (not(I=0),'Custom assert message'); +end. diff --git a/tests/tbs/tb0131.pp b/tests/tbs/tb0131.pp new file mode 100644 index 0000000000..07232d08c1 --- /dev/null +++ b/tests/tbs/tb0131.pp @@ -0,0 +1,39 @@ +{ Old file: tbs0152.pp } +{ End value of loop variable must be calculated before loop variable is initialized. OK 0.99.11 (PM) } + +Program tbs0152; + +{ + Shows wrong evaluation of loop boundaries. First end boundary must + be calculated, only then Loop variable should be initialized. + Change loop variable to J to see what should be the correct output. +} + +PROCEDURE LGrow(VAR S : String;C:CHAR;Count:WORD); + + VAR I,J :WORD; + +BEGIN + I:=ORD(S[0]); { Keeping length in local data eases optimalisations} + IF I<Count THEN + BEGIN + Move(S[1],S[Count-I+1],I); + FOR I:=1 TO Count-I DO + S[I]:=C; + S[0]:=CHR(Count); + END; +END; + +Var S : string; + +begin + s:='abcedfghij'; + writeln ('s : ',s); + lgrow (s,'1',17); + writeln ('S : ',s); + if s<>'1111111abcedfghij' then + begin + writeln('tbs0152 fails'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0132.pp b/tests/tbs/tb0132.pp new file mode 100644 index 0000000000..aa2ffefc87 --- /dev/null +++ b/tests/tbs/tb0132.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0154.pp } +{ Subrange types give type mismatch when assigning to OK 0.99.7 (PFV) } + +type + week=(mon,tue,wed); +Var + w : week; + w1 : mon..tue; +begin + w1:=w; +end. diff --git a/tests/tbs/tb0133.pp b/tests/tbs/tb0133.pp new file mode 100644 index 0000000000..2d4ba25d02 --- /dev/null +++ b/tests/tbs/tb0133.pp @@ -0,0 +1,7 @@ +{ Old file: tbs0156a.pp } +{ } + +uses ub0133; + +begin +end. diff --git a/tests/tbs/tb0134.pp b/tests/tbs/tb0134.pp new file mode 100644 index 0000000000..4e515b63da --- /dev/null +++ b/tests/tbs/tb0134.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0157.pp } +{ Invalid compilation and also crashes OK 0.99.7 (PFV) } + +{ this should be rejected because we only accept integer args } + +program write_it; +var x,y:real; +begin +x:=5.6; +y:=45.789; +write(y:2:3,x:3:4); +{write(y:3.2,x:5.2);} +end. diff --git a/tests/tbs/tb0135.pp b/tests/tbs/tb0135.pp new file mode 100644 index 0000000000..8e5ea00658 --- /dev/null +++ b/tests/tbs/tb0135.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0159.pp } +{ Invalid virtual functions - should compile OK 0.99.7 (FK) } + +Type TParent = Object + Procedure SomeProc; + end; + + TChild = Object(TParent) + Procedure SomeProc; virtual; + end; + + + Procedure TParent.someproc; + Begin + end; + + + procedure TChild.Someproc; + Begin + end; + + + +Begin +end. diff --git a/tests/tbs/tb0136.pp b/tests/tbs/tb0136.pp new file mode 100644 index 0000000000..3fb1df11b7 --- /dev/null +++ b/tests/tbs/tb0136.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0160.pp } +{ Incompatibility with BP: Self shouldn't be a reserved word. OK 0.99.9 (PM) } + +program xxxx; + +procedure yyyy; + +var self:word; + +begin +end; + +procedure self; + +begin +end; + +begin +end. diff --git a/tests/tbs/tb0137.pp b/tests/tbs/tb0137.pp new file mode 100644 index 0000000000..c33c5241ac --- /dev/null +++ b/tests/tbs/tb0137.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0162.pp } +{ continue in repeat ... until loop doesn't work correct OK 0.99.8 (PFV) } + +var + i : longint; + +begin + i:=1; + repeat + continue; + until i=1; +end. + diff --git a/tests/tbs/tb0138.pp b/tests/tbs/tb0138.pp new file mode 100644 index 0000000000..d7af769054 --- /dev/null +++ b/tests/tbs/tb0138.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0163.pp } +{ missing <= and >= operators for sets. OK 0.99.11 (JM) } + +Program test; + +{ shows missing <= and >= for sets } + +Type + Days = (Monday,tuesday,wednesday,thursday,friday,saturday,sunday); + +Var + FreeDays,Weekend : set of days; + +begin + Weekend := [saturday, sunday]; + FreeDays := [friday, saturday, sunday]; + If (Weekend <= Freedays) then + Writeln ('Free in weekend !'); +end. diff --git a/tests/tbs/tb0139.pp b/tests/tbs/tb0139.pp new file mode 100644 index 0000000000..ba566b88ba --- /dev/null +++ b/tests/tbs/tb0139.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0164.pp } +{ crash when using undeclared array index in with statement OK 0.99.8 (PFV) } + +type t1r = record + a, b: Byte; + end; + t2r = record + l1, l2: Array[1..4] Of t1r; + end; + + +Var r: t2r; + counter : byte; + +begin + counter:=2; + + with r.l1[counter] Do + Inc(a) +end. diff --git a/tests/tbs/tb0140.pp b/tests/tbs/tb0140.pp new file mode 100644 index 0000000000..d1d9651a56 --- /dev/null +++ b/tests/tbs/tb0140.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0165.pp } +{ missing range check code for enumerated types. OK 0.99.9 (PFV) } + +{$R+} +Program bug0165; + +uses + erroru; + +{ No range check when -Cr given} + +Type Directions = (North, East,South,West); + +Var Go : Directions; + + +begin + Require_Error(201); + Go:=North; + Go:=Pred(Go); { must give run-time error } +end. diff --git a/tests/tbs/tb0141.pp b/tests/tbs/tb0141.pp new file mode 100644 index 0000000000..5868ec2a6d --- /dev/null +++ b/tests/tbs/tb0141.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0169.pp } +{ missing new(type) support for not object/class OK 0.99.9 (PM) } + +type + psearchrec=^longint; + +Var Sr : PSearchrec; + +begin + Sr := New(PSearchRec); + Sr^ := 45; + if Sr^<>45 then + Halt(1); + Dispose(Sr); +end. diff --git a/tests/tbs/tb0142.pp b/tests/tbs/tb0142.pp new file mode 100644 index 0000000000..b09660a8fb --- /dev/null +++ b/tests/tbs/tb0142.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0170.pp } +{ Asm, {$ifdef} is seen as a separator OK 0.99.9 (PFV) } + +procedure free1; +begin +end; + +procedure free2; +begin +end; + +begin +asm +{$ifdef CPUI386} + call {$ifdef dummy}free1{$else}free2{$endif} +{$endif CPUI386} +{$ifdef CPU68K} + jsr {$ifdef dummy}free1{$else}free2{$endif} +{$endif CPU68K} +{$ifdef ARM} + bl {$ifdef dummy}free1{$else}free2{$endif} +{$endif ARM} +end; +end. diff --git a/tests/tbs/tb0143.pp b/tests/tbs/tb0143.pp new file mode 100644 index 0000000000..099a7ded30 --- /dev/null +++ b/tests/tbs/tb0143.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0171.pp } +{ missing typecasting in constant expression solved for pointers OK 0.99.11 (PM) } + +type + pstring=^string; +const + drivestr:string='c:'; + pdrivestr:pstring=pstring(@drivestr); +begin + if pdrivestr^<>'c:' then + begin + Writeln('Error in typecast of const'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0144.pp b/tests/tbs/tb0144.pp new file mode 100644 index 0000000000..e6d5216531 --- /dev/null +++ b/tests/tbs/tb0144.pp @@ -0,0 +1,25 @@ +{ %CPU=i386 } +{ Old file: tbs0174.pp } +{ Asm, offsets of fields are not possible yet OK 0.99.9 (PFV) } + +{$ASMMODE ATT} + +type + tobj=object + l : longint; + end; +var + t : tobj; + +procedure kl;assembler; +asm +{$ifdef CPUI386} + movl tobj.l,%eax // tobj.l should return the offset of l in tobj +{$endif CPUI386} +end; + + +begin +end. + + diff --git a/tests/tbs/tb0145.pp b/tests/tbs/tb0145.pp new file mode 100644 index 0000000000..b6d12ff030 --- /dev/null +++ b/tests/tbs/tb0145.pp @@ -0,0 +1,14 @@ +{ %CPU=i386 } +{ Old file: tbs0175.pp } +{ Asm, mov word,%eax should not be allowed without casting emits a warning (or error with range checking enabled) OK 0.99.11 (PM) } + +{ this will just give out a warning } +{$asmmode att} +{$R-} +var + w : word; +begin + asm + movl w,%ecx + end; +end. diff --git a/tests/tbs/tb0146.pp b/tests/tbs/tb0146.pp new file mode 100644 index 0000000000..f1401de454 --- /dev/null +++ b/tests/tbs/tb0146.pp @@ -0,0 +1,21 @@ +{ %OPT= -Un } + +{ Old file: tbs0176.pp } +{ unit.symbol not allowed for implementation vars OK 0.99.9 (PM) } + +{ no unit name checking !! } +unit tb150_wrong; +interface + +var + l1 : longint; + +implementation + +var + l2 : longint; + +begin + tb150_wrong.l1:=1; + tb150_wrong.l2:=1; +end. diff --git a/tests/tbs/tb0147.pp b/tests/tbs/tb0147.pp new file mode 100644 index 0000000000..01a530dd72 --- /dev/null +++ b/tests/tbs/tb0147.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0177.pp } +{ program.symbol not allowed (almost the same as bugs 176) OK 0.99.9 (PM) } + +program p; +var + l : longint; +begin + p.l:=1; +end. diff --git a/tests/tbs/tb0148.pp b/tests/tbs/tb0148.pp new file mode 100644 index 0000000000..a103fec7ac --- /dev/null +++ b/tests/tbs/tb0148.pp @@ -0,0 +1,68 @@ +{ %OPT=-Sg } + +{ Old file: tbs0178.pp } +{ problems with undefined labels and fail outside constructor OK 0.99.9 (PM) } + +PROGRAM NoLabel; { this program compiles fine with TP but not with FP } + + type + ptestobj = ^ttestobj; + ttestobj = object + constructor init; + procedure test_self; + end; + + const + allowed : boolean = false; + + constructor ttestobj.init; + begin + if not allowed then + fail; + end; + procedure ttestobj.test_self; + function myself : ptestobj; + begin + myself:=@self; + end; + + begin + if myself<>@self then + begin + Writeln('problem with self'); + Halt(1); + end; + end; + + +LABEL + N1, + N2, + FAIL, { this is a reserved word in constructors only! - FP fails here +} + More; { label not defined - FP fails, but a warning is enough for that +} + { since label referenced nowhere } + var ptest : ptestobj; + self : longint; +BEGIN + new(ptest,init); + if ptest<>nil then + begin + Writeln('Fail does not work !!'); + Halt(1); + end; + allowed:=true; + new(ptest,init); + if ptest=nil then + begin + Writeln('Constructor does not work !!'); + Halt(1); + end + else + ptest^.test_self; + N1: Write; + N2: Write; + FAIL: Write; + self:=1; +END. diff --git a/tests/tbs/tb0149.pp b/tests/tbs/tb0149.pp new file mode 100644 index 0000000000..ac11769b05 --- /dev/null +++ b/tests/tbs/tb0149.pp @@ -0,0 +1,14 @@ +{ %OPT= -So } + +{ Old file: tbs0179.pp } +{ show a problem for -So mode OK 0.99.9 (PM) } + +UNIT tb0149; +INTERFACE + PROCEDURE A(B:WORD); +IMPLEMENTATION + PROCEDURE A; { <-- works with TP, FP says overloading problem } + BEGIN + Write(B); + END; +END. diff --git a/tests/tbs/tb0150.pp b/tests/tbs/tb0150.pp new file mode 100644 index 0000000000..d07202c1fa --- /dev/null +++ b/tests/tbs/tb0150.pp @@ -0,0 +1,20 @@ +{ %OPT=-Un } +{ %RECOMPILE } + +{ Old file: tbs0180.pp } +{ problem for units with names different from file name should be accepted with -Un !! Solved, but you still need to use the file name from other units OK 0.99.9 (PM) } + +{ this name should be accepted with -Un option !! } +UNIT tb154_wrong; +INTERFACE + uses + ub0150; + + procedure dummy; +IMPLEMENTATION + procedure dummy; + begin + { Unit_with_strange_name.dummy; should this work ?? } + ub0150.dummy; + end; +END. diff --git a/tests/tbs/tb0151.pp b/tests/tbs/tb0151.pp new file mode 100644 index 0000000000..4d8c45dbfb --- /dev/null +++ b/tests/tbs/tb0151.pp @@ -0,0 +1,19 @@ + +{$ifdef fpc}{$mode tp}{$endif} + +{$ifdef ENDIAN_BIG} +var + i : longint; + j : word; +begin + j:=5; + i:=-1; + byte(i):=j; + writeln('i: ',i,' (should be -251)'); + if i<>-251 then + halt(1); +end. +{$else} +begin +end. +{$endif} diff --git a/tests/tbs/tb0152.pp b/tests/tbs/tb0152.pp new file mode 100644 index 0000000000..7bf7efda13 --- /dev/null +++ b/tests/tbs/tb0152.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0182.pp } +{ @record.field doesn't work in constant expr OK 0.99.9 (PM) } + +TYPE Rec = RECORD + x:WORD; + y:WORD; + END; + + Rec1 = Record + x,y : longint; + end; + Rec2 = Record + r,s : Rec1; + z : word; + end; + plongint = ^longint; + +VAR s:WORD; + r:Rec; + rr : Rec2; + +CONST p1:POINTER = @s; { Works fine } + p2:POINTER = @R.y; { illegal expression } + p3:pointer = @rr.s.y; + p4:plongint = @rr.s.y; +BEGIN + rr.s.y:=15; + if plongint(p3)^<>15 then + Begin + Writeln('Error : wrong code generated'); + Halt(1); + End; +END. + diff --git a/tests/tbs/tb0153.pp b/tests/tbs/tb0153.pp new file mode 100644 index 0000000000..9eec5768e2 --- /dev/null +++ b/tests/tbs/tb0153.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0183.pp } +{ internal error 10 in secondnot OK 0.99.11 (PM) } + +program Internal_Error_10; + +type + PBug = ^TBug; + TBug = array[1..1] of boolean; + +var + Left : PBug; + test : longint; + +begin + New(left); + test := 1; + +{ following shows internal error 10 only if the + + array index is a var on both sides + ( if either is a constant then it compiles fine, error only occurs if the + not is in the statement ) + bug only appears if the array is referred to using a pointer - + if using TBug, and no pointers it compiles fine + with PBug the error appears + } + + Left^[test] := not Left^[test]; +end. + diff --git a/tests/tbs/tb0154.pp b/tests/tbs/tb0154.pp new file mode 100644 index 0000000000..c1dac73c7d --- /dev/null +++ b/tests/tbs/tb0154.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0184.pp } +{ multiple copies of the same constant set are stored in executable OK 0.99.9 (PFV) } + +Program Bug0184; + +{ multiple copies of the constant sets are stored in the assembler file when + they are needed more than once} + +Var BSet: Set of Byte; + SSet: Set of 0..31; + b,c: byte; + s: 0..31; + +Begin + BSet := BSet + [b]; {creates a big, empty set} + BSet := BSet + [c]; {creates another one} + BSet := BSet + [3]; {creates a big set with element three set} + BSet := BSet + [3]; {and antoher one} + + SSet := SSet + [5]; {creates a small set containing 5} + SSet := SSet + [s]; {creates a small, empty set} + SSet := SSet + [5]; {creates another small set containing 5} + SSet := SSet + [s]; {creates another small, empty set} + +{BTW: small constant sets don't have to be stored seperately in the + executable, as they're simple 32 bit constants, like longints!} + +End. diff --git a/tests/tbs/tb0155.pp b/tests/tbs/tb0155.pp new file mode 100644 index 0000000000..bf6c869ec4 --- /dev/null +++ b/tests/tbs/tb0155.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0181.pp } +{ shows a problem with name mangling OK 0.99.9 (PM) } + +{ shows a problem of name mangling } +Program tb0155; + + Uses ub0155; + + var l : mylongint; +begin + dummy(l); +end. diff --git a/tests/tbs/tb0156.pp b/tests/tbs/tb0156.pp new file mode 100644 index 0000000000..f8a11f14e1 --- /dev/null +++ b/tests/tbs/tb0156.pp @@ -0,0 +1,116 @@ +{ %OPT=-St -Cr } + +{ Old file: tbs0187.pp } +{ constructor in a WIth statement isn't called correct. (works at lest in the case stated) OK 0.99.11 (PM) } + +{$static on} + +type + Tbaseclass = object + base_arg : longint; + st_count : longint;static; + constructor Init; + destructor Done; + procedure Run; virtual; + + end; + Totherclass = object(Tbaseclass) + other_arg : longint; + procedure Run; virtual; + + end; + +const + BaseRunCount : integer = 0; + OtherRunCount : integer = 0; + +constructor Tbaseclass.Init; + +begin + writeln('Init'); + Inc(st_count); + Run; +end; + +destructor Tbaseclass.Done; + +begin + writeln('Done'); + dec(st_count); +end; + +procedure Tbaseclass.Run; + +begin + writeln('Base method'); + inc(BaseRunCount); +end; + + +procedure Totherclass.Run; + +begin + writeln('Inherited method'); + inc(OtherRunCount); +end; + + { try this as local vars } + + procedure test_local_class_init; + var base1 : TbaseClass; + var other1 : TOtherClass; + begin + with other1 do + Init; + with base1 do + Init; + with other1 do + begin + Writeln('number of objects = ',st_count); + base_arg:=2; + other_arg:=6; + Run; + end; + { test if changed !! } + + if (other1.base_arg<>2) or (other1.other_arg<>6) then + Halt(1); + + with base1 do + begin + Run; + Done; + end; + other1.done; + end; + +var base : Tbaseclass; + other : Totherclass; + testfield : longint; + +begin +// Uncommenting here and commenting the init in the WIth solves it. +// Base.Init; + with base do + begin + Init; + Run; + Done; + end; +// Uncommenting here and commenting the init in the WIth solves it. +// Other.init; + with other do + begin + Init; + Run; + Done; + end; + + test_local_class_init; +{ Calls Tbaseclass.Run when it should call Totherclass.Run } + If (BaseRunCount<>4) or (OtherRunCount<>4) then + Begin + Writeln('Error in tb162'); + Halt(1); + End; +end. diff --git a/tests/tbs/tb0157.pp b/tests/tbs/tb0157.pp new file mode 100644 index 0000000000..897b3d30e4 --- /dev/null +++ b/tests/tbs/tb0157.pp @@ -0,0 +1,45 @@ +{ Old file: tbs0188.pp } +{ can't print function result of procedural var that returns a function. Not a bugs : wrong syntax !! See source (PM) } + +{ this are no bugs, just wrong + understanding of FPC syntax } + +type testfunc = function:longint; + +var f : testfunc; + +var test: testfunc; + +function test_temp: longint; +begin + test_temp:=12; +end; + +procedure sound(test: testfunc); +begin + {writeln(test); this is wrong because + test is the function itself and write does not know how to + output a function ! + to call test you must use test() !! } + writeln(test()); +end; { proc. sound } + +var i : longint; +begin + i:=test_temp; + f:=@test_temp; + if f()<>i then + begin + Writeln('error calling f'); + Halt(1); + end; + + { this works for FPC + sound(test_temp); + but the correct syntax would be } + sound(@test_temp); + { imagine if a function would return its own type !! } + + { for f var this is correct also ! } + sound(f); +end. diff --git a/tests/tbs/tb0158.pp b/tests/tbs/tb0158.pp new file mode 100644 index 0000000000..5864fe61d0 --- /dev/null +++ b/tests/tbs/tb0158.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0189.pp } +{ cant compare adresses of function variables !! As tbs0188 FPC syntax problem see source (PM) } + +var m: procedure; + +procedure test; +begin +end; + +procedure test2; +begin +end; + +begin + if @test <> @test2 then + writeln('different!') + else + writeln('error'); + m:=@test; + + { here also the syntax was wrong !! } + { @m <> @test have different types !! } + if m <> @test then + writeln('error'); +end. diff --git a/tests/tbs/tb0159.pp b/tests/tbs/tb0159.pp new file mode 100644 index 0000000000..b021cbfa02 --- /dev/null +++ b/tests/tbs/tb0159.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0190.pp } +{ can't have typecast for var params ?? OK 0.99.11 (PM) } + +procedure a(var b: boolean); +begin + b:=true; +end; + +var C: byte; + +begin + a(boolean(c)); +end. diff --git a/tests/tbs/tb0160.pp b/tests/tbs/tb0160.pp new file mode 100644 index 0000000000..0c17f0c862 --- /dev/null +++ b/tests/tbs/tb0160.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0191.pp } +{ missing vecn constant evaluation OK 0.99.11 (PM) } + +type + trec=record + a,b : longint; + end; + prec=^trec; + +const + s : string = 'test'; + + cfg : array[1..2] of trec=( + (a:1;b:2), + (a:3;b:4) + ); + pcfg : prec = @cfg[2]; + + l : ^longint = @cfg[1].b; { l^ should be 2 } + + pc : pchar = @s[1]; + +begin + Writeln(' l^ = ',l^); + Writeln('pc[0] = ',pc[0]); + if (l^<>2) or (pc[0]<>'t') then + Begin + Writeln('Wrong code generated'); + RunError(1); + End; +end. diff --git a/tests/tbs/tb0161.pp b/tests/tbs/tb0161.pp new file mode 100644 index 0000000000..e049891309 --- /dev/null +++ b/tests/tbs/tb0161.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0192.pp } +{ can't compare boolean result with true/false, because the boolean result is already in the flags OK 0.99.11 (PFV) } + +var + k,l : word; +begin + if (k<>l)=false then + ; + if (k<>l)=true then + ; +end. diff --git a/tests/tbs/tb0162.pp b/tests/tbs/tb0162.pp new file mode 100644 index 0000000000..645c680526 --- /dev/null +++ b/tests/tbs/tb0162.pp @@ -0,0 +1,232 @@ +{ Old file: tbs0193.pp } +{ overflow checking for 8 and 16 bit operations wrong } + +{$mode objfpc} + +uses sysutils; + +procedure doerror(l: longint); +begin + writeln('error near ',l); + halt(1); +end; + +{$R-} +{$Q+} +var i: integer; + b: byte; + l: longint; + c: cardinal; + n: int64; + q: qword; +begin + i := 32767; + i := i + 15; + b := 255; + b := b + 18; + b := 255; + b := b * 8; + b := 255; + b := b * 17; + +{ 64 bit cpus do all calculations in 64 bit so longint and cardinal can't overflow } +{$ifndef CPU64} + l := high(longint); + try + l := l+1; + doerror(1); + except + on eintoverflow do + ; + else + doerror(2); + end; + + l := low(longint); + try + l := l-1; + doerror(3); + except + on eintoverflow do + ; + else + doerror(4); + end; + + l := low(longint); + try + l := l*2; + doerror(5); + except + on eintoverflow do + ; + else + doerror(6); + end; + + l := high(longint) div 2; + try + l := l*3; + doerror(7); + except + on eintoverflow do + ; + else + doerror(8); + end; + + + c := 0; + try + c := c-1; + doerror(9); + except + on eintoverflow do + ; + else + doerror(10); + end; + + + c := high(cardinal); + try + c := c+1; + doerror(11); + except + on eintoverflow do + ; + else + doerror(12); + end; + + c := high(cardinal) div 2; + try + c := c*3; + doerror(13); + except + on eintoverflow do + ; + else + doerror(14); + end; + + c := high(cardinal); + try + c := c*high(cardinal); + doerror(15); + except + on eintoverflow do + ; + else + doerror(16); + end; + +{$endif CPU64} + +{$ifdef fpc} +{$ifndef ver1_0} + + n := high(int64); + try + n := n+1; + doerror(17); + except + on eintoverflow do + ; + else + doerror(18); + end; + + n := low(int64); + try + n := n-1; + doerror(19); + except + on eintoverflow do + ; + else + doerror(20); + end; + + n := 0; + try + n := n-1; + except + on eintoverflow do + doerror(39); + end; + + + n := low(int64); + try + n := n*2; + doerror(21); + except + on eintoverflow do + ; + else + doerror(22); + end; + + n := high(int64) div 2; + try + n := n*3; + doerror(23); + except + on eintoverflow do + ; + else + doerror(24); + end; + + + q := 0; + try + q := q-1; + doerror(25); + except + on eintoverflow do + ; + else + doerror(26); + end; + + + q := qword(high(qword)); + try + q := q+1; + doerror(27); + except + on eintoverflow do + ; + else + doerror(28); + end; + + q := qword(high(qword)) div qword(2); + try + q := q*qword(3); + doerror(29); + except + on eintoverflow do + ; + else + doerror(30); + end; + + q := high(qword); + try + q := q*high(qword); + doerror(31); + except + on eintoverflow do + ; + else + doerror(32); + end; + +{$endif ver1_0} +{$endif fpc} + +End. + diff --git a/tests/tbs/tb0163.pp b/tests/tbs/tb0163.pp new file mode 100644 index 0000000000..735a58584a --- /dev/null +++ b/tests/tbs/tb0163.pp @@ -0,0 +1,45 @@ +{ Old file: tbs0194.pp } +{ @procedure var returns value in it instead of address !! OK 0.99.11 (PM) } + +{$Q+} + +type + tproc = function : longint; + +var + f : tproc; + fa : array [0..1] of tproc; + + function dummy : longint; + begin + dummy:=25; + end; +const + prog_has_errors : boolean = false; + + procedure Wrong(const s : string); + begin + writeln(s); + prog_has_errors:=True; + end; + +Begin + f:=@dummy; + if f()<>25 then + Wrong('f() does not call dummy !!'); + if pointer(@f)=pointer(@dummy) then + Wrong('@f returns value of f !'); + if longint(f)=longint(@f) then + Wrong('longint(@f)=longint(f) !!!!'); + if f<>@dummy then + Wrong('f does not return the address of dummy'); + if longint(@f)=longint(@dummy) then + Wrong('longint(@f) returns address of dummy instead of address of f'); + fa[0]:=@dummy; + if longint(@f)=longint(@fa[0]) then + Wrong('arrays of procvar also wrong'); + if longint(f)<>longint(fa[0]) then + Wrong('arrays of procvar and procvars are handled differently !!'); + if prog_has_errors then + Halt(1); +End. diff --git a/tests/tbs/tb0164.pp b/tests/tbs/tb0164.pp new file mode 100644 index 0000000000..ea1e754d08 --- /dev/null +++ b/tests/tbs/tb0164.pp @@ -0,0 +1,33 @@ +{ %GRAPH } +{ %TARGET=go32v2,win32,linux } + +{ Old file: tbs0195.pp } +{ Problem with Getimage, crash of DOS box, even with dpmiexcp!! (PFV) Not a bugs, you must use p^. } + +uses graph; +var + GDriver, GMode: Integer; + w:word; + p:pointer; +begin + GDriver := $FF; + GMode := $101; + InitGraph(GDriver, GMode, ''); + if (GraphResult <> grOK) then + Halt(0); + rectangle(0,0,getmaxx,getmaxy); + w := imagesize(0,0,111,111); + getmem(p, w); + + {---runtime-error!------} + { getimage(0,0,111,111, p); } + {-----------------------} + + { This is the correct usage (PFV) } + getimage(0,0,111,111, p^); + + + freemem(p, w); + closegraph; + readln; +end. diff --git a/tests/tbs/tb0165.pp b/tests/tbs/tb0165.pp new file mode 100644 index 0000000000..ab9b1d56ff --- /dev/null +++ b/tests/tbs/tb0165.pp @@ -0,0 +1,17 @@ +{ %OPT= -So } + +{ Old file: tbs0196.pp } +{ "function a;" is accepted (should require result type) OK 0.99.1 (PM) } + +Unit tb0165; +interface + + function a : integer; + +implementation + function a; +begin + a:=1; +end; + +end. diff --git a/tests/tbs/tb0166.pp b/tests/tbs/tb0166.pp new file mode 100644 index 0000000000..2b41614663 --- /dev/null +++ b/tests/tbs/tb0166.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0198.pp } +{ calling specifications aren't allowed in class declarations, this should be allowed OK 0.99.11 (PM) } + +{$mode objfpc} +type + to1 = class + function GetCaps1 : Longint;virtual;abstract; + function GetCaps2 : Longint;virtual;stdcall; + function GetCaps : Longint;virtual;stdcall;abstract; + end; + +function to1.GetCaps2 : Longint;stdcall; +begin +end; + +begin +end. diff --git a/tests/tbs/tb0167.pp b/tests/tbs/tb0167.pp new file mode 100644 index 0000000000..7b33ccc2b2 --- /dev/null +++ b/tests/tbs/tb0167.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0199.pp } +{ bugs in mul code OK 0.99.11 (FK) } + +PROGRAM PRTest; + +TYPE + ptRec = ^tRec; + tRec = Record + D : DWORD; + END; + +VAR + pR1, pR2 : ptRec; +BEGIN + GetMem(pR1, SizeOf(tRec)); + GetMem(pR2, SizeOf(tRec)); + + pR1^.D := 10; + Move(pR1^,pR2^,SizeOf(tRec)); + WriteLn(pR1^.D:16,pR2^.D:16); + + pR1^.D := 1; + pR2^.D := pR1^.D*2; { THE BUG IS HERE } + WriteLn(pR1^.D:16,pR2^.D:16); + if (pR1^.D<>1) or (pR2^.D<>2) then + Halt(1); +END. diff --git a/tests/tbs/tb0168.pp b/tests/tbs/tb0168.pp new file mode 100644 index 0000000000..bc25e5a52a --- /dev/null +++ b/tests/tbs/tb0168.pp @@ -0,0 +1,45 @@ +{ %CPU=i386 } +{ %OPT= -Ratt } + +{ Old file: tbs0201.pp } +{ problem with record var-parameters and assembler OK 0.99.11 (PFV) } + +program bug0201; + +type rec = record + a : DWord; + b : Word; + end; + +{ this is really for tests but + this should be coded with const r1 and r2 !! } + +function x(r1 : rec; r2 : rec; var r3 : rec) : integer; assembler; {$ifndef ver1_0}oldfpccall;{$endif} +asm + movl r3, %edi + movl r1, %ebx + movl r2, %ecx + movl rec.a(%ebx), %eax + addl rec.a(%ecx), %eax + movl %eax, rec.a(%edi) + + movw rec.b(%ebx), %ax + addw rec.b(%ecx), %ax + movw %ax, rec.b(%edi) + movw $1,%ax +end; + +var r1, r2, r3 : rec; + +begin + r1.a := 100; r1.b := 200; + r2.a := 300; r2.b := 400; + x(r1, r2, r3); + Writeln(r3.a, ' ', r3.b); + if (r3.a<>400) or (r3.b<>600) then + begin + Writeln('Error in assembler code'); + Halt(1); + end; +end. + diff --git a/tests/tbs/tb0169.pp b/tests/tbs/tb0169.pp new file mode 100644 index 0000000000..539bb96dd7 --- /dev/null +++ b/tests/tbs/tb0169.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0202.pp } +{ flag results not supported with case OK 0.99.11 (PFV) } + +program silly; + +var greater : boolean; + +procedure error; +begin + Writeln('Error in tbs0202'); + Halt(1); +end; + +procedure compare(i,j : integer); +begin + case (i>j) of + true : begin + greater:=true; + end; + false : begin + greater:=false; + end; + end; +end; + +begin + compare(45,2); + if not greater then + error; + compare(-5,26); + if greater then + error; +end. + diff --git a/tests/tbs/tb0170.pp b/tests/tbs/tb0170.pp new file mode 100644 index 0000000000..e2bb4443db --- /dev/null +++ b/tests/tbs/tb0170.pp @@ -0,0 +1,13 @@ +{ %version=1.1 } + +{ Old file: tbs0203.pp } +{ problem with changed mangledname of procedures after use } + +uses + ub0170; + +begin + c; + a; +end. + diff --git a/tests/tbs/tb0172.pp b/tests/tbs/tb0172.pp new file mode 100644 index 0000000000..4fa633bb8c --- /dev/null +++ b/tests/tbs/tb0172.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0204.pp } +{ can typecast the result var in an assignment OK 0.99.11 (PM) } + +{ boolean(byte) byte(boolean) + word(wordbool) wordbool(word) + longint(longbool) and longbool(longint) + must be accepted as var parameters + or a left of an assignment } + +procedure error; +begin + Writeln('Error in tbs0204'); + Halt(1); +end; + +var + b : boolean; + wb : wordbool; + lb : longbool; + +begin + byte(b):=1; + word(wb):=1; + longint(lb):=1; + if (not b) or (not wb) or (not lb) then + error; + byte(b):=2; + Writeln('if a boolean contains 2 it is considered as ',b); + byte(b):=3; + Writeln('if a boolean contains 3 it is considered as ',b); + shortint(b):=-1; + Writeln('if a boolean contains shortint(-1) it is considered as ',b); +end. diff --git a/tests/tbs/tb0173.pp b/tests/tbs/tb0173.pp new file mode 100644 index 0000000000..57a0fee2b1 --- /dev/null +++ b/tests/tbs/tb0173.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0206.pp } +{ sets with variable ranges doesn't work OK 0.99.11 (PFV) } + +PROGRAM SetRange_Bug; +CONST a:char='A';z:char='Z'; +VAR s:set of char;c:char; +BEGIN + s:=[a..z]; + for c:=#0 to #255 do + if c in s then + write(c); + writeln; +END. diff --git a/tests/tbs/tb0174.pp b/tests/tbs/tb0174.pp new file mode 100644 index 0000000000..ea3d11a897 --- /dev/null +++ b/tests/tbs/tb0174.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0207.pp } +{ a class destructor doesn't release the memory OK 0.99.11 (FK) } + + +{$mode delphi} + var i : longint; + +begin + for i:=1 to 100 do + tobject.create.free; +end. diff --git a/tests/tbs/tb0175.pp b/tests/tbs/tb0175.pp new file mode 100644 index 0000000000..1c195762b2 --- /dev/null +++ b/tests/tbs/tb0175.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0209.pp } +{ problem with boolean expressions of different store sizes } + +program bug0209; + +{ problem with boolean expression mixing different boolean sizes } + +var + b : boolean; + wb : wordbool; + lb : longbool; +begin + b:=true; + wb:=true; + lb:=true; + if (not b) or (not wb) or (not lb) then + begin + Writeln('Error with boolean expressions of different sizes'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0176.pp b/tests/tbs/tb0176.pp new file mode 100644 index 0000000000..81dd8f7049 --- /dev/null +++ b/tests/tbs/tb0176.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0210.pp } +{ fillchar should accept boolean value also !! OK 0.99.11 (PM) } + +{ boolean args are accepted for fillchar in BP } + +program test; + + var l : array[1..10] of boolean; + +begin + fillchar(l,sizeof(l),true); +end. + diff --git a/tests/tbs/tb0177.pp b/tests/tbs/tb0177.pp new file mode 100644 index 0000000000..d90496e45e --- /dev/null +++ b/tests/tbs/tb0177.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0211.pp } +{ a and not a is true !!! (if a:=boolean(5)) OK 0.99.11 (PM) } + +var + a,b : boolean; + c : byte; + i : longint; + +procedure Error; +begin + Writeln('Error in bug0211'); + Halt(1); +end; + +begin + c:=5; + a:=boolean(c); + if a and not a then + Begin + Writeln('FPC is crazy !!'); + Error; + End; + i:=256; + a:=boolean(i); + { the value here is less trivial } + { BP returns false here !! } + { the problem is the converting wordbool to boolean } + { if wordbool is 256 should not convert true to false !! } + + Writeln('boolean(256) =',a); +end. + diff --git a/tests/tbs/tb0178.pp b/tests/tbs/tb0178.pp new file mode 100644 index 0000000000..4a2785be4d --- /dev/null +++ b/tests/tbs/tb0178.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0212.pp } +{ problem with properties OK 0.99.11 (PFV) } + +program proptest; + +{$mode objfpc} + +type + TMyRec = record + Int: Integer; + Str: String; + end; + + TMyClass = class + private + FMyRec: TMyRec; + public + property AnInt: Integer read FMyRec.Int; + property AStr: String read FMyRec.Str; + end; + +begin +end. diff --git a/tests/tbs/tb0179.pp b/tests/tbs/tb0179.pp new file mode 100644 index 0000000000..edb3056458 --- /dev/null +++ b/tests/tbs/tb0179.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0213.pp } +{ name mangling problem with nested procedures in overloaded } + +uses + ub0179; + +PROCEDURE Testsomething(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +VAR O : LONGINT; + O2 : WORD; + +BEGIN + TestSomething(O); + TestSomething(O2); +END. + diff --git a/tests/tbs/tb0181.pp b/tests/tbs/tb0181.pp new file mode 100644 index 0000000000..561d9da526 --- /dev/null +++ b/tests/tbs/tb0181.pp @@ -0,0 +1,32 @@ +{ %OPT=-St } + +{ Old file: tbs0214.pp } +{ bugs for static methods OK 0.99.11 (PM) } + +Program SttcTest; +{ Note: I've cut a lot out of this program, it did originally have + constructors, destructors and instanced objects, but this + is the minimum required to produce the problem, and I think + that this should work, unless I've misunderstood the use of + the static keyword. } +Type + TObjectType1 = Object + Procedure Setup; static; + Procedure Weird; static; + End; + +Procedure TObjectType1.Setup; + Begin + End; + +Procedure TObjectType1.Weird; + Begin + End; + +Begin + TObjectType1.Setup; + TObjectType1.Weird; + TObjectType1.Weird; // GPFs before exiting "Weird" + Writeln('THE END.'); +End. + diff --git a/tests/tbs/tb0182.pp b/tests/tbs/tb0182.pp new file mode 100644 index 0000000000..86b06993ce --- /dev/null +++ b/tests/tbs/tb0182.pp @@ -0,0 +1,52 @@ +{ %OPT=-St } + +{ Old file: tbs0215.pp } +{ more bugss with static methods OK 0.99.11 (PM) } + +{ allow static keyword } +{ submitted by Andrew Wilson } + +Program X; + +Type + PY=^Y; + Y=Object + A : LongInt; + P : PY; static; + Constructor Init(NewA:LongInt); + Procedure StaticMethod; static; + Procedure VirtualMethod; virtual; + End; + +Constructor Y.Init(NewA:LongInt); + Begin + A:=NewA; + P:=@self; + End; + +Procedure Y.StaticMethod; + Begin + Writeln(P^.A); // Compiler complains about using A. + P^.VirtualMethod; // Same with the virtual method. + With P^ do begin + Writeln(A); // These two seem to compile, but I + VirtualMethod; // can't get them to work. It seems to + End; // be the same problem as last time, so + End; // I'll check it again when I get the + // new snapshot. +Procedure Y.VirtualMethod; + Begin + Writeln('VirtualMethod ',A); + End; + +var T1,T2 : PY; + +Begin + New(T1,init(1)); + New(T2,init(2)); + T1^.VirtualMethod; + T2^.VirtualMethod; + Y.StaticMethod; + T1^.StaticMethod; + T2^.StaticMethod; +End. diff --git a/tests/tbs/tb0183.pp b/tests/tbs/tb0183.pp new file mode 100644 index 0000000000..ca945ad4b0 --- /dev/null +++ b/tests/tbs/tb0183.pp @@ -0,0 +1,37 @@ +{ Old file: tbs0216.pp } +{ problem with with fields as function args OK 0.99.11 (PM) } + +type rec = record + a : Longint; + b : Longint; + c : Longint; + d : record + e : Longint; + f : Word; + end; + g : Longint; + end; + +const r : rec = ( + a : 100; b : 200; c : 300; d : (e : 20; f : 30); g : 10); + + +begin + with r do begin + Writeln('A : ', a); + if a<>100 then halt(1); + Writeln('B : ', b); + if b<>200 then halt(1); + Writeln('C : ', c); + if c<>300 then halt(1); + Writeln('D'); + with d do begin + Writeln('E : ', e); + if e<>20 then halt(1); + Writeln('F : ', f); + if f<>30 then halt(1); + end; + Writeln('G : ', g); + if g<>10 then halt(1); + end; +end. diff --git a/tests/tbs/tb0184.pp b/tests/tbs/tb0184.pp new file mode 100644 index 0000000000..1bdee473be --- /dev/null +++ b/tests/tbs/tb0184.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0217.pp } +{ in tp mode can't use the procvar in writeln OK 0.99.11 (PFV) } + +{$ifdef fpc}{$mode tp}{$endif} + +type tmpproc=function:longint; + +function a:longint;{$ifndef fpc}far;{$endif} +begin + a:=-1; +end; + +procedure tmp(aa: tmpproc); +begin + writeln(aa); { "Cannot read/write variables of this type", TP kan dit +wel? } + if aa<>-1 then halt(1); +end; + +begin + tmp(a); { de TP manier , in FPC moet dit zijn tmp(@a); } +end. diff --git a/tests/tbs/tb0185.pp b/tests/tbs/tb0185.pp new file mode 100644 index 0000000000..1d4463cc86 --- /dev/null +++ b/tests/tbs/tb0185.pp @@ -0,0 +1,49 @@ +{ Old file: tbs0218.pp } +{ rounding errors with write/str (the bugs is fixed, OK 0.99.11 (FK) } + +Program Wrong_Output; +{} +Var r,rr,error:Extended; + s:String; + code : word; +{} +Begin + Writeln('Size of Extended type (r)=',SizeOf(r),' bytes'); + r:=0.000058184639; + Writeln('r=',r); + Writeln('r=',r:16:13); + Writeln('r=',r:15:12); + Writeln('r=',r:14:11); + Writeln('r=',r:13:10); + Writeln('r=',r:12:9); + Writeln('r=',r:11:8); + Writeln('r=',r:10:7); + Writeln('r=',r:9:6); + Writeln('r=',r:8:5); + Writeln('r=',r:7:4); + Str(r,s); + Writeln('r=',s,' (as string)'); + str(r,s); + val(s,rr,code); + { calculate maximum possible precision } + if sizeof(extended) = 12 then + error := exp(17*ln(10)) + else if sizeof(extended) = 10 then + error := exp(17*ln(10)) + else if sizeof(extended) = 8 then + error := exp(14*ln(10)) + else if sizeof(extended) = 4 then + { the net may have to be 9 instead of 8, not sure } + error := exp(8*ln(10)) + else + begin + Writeln('unknown extended type size!'); + halt(1) + end; + if abs(r-rr) > error then + begin + Writeln('r=',r); + Writeln('is different from rr=',rr); + halt(1); + end; +End. diff --git a/tests/tbs/tb0186.pp b/tests/tbs/tb0186.pp new file mode 100644 index 0000000000..09443a738f --- /dev/null +++ b/tests/tbs/tb0186.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0220.pp } +{ array of char overloading problem with strings OK 0.99.11 (PFV) } + +type + a = array[1..100] of char; + +var + a1 : a; + s : string; +begin + a1[1]:='1';a1[2]:='2';a1[3]:='3'; + a1[4]:='4';a1[5]:='5';a1[6]:='6'; + a1[7]:='7';a1[8]:='8';a1[9]:='9'; + a1[10]:='0';a1[11]:='1'; + s:=Copy(a1,1,10); + if s<>'1234567890' then halt(1); + writeln('ok'); +end. diff --git a/tests/tbs/tb0187.pp b/tests/tbs/tb0187.pp new file mode 100644 index 0000000000..a1552baec4 --- /dev/null +++ b/tests/tbs/tb0187.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0221.pp } +{ syntax parsing incompatibilities with tp7 OK 0.99.11 (PFV) } + + +var + r : double; + c : char; +begin + r:=1.; + c:=^.; { this compile in tp7, c should contain 'n'/#110 } + if c<>#110 then + begin + Writeln('FPC does not support ^. character!'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0188.pp b/tests/tbs/tb0188.pp new file mode 100644 index 0000000000..2f393c75f8 --- /dev/null +++ b/tests/tbs/tb0188.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0222.pp } +{ an record field can't be the counter index (compiles with TP) OK 0.99.11 (PFV) } + +{$mode tp} + +type TStruct = record + x,y: Integer; + end; + +var i: TStruct; + +begin + for i.x:=1 to 10 do + writeln(i.x); +end. diff --git a/tests/tbs/tb0189.pp b/tests/tbs/tb0189.pp new file mode 100644 index 0000000000..cbf2a67c43 --- /dev/null +++ b/tests/tbs/tb0189.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0223.pp } +{ wrong boolean evaluation in writeln OK 0.99.11 (PFV) } + + +uses + erroru; + +var a:string; + +begin + writeln('B:'='B:'); { debbuger evaluates this to FALSE } + if 'B:'='B:' then + writeln('OK') + else + error; + a:='A:'; + inc(a[1]); + writeln(a='B:'); { TRUE } + if a='B:' then + writeln('OK') + else + error; +end. diff --git a/tests/tbs/tb0190.pp b/tests/tbs/tb0190.pp new file mode 100644 index 0000000000..b1ff90ae01 --- /dev/null +++ b/tests/tbs/tb0190.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0224.pp } +{ I/O-Error generation in readln can't be switched off OK 0.99.11 (PFV) } + + +var f:text; + i:integer; +begin + assign(f,'bug0224.txt'); + rewrite(f); + write(f,' '); + reset(f); +{$I-} + readln(f,i); { you can't avoid run-time error generation } +{$I+} + if IOResult<>0 then + writeln('error...'); +{$I-} + close(f); + erase(f); +{$I+} + if IOResult<>0 then; +end. diff --git a/tests/tbs/tb0191.pp b/tests/tbs/tb0191.pp new file mode 100644 index 0000000000..2b24d2deba --- /dev/null +++ b/tests/tbs/tb0191.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0225.pp } +{ Sigsegv when run with range checks on open arrays OK 0.99.11 (PFV) } + + program bug0255; + +{$mode objfpc} + +{$R+} + + function erwwert(const feld: array of LongInt):extended; + var i: LongInt; + begin + Result:=0; + for i:=low(feld) to high(feld) + do begin + writeln(i); // gives "0" + Result:=Result+feld[i]; + end; //^^^^^^^ there occurs the segfault (216) + // on the first loop + Result:=Result/(high(feld)-low(feld)+1); + end; + + var werte: array[0..299] of LongInt; + i: LongInt; + + begin + //init the array + for i:=0 to 299 do + werte[i]:=random(5); + + //and do something with it + writeln(erwwert(werte):6:5); + end. diff --git a/tests/tbs/tb0192.pp b/tests/tbs/tb0192.pp new file mode 100644 index 0000000000..601c4c5ba8 --- /dev/null +++ b/tests/tbs/tb0192.pp @@ -0,0 +1,13 @@ +{ %CPU=i386 } +{ Old file: tbs0226.pp } +{ Asm, offset of var is not allowed as constant OK 0.99.11 (PFV) } + +{$ifdef fpc}{$asmmode intel}{$endif} +var + test : longint; +begin + exit; { don't run this code below !! } + asm + dd test + end; +end. diff --git a/tests/tbs/tb0193.pp b/tests/tbs/tb0193.pp new file mode 100644 index 0000000000..4e520d10cd --- /dev/null +++ b/tests/tbs/tb0193.pp @@ -0,0 +1,39 @@ +{ Old file: tbs0227.pp } +{ external var does strange things when declared in localsymtable OK 0.99.11 (PFV) } + +var + stacksize : ptrint;external name '__stklen'; + +function getstacksize:longint;assembler; +asm +{$ifdef CPUI386} + movl stacksize,%eax +end ['EAX']; +{$endif CPUI386} +{$ifdef CPUX86_64} + movl stacksize,%eax +end ['EAX']; +{$endif CPUX86_64} +{$ifdef CPU68K} + move.l stacksize,d0 +end ['D0']; +{$endif CPU68K} +{$ifdef cpupowerpc} +{$ifndef macos} + lis r3, stacksize@ha + lwz r3, stacksize@l(r3) +{$else macos} + lwz r3, stacksize(r2) + lwz r3, 0(r3) +{$endif macos} +end; +{$endif cpupowerpc} +{$ifdef cpusparc} + sethi %hi(stacksize),%i0 + or %i0,%lo(stacksize),%i0 +end; +{$endif cpusparc} +begin + writeln(getstacksize); +end. + diff --git a/tests/tbs/tb0194.pp b/tests/tbs/tb0194.pp new file mode 100644 index 0000000000..78cb8adf11 --- /dev/null +++ b/tests/tbs/tb0194.pp @@ -0,0 +1,19 @@ +{ %CPU=i386 } +{ Old file: tbs0228.pp } +{ Asm, wrong warning for size OK 0.99.11 (PFV) } + +PROGRAM Buggy; + +{$ASMMODE ATT} + +PROCEDURE XX; ASSEMBLER; +TYPE + TabType=ARRAY[0..3] OF BYTE; +CONST + TabCent : TabType = (0,6,4,2); +ASM + movzbl TabCent(,%eax),%ebx +END; + +BEGIN +END. diff --git a/tests/tbs/tb0195.pp b/tests/tbs/tb0195.pp new file mode 100644 index 0000000000..0956e7443b --- /dev/null +++ b/tests/tbs/tb0195.pp @@ -0,0 +1,37 @@ +{ Old file: tbs0229.pp } +{ consts > 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) } + +{$mode objfpc} +{$X-} + +const + CRLF = #13#10; + c = + '1-----------------'+CRLF+ + '2/PcbDict 200 dict'+CRLF+ + '3PcbDicljkljkljk b'+CRLF+ + '4PcbDict /DictMaix'+CRLF+ + '5% draw a pin-poll'+CRLF+ + '6% get x+CRLF+ y s'+CRLF+ + '7/thickness exch h'+CRLF+ + '8gsave x y transls'+CRLF+ + '9---------jljkljkl'+crlf+ + '10----------2jkljk'+crlf+ + '11----------jkllkk'+crlf+ + 'eeeeeeeeeeeeeeeeee'+crlf+ + '2-----------------'+CRLF+ + '2/PcbDict 200 dice'+CRLF+ + 'END____.XXXXXxjk b'+CRLF+ + '4PcbDict /DictMaix'+CRLF+ + '5% draw a pin-poll'+CRLF+ + '6% get x+CRLF+ y s'+CRLF+ + '7/thickness exch h'+CRLF+ + '8gsave x y transls'+CRLF+ + '9---------jljkljkl'+crlf+ + '10----------2jkljk'+crlf+ + '11----------jkllkk'+crlf+ + 'eeeeeeeeeeeeeeeeee12'; + +begin + write(c); +end. diff --git a/tests/tbs/tb0196.pp b/tests/tbs/tb0196.pp new file mode 100644 index 0000000000..2517d76cfa --- /dev/null +++ b/tests/tbs/tb0196.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0232.pp } +{ const. procedure variables need a special syntax if they use calling specification modifiers } + +const + p1 : procedure;stdcall=nil; { <----- this doesn't what you expect !!!!} + p2 : procedure stdcall=nil; { so delphi supports also this way of } + { declaration } + +begin +end. + diff --git a/tests/tbs/tb0197.pp b/tests/tbs/tb0197.pp new file mode 100644 index 0000000000..bb80d7de98 --- /dev/null +++ b/tests/tbs/tb0197.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0233.pp } +{ Problem with enum sets in args OK 0.99.11 (PFV) } + +program except_test; + +type byteset = set of byte; + enumset = set of (zero,one,two,three); + +function test(s : byteset) : boolean; +begin + test:=false; + if 0 in s then + begin + Writeln('Contains zero !'); + test:=true; + end; +end; + +function testenum(s : enumset) : boolean; +begin + testenum:=false; + + if zero in s then + begin + Writeln('Contains zero !'); + testenum:=true; + end; +end; + +begin + if test([1..5,8]) then halt(1); + if not test([0,8,15]) then halt(1); + if not testenum([zero,two]) then halt(1); +end. diff --git a/tests/tbs/tb0198.pp b/tests/tbs/tb0198.pp new file mode 100644 index 0000000000..79ad1d855a --- /dev/null +++ b/tests/tbs/tb0198.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0234.pp } +{ New with void pointer OK 0.99.11 (PM) } + +program bug0232; + +{$mode tp} + +var p:pointer; + +begin + new(p); + dispose(p); +end. diff --git a/tests/tbs/tb0199.pp b/tests/tbs/tb0199.pp new file mode 100644 index 0000000000..bf7e7e32c9 --- /dev/null +++ b/tests/tbs/tb0199.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0235.pp } +{ Val(cardinal) bugs OK 0.99.11 (JM) } + +program bug0233; + +var s:string; + w:cardinal; + code:word; + +begin + s:='192'; + val(s,w,code); + if code<>0 then + begin + writeln('Error'); + halt(1); + end + else + writeln(w); +end. diff --git a/tests/tbs/tb0200.pp b/tests/tbs/tb0200.pp new file mode 100644 index 0000000000..52f17d05bb --- /dev/null +++ b/tests/tbs/tb0200.pp @@ -0,0 +1,43 @@ +{ Old file: tbs0236.pp } +{ Problem with range check of subsets !! compile with -Cr OK 0.99.11 (PFV) } + +{$R+} +program test_set_subrange; + +uses + erroru; + + type + enum = (zero,one,two,three); + + sub_enum = one..three; + prec = ^trec; + + trec = record + dummy : longint; + en : enum; + next : prec; + end; + + const + str : array[sub_enum] of string = ('one','two','three'); + +procedure test; + + var hp : prec; + t : sub_enum; + + begin + new(hp); + hp^.en:=zero; + new(hp^.next); + hp^.next^.en:=three; + t:=hp^.en; + Writeln('hp^.en = ',str[hp^.en]); + Writeln('hp^.next^.en = ',str[hp^.next^.en]); + end; + +begin + require_error(201); + test; +end. diff --git a/tests/tbs/tb0201.pp b/tests/tbs/tb0201.pp new file mode 100644 index 0000000000..8fada7299e --- /dev/null +++ b/tests/tbs/tb0201.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0237.pp } +{ Can't have sub procedures with names defined in interface OK 0.99.13 (PM) } + +unit tb0201; +interface + + procedure sub1(w1,w2:word); + +implementation + +procedure p1; + + procedure sub1(w:word); + begin + end; + +begin +end; + + +procedure sub1(w1,w2:word); +begin +end; + +end. diff --git a/tests/tbs/tb0202.pp b/tests/tbs/tb0202.pp new file mode 100644 index 0000000000..10ef6838f2 --- /dev/null +++ b/tests/tbs/tb0202.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0238.pp } +{ Internal error 432645 (from Frank MCCormick, mailinglist 24/2) OK 0.99.11 (PM) } + +program test1; + + {compiles under TPC - PPC386 gives internal error} + +Type str1=string[160]; + +var + fileof :file of str1; + lol :array[1..8] of str1; + nu,n:integer; + i,tt :str1; + ul :text; + a: str1; + + +procedure test; + + +begin + for nu:=1 to 8 do read(fileof,lol[nu]); + writeln('File contents'); + for nu:=4 to 8 do writeln(lol[nu]); +end; + + +begin + assign(fileof,'tbs0238.tmp'); + rewrite(fileof); + a:='dummy string !!'; + for nu:=1 to 8 do write(fileof,a); + close(fileof); + reset(fileof); + test; + close(fileof); +end. diff --git a/tests/tbs/tb0203.pp b/tests/tbs/tb0203.pp new file mode 100644 index 0000000000..7f1d0a0198 --- /dev/null +++ b/tests/tbs/tb0203.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0239.pp } +{ No warning for uninitialized class in IS statements OK 0.99.11 (PM) } + +{$mode delphi} + uses + sysutils; + + type + ttest=class + end; + ttest2 = class(ttest) + end; + ttestclass=class of ttest; + var + i,j:ttest; + tt:tclass; + begin + tt:=ttest; + i:=ttest.create; + j:=ttest2.create; + Writeln('tt is a class of ttest initialized by "tt:=ttest"'); + Writeln('i is a ttest class initialized by "i:=ttest.create"'); + Writeln('j is a ttest class initialized by "j:=ttest2.create"'); + writeln('i is tobject ',i is tobject); + if not(i is tobject) then + Halt(1); + writeln('i is tt ',i is tt); + if not(i is tt) then + Halt(1); + writeln('i is ttest ',i is ttest); + if not(i is ttest) then + Halt(1); + writeln('i is ttest2 ',i is ttest2); + if (i is ttest2) then + Halt(1); + writeln('j is tobject ',j is tobject); + if not(j is tobject) then + Halt(1); + writeln('j is tt ',j is tt); + if not(j is tt) then + Halt(1); + writeln('j is ttest ',j is ttest); + if not(j is ttest) then + Halt(1); + writeln('j is ttest2 ',j is ttest2); + if not(j is ttest2) then + Halt(1); + end. diff --git a/tests/tbs/tb0204.pp b/tests/tbs/tb0204.pp new file mode 100644 index 0000000000..170efa1e7e --- /dev/null +++ b/tests/tbs/tb0204.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0240.pp } +{ Problems with larges value is case statements OK 0.99.11 (FK) } + +Program TEST; + +var CurFileCrc32f : cardinal{Longint}; + CheckThis : String; + +BEGIN + CurFileCrc32f := $C5CAF43C; + CheckThis := ''; + Case CurFileCrc32f of + $F3DC2AF0 : CheckThis := ' First '; + $27BF798B : CheckThis := ' Second '; + $7BA5BB19 : CheckThis := ' Third'; + $FA246A81 : CheckThis := ' Forth'; + $8A00B508 : CheckThis := ' Fifth'; + $C5CAF43C : CheckThis := ' Sixth'; + End; + Writeln( CheckThis ); + If CheckThis<>' Sixth' then halt(1); +END. + + diff --git a/tests/tbs/tb0205.pp b/tests/tbs/tb0205.pp new file mode 100644 index 0000000000..16691edc8f --- /dev/null +++ b/tests/tbs/tb0205.pp @@ -0,0 +1,17 @@ +{ %TARGET=win32 } + +{ Old file: tbs0241.pp } +{ Problem with importing function from a DLL with .drv suffix ! OK 0.99.11 (PM) } + +program test_win32_drv; + +procedure printer;external 'winspool.drv' name 'AbortPrinter'; + +procedure test; +begin + Writeln('Loading of Winspool works '); +end; + +begin + test; +end. diff --git a/tests/tbs/tb0206.pp b/tests/tbs/tb0206.pp new file mode 100644 index 0000000000..97a5fda104 --- /dev/null +++ b/tests/tbs/tb0206.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0242b.pp } +{ } + + +const + test = 5; + + procedure test_const(const s : string;const x); + begin + writeln(s,' is ',longint(x)); + end; + + procedure change(var x); + begin + inc(longint(x)); + end; + const i : longint = 12; + var + j : longint; +begin + j:=34; + test_const('Const 5',5); + test_const('Untyped const test',test); + test_const('Typed_const i',i); + test_const('Var j',j); + {test_const('i<>j ',i<>j);} + change(i); + change(j); + { change(test); + change(longint); } +end. diff --git a/tests/tbs/tb0207.pp b/tests/tbs/tb0207.pp new file mode 100644 index 0000000000..07d6649404 --- /dev/null +++ b/tests/tbs/tb0207.pp @@ -0,0 +1,40 @@ +{ %KNOWNRUNERROR=1 Free Pascal does not compute args from left to right } + +{ Old file: tbs0243.pp } +{ Arguments of functions are computed from right to left this } + +program simpletest; + +var i : longint; + + function _next : longint; + begin + inc(i); + _next:=i; + end; + + procedure test(a,b : longint); + begin + Writeln('first arg is ',a); + Writeln('second arg is ',b); + end; + + procedure check(a,b : longint); + begin + if a>b then + begin + Writeln('FPC does not follow PASCAL rules for parameter passing'); + Halt(1); + end; + end; + +begin +{ this could give + first arg is 1 + second arg is 2 + but FPC parses the second arg before the first one ! } +test(_next,_next); +writeln('third arg is ',_next); +writeln('fourth arg is ',_next,' fifth arg is ',_next); +check(_next,_next); +end. diff --git a/tests/tbs/tb0208.pp b/tests/tbs/tb0208.pp new file mode 100644 index 0000000000..14fdf8bd61 --- /dev/null +++ b/tests/tbs/tb0208.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0244.pp } +{ nested procedures can't have same name as global ones (same as tbs0237) OK 0.99.13 (PM) } + +Unit tb0208; + +{test also with -So !!!} + +Interface + +Procedure t(a,b: longint); + +Implementation + +Procedure t(a,b: longint); +begin +end; + +Procedure t2; + + Procedure t(l: Longint); + Begin + End; + +Begin +End; + +End. diff --git a/tests/tbs/tb0209.pp b/tests/tbs/tb0209.pp new file mode 100644 index 0000000000..dfd122f1e5 --- /dev/null +++ b/tests/tbs/tb0209.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0247.pp } +{ var with initial value not supprted (Delphi var x : integer = 5;) allowed in -Sd mode OK 0.99.11 (PM) } + +{$mode delphi} + +var + x : integer = 34; +{ this is the way Delphi creates initialized vars + ++ its much more logical then BP + typed const !! + -- its incompatible with BP !! (PM) } + + y : array[0..2] of real = (0.0,1.23,2.56); + +{ these are true const in Delphi mode and thus + it should not be possible to change ! } + +const + z : real = 45.2; + +begin + y[2]:=z; + { this should be refused ! } + z:=y[1]; +end. diff --git a/tests/tbs/tb0210.pp b/tests/tbs/tb0210.pp new file mode 100644 index 0000000000..1bb62c7bba --- /dev/null +++ b/tests/tbs/tb0210.pp @@ -0,0 +1,64 @@ +{ Old file: tbs0249.pp } +{ procedure of object cannot be assigned to property. OK 0.99.11 (PFV) } + +program TestEvent; + +{$mode objfpc} +{$M+} + +type + TNotifyEvent = procedure( Sender: TObject ) of object; + + THost = class + protected + FOnEvent: TNotifyEvent; + procedure SetOnEvent( Value: TNotifyEvent ); + public + constructor Create; + procedure Trigger; + procedure SayHello; + published + property OnEvent: TNotifyEvent read FOnEvent write SetOnEvent; + end; + + TDummy = class + procedure HandleEvent( Sender: TObject ); + end; + +constructor THost.Create; +begin + FOnEvent := nil; +end; + +procedure THost.Trigger; +begin + if @FOnEvent <> nil then + FOnEvent( Self ) +end; + +procedure THost.SetOnEvent( Value: TNotifyEvent ); +begin + FOnEvent := Value +end; + +procedure THost.SayHello; +begin + Writeln( 'Hello event' ) +end; + +procedure TDummy.HandleEvent( Sender: TObject ); +begin + THost( Sender ).SayHello +end; + + +var + Host: THost; + Dummy: TDummy; +begin + Dummy := TDummy.Create; + Host := THost.Create; + with Host,Dummy do + OnEvent := @HandleEvent; // this is 57, 27 is ";" + Host.Trigger; +end. diff --git a/tests/tbs/tb0211.pp b/tests/tbs/tb0211.pp new file mode 100644 index 0000000000..abe559afc5 --- /dev/null +++ b/tests/tbs/tb0211.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0250.pp } +{ error with Ansistrings and loops. OK 0.99.11 (PFV) } + +program testme; + +uses erroru; + +// Removing this switch removes the bug !! +{$H+} + +var A : String; + P : PChar; + I : longint; + +begin + P := 'Some sample testchar'; + A := Ansistring(P); + Writeln ('A : ',A); + for I:=1 to length(A)-1 do + begin + A:='Some small test'; + A:=A+' ansistring'; + Writeln ('A : ',A); + If A<>'' then + Writeln ('All is fine') + else + begin + writeln ('Oh-oh!'); + error; + end; + end; +end. diff --git a/tests/tbs/tb0212.pp b/tests/tbs/tb0212.pp new file mode 100644 index 0000000000..fd2a069bd2 --- /dev/null +++ b/tests/tbs/tb0212.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0251.pp } +{ typed const are not aligned correctly OK 0.99.11 (PM) } + + +uses erroru; + +const + c : byte = 5; + r : real = 3.4; +var + l : longint; + cc : char; + rr : real; + +begin + l:=longint(@r); + if (l mod 4)<>0 then + begin + Writeln('static const are not aligned properly !'); + error; + end; + cc:='d'; + l:=longint(@rr); + if (l mod 4)<>0 then + begin + Writeln('static var are not aligned properly !'); + error; + end; +end. diff --git a/tests/tbs/tb0213.pp b/tests/tbs/tb0213.pp new file mode 100644 index 0000000000..a64141a6d4 --- /dev/null +++ b/tests/tbs/tb0213.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0252.pp } +{ typecasting not possible within typed const OK 0.99.13 (PFV) } + +type + wnd=procedure; + r=record + w : wnd; + end; + +procedure p; +begin +end; + +const + r1:r=( + w : wnd(@p); + ); + +begin +end. + diff --git a/tests/tbs/tb0214.pp b/tests/tbs/tb0214.pp new file mode 100644 index 0000000000..98fc44963f --- /dev/null +++ b/tests/tbs/tb0214.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0253.pp } +{ problem with overloaded procedures and forward OK 0.99.11 (PFV) } + +procedure test(w : word);forward; + +procedure test(a : string); +begin + Writeln(a); + test(20); +end; + +procedure test(w :word); +begin + writeln(w); +end; + +begin + test('test'); + test(32); +end. + diff --git a/tests/tbs/tb0215.pp b/tests/tbs/tb0215.pp new file mode 100644 index 0000000000..005afffb90 --- /dev/null +++ b/tests/tbs/tb0215.pp @@ -0,0 +1,7 @@ +{ Old file: tbs0254.pp } +{ problem of endless loop if string at end of main file without new line. OK 0.99.11 (PM) } + +begin +end. + +disposestr diff --git a/tests/tbs/tb0216.pp b/tests/tbs/tb0216.pp new file mode 100644 index 0000000000..87de34cd6a --- /dev/null +++ b/tests/tbs/tb0216.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0255.pp } +{ internal error 10 with in and function calls OK 0.99.12 (FK) } + + +function a: char; +begin + a:='c'; +end; + +begin + if #12 in [a, a, a, a, a] then ; { <--- } +end. diff --git a/tests/tbs/tb0217.pp b/tests/tbs/tb0217.pp new file mode 100644 index 0000000000..e23bd6ede3 --- /dev/null +++ b/tests/tbs/tb0217.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0256.pp } +{ problem with conditionnals in TP mode OK 0.99.11 (PM) } + +{$mode tp} + +{$undef dummy } + +{$ifdef dummy} + procedure test; + begin + foreach({$ifndef TP}@{$endif}add_to_browserlog); + end; +{$endif BrowserLog} + +begin +end. diff --git a/tests/tbs/tb0218.pp b/tests/tbs/tb0218.pp new file mode 100644 index 0000000000..1cd751556e --- /dev/null +++ b/tests/tbs/tb0218.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0257.pp } +{ problem with procvars in tp mode OK 0.99.11 (PM) } + +{$mode tp} + +type proc = procedure(a : longint); +procedure test(b : longint); +begin + Writeln('Test ',b); +end; + +var + t : proc; + +begin + t:=test; + t:=proc(test); + test(3); + t(5); +end. + diff --git a/tests/tbs/tb0219.pp b/tests/tbs/tb0219.pp new file mode 100644 index 0000000000..85aeded45b --- /dev/null +++ b/tests/tbs/tb0219.pp @@ -0,0 +1,66 @@ +{ Old file: tbs0258.pp } +{ bugs in small const set extension to large sets OK 0.99.12 (PM) } + +{$ifdef fpc} +{$mode tp} +{$endif fpc} +program test_set; + +uses erroru; + +{$R-} + +procedure test; + + var + i : longint; + j : integer; + k : word; + l : shortint; + m : byte; + x : array [1..32] of byte; + + begin + for i:=1 to 32 do x[i]:=$ff; + i:=1; + if not(i in [1,3,5,8,11,14,15]) then + begin + writeln('Error in set'); + error; + end; + i:=135; + if i in [1,3,5,8,11,14,15] then + begin + writeln('Error : 135 is in [1,3,5,8,11,14,15]'); + error; + end; + i:=257; + if not(i in [1,3,5,8,11,14,15]) then + begin + writeln('Error : 257 isn''t in [1,3,5,8,11,14,15]'); + error; + end; + l:=-1; + if not(l in [1,3,5,8,11,14,15,255]) then + begin + writeln('Error : -1 isn''t in [1,3,5,8,11,14,15,255]'); + error; + end; + i:=257; + if not(l in [1,3,5,8,11,14,15,255]) then + begin + writeln('Error : longint(257) isn''t in [1,3,5,8,11,14,15,255]'); + error; + end; + for i:=1 to 32 do x[i]:=0; + i:=135; + if i in [1,3,5,8,11,14,15] then + begin + writeln('Second try Error : 135 is in [1,3,5,8,11,14,15]'); + error; + end; + end; + +begin + test; +end. diff --git a/tests/tbs/tb0220.pp b/tests/tbs/tb0220.pp new file mode 100644 index 0000000000..b2f5fc1f83 --- /dev/null +++ b/tests/tbs/tb0220.pp @@ -0,0 +1,12 @@ +{ %CPU=i386 } +{ %OPT= -O1 } + +{ Old file: tbs0259.pp } +{ problem with optimizer for real math (use -O1) OK 0.99.12 (PM) } +{ -O1 is not allowed for m68k } + +VAR time1,time2 : Real; +BEGIN + time1 := 0; + time2 := time1*time1; +END. diff --git a/tests/tbs/tb0221.pp b/tests/tbs/tb0221.pp new file mode 100644 index 0000000000..6d4805f772 --- /dev/null +++ b/tests/tbs/tb0221.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0260.pp } +{ problem with VMT generation if non virtual method has a virtual overload OK 0.99.12 (PM) } + +program test; + + type + obj1 = object + st : string; + constructor init; + procedure writeit; + end; + + obj2 = object(obj1) + procedure writeit;virtual; + end; + + obj3 = object(obj2) + l : longint; + end; + + constructor obj1.init; + begin + end; + + procedure obj1.writeit; + begin + end; + + procedure obj2.writeit; + begin + end; + + +begin +end. diff --git a/tests/tbs/tb0222.pp b/tests/tbs/tb0222.pp new file mode 100644 index 0000000000..ba2ec84580 --- /dev/null +++ b/tests/tbs/tb0222.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0261.pp } +{ problems for assignment overloading OK 0.99.12a (PM) } + +program bug0261; + +{ test for operator overloading } +{ Copyright (c) 1999 Lourens Veen } +{ why doesn't this work? } +uses + erroru, + ub0222; + + +var a : mythingy; + b : myotherthingy; + c : mythirdthingy; +begin + a.x:=55; + a.y:=45; + a.c:=7; + b:=a; + c:=a; + if b.d<>c.e then + begin + Writeln('Error in assignment overloading'); + Halt(1); + end; + if b<>c then + begin + Writeln('Error in equal overloading'); + Halt(1); + end; + Writeln('Sizeof(mythirdthingy)=',sizeof(mythirdthingy)); + Writeln('Sizeof(mynewthingy)=',sizeof(mynewthingy)); +end. diff --git a/tests/tbs/tb0224.pp b/tests/tbs/tb0224.pp new file mode 100644 index 0000000000..080511931e --- /dev/null +++ b/tests/tbs/tb0224.pp @@ -0,0 +1,119 @@ +{ %version=1.1 } + +{ Old file: tbs0262.pp } +{ problems with virtual and overloaded methods } + +program test; + + type + obj1 = object + st2 : string; + constructor init; + procedure writeit;overload; + procedure writeit(st : string);virtual;overload; + end; + + obj2 = object(obj1) + procedure writeit;virtual;overload; + end; + + obj3 = object(obj2) + l2 : longint; + procedure writeit(l : longint);virtual;overload; + procedure writeit(st : string);virtual;overload; + end; + + obj4 = object(obj3) + procedure writeit;virtual;overload; + procedure writeit(st : string);virtual;overload; + end; + + obj5 = object(obj4) + procedure writeit;virtual;overload; + procedure writeit(st : string);overload; + procedure writeit(l : longint);virtual;overload; + end; + + constructor obj1.init; + begin + end; + + procedure obj1.writeit; + begin + Writeln('Obj1 writeit'); + end; + + procedure obj1.writeit(st : string); + begin + Writeln('Obj1 writeit(string) ',st); + end; + + procedure obj2.writeit; + begin + Writeln('Obj2 writeit'); + end; + + procedure obj3.writeit(st : string); + begin + Writeln('Obj3 writeit(string) ',st); + end; + + procedure obj3.writeit(l : longint); + begin + Writeln('Obj2 writeit(longint) ',l); + end; + + procedure obj4.writeit; + begin + Writeln('Obj4 writeit'); + end; + + procedure obj4.writeit(st : string); + begin + Writeln('Obj4 writeit(string) ',st); + end; + + procedure obj5.writeit; + begin + Writeln('Obj5 writeit'); + end; + + procedure obj5.writeit(st : string); + begin + Writeln('Obj5 writeit(string) ',st); + end; + + procedure obj5.writeit(l : longint); + begin + Writeln('Obj5 writeit(longint) ',l); + end; + +var + o1 : obj1; + o2 : obj2; + o3 : obj3; + o4 : obj4; + o5 : obj5; + + + +begin + o1.init; + o1.writeit; + o1.writeit('o1'); + o2.init; + o2.writeit; + o2.writeit('o2'); + o3.init; + o3.writeit; + o3.writeit('o3'); + o3.writeit(3); + o4.init; + o4.writeit; + o4.writeit('o4'); + o4.writeit(4); + o5.init; + o5.writeit; + o5.writeit('o5'); + o5.writeit(5); +end. diff --git a/tests/tbs/tb0225.pp b/tests/tbs/tb0225.pp new file mode 100644 index 0000000000..22c8967245 --- /dev/null +++ b/tests/tbs/tb0225.pp @@ -0,0 +1,21 @@ +{ %TARGET=win32,linux } +{ %NORUN } + +{ Old file: tbs0263.pp } +{ export directive is not necessary in delphi anymore OK 0.99.13 (PFV) } + +library tb0225; + +{ + The export directive is not necessary anymore in delphi, it's a leftover + from the 16bit model, just like near and far. +} + +procedure testp; +begin +end; + +exports + testp name 'testp'; + +end. diff --git a/tests/tbs/tb0226.pp b/tests/tbs/tb0226.pp new file mode 100644 index 0000000000..c0b1852a30 --- /dev/null +++ b/tests/tbs/tb0226.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0264.pp } +{ methodpointer bugss OK 0.99.12b (FK) } + +{$MODE DELPHI} + +type + a = class + c : procedure of object; + + constructor create; virtual; + destructor destroy; override; + + procedure e; virtual; + procedure f; virtual; + end; + +constructor a.create; +begin + c := e; +end; + +destructor a.destroy; +begin +end; + +procedure a.e; +begin + Writeln('E'); + c := f; +end; + +procedure a.f; +begin + Writeln('F'); + c := e; +end; + +var + z : a; + +begin + z := a.create; + z.c; + z.c; + z.c; + z.free; +end. diff --git a/tests/tbs/tb0227.pp b/tests/tbs/tb0227.pp new file mode 100644 index 0000000000..30b1cca9ba --- /dev/null +++ b/tests/tbs/tb0227.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0266.pp } +{ linux crt write cuts 256 char OK 0.99.13 (PFV) } + +PROGRAM t10; + +USES CRT; + +VAR S: STRING; + X: BYTE; + + + BEGIN + S := ''; + FOR X := 1 TO 253 DO S:=S+'-'; + S := S+'_!'; + WRITE(S); + WRITE('*',S); + END. + diff --git a/tests/tbs/tb0228.pp b/tests/tbs/tb0228.pp new file mode 100644 index 0000000000..fd16bbdd9e --- /dev/null +++ b/tests/tbs/tb0228.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0267.pp } +{ parameters after methodpointer are wrong OK 0.99.12b (FK) } + +{$MODE objfpc} + +program procofobject_arg; +type + TProcOfObject = procedure of object; + TTestClass = class + procedure SomeMethod; + end; + +procedure TTestClass.SomeMethod; begin end; + + +// the following proc won't print i2 correctly + +procedure CrashProc(i1: Integer;method: TProcOfObject; i2: Integer); +begin + WriteLn('i1 is :', i1); + WriteLn('i2 is :', i2); + if i2<>456 then + Halt(1); +end; + +var + instance: TTestClass; +begin + instance := TTestClass.Create; + CrashProc(123, @instance.SomeMethod, 456); +end. diff --git a/tests/tbs/tb0229.pp b/tests/tbs/tb0229.pp new file mode 100644 index 0000000000..c1e2235aa1 --- /dev/null +++ b/tests/tbs/tb0229.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0268.pp } +{ crash with exceptions OK 0.99.13 (FK) } + +PROGRAM Test2; + +{$MODE DELPHI} + +USES SysUtils; // Dos for DosError because FindFirst is not a Function? + +PROCEDURE DirList; +(* Show all Files, gives me "unhandled exception occurred at xxx, access + violation" after inserting Try Except it worked but i got a "forever + scrolling screen", then i inserted raise and got a correct "Exception + in FindFirst" and "At end of ExceptionAddressStack" + Next i inserted the ON E:EXCEPTION and ,E.Message an got 9999 *) +VAR SR : TSearchRec; +BEGIN + TRY + FindFirst ('*',faAnyFile,SR); // why not a function ? + EXCEPT + ON E:EXCEPTION DO + WriteLn ('Exception in FindFirst !-', E.Message); + END; + repeat + Write (SR.Name,' '); + until FindNext (SR)<>0; + FindClose (SR); // and this is Delphi ? +END; + +BEGIN + WriteLn ('Hello, this is my first FPC-Program'); + DirList; +END. diff --git a/tests/tbs/tb0230.pp b/tests/tbs/tb0230.pp new file mode 100644 index 0000000000..4b85247a8a --- /dev/null +++ b/tests/tbs/tb0230.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0270.pp } +{ unexpected eof in tp mode with (* and directives OK 0.99.13 (PFV) } + +unit tb0230; + +{$mode tp} + +interface + +const + s='df'; + +{$IFDEF VDE} + SFilterOpen = ' (*.nnn)|*.nnn' + '|' + 'Alle Files (*.*)|*.*'; + SFilterSave = ' (*.nnn)|*.nnn'; + SFilterOpen2 = ' (*.vvv)|*.vvv' + '|' + 'All Files (*.*)|*.*'; + SFilterSave2 = ' (*.vvv)|*.vvv'; + SFilterOpen3 = ' (*.eee)|*.eee' + '|' + 'All Files (*.*)|*.*'; + SFilterSave3 = ' (*.eee)|*.eee'; +{$ENDIF} + +implementation + +end. diff --git a/tests/tbs/tb0231.pp b/tests/tbs/tb0231.pp new file mode 100644 index 0000000000..6e382ad4f7 --- /dev/null +++ b/tests/tbs/tb0231.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0271.pp } +{ abstract methods can't be assigned to methodpointers OK 0.99.13 (??) } + +{$mode fpc} + type + tproc = procedure; + +procedure proc1; +begin +end; + +var + _copyscan : tproc; + +procedure setproc; +begin + _copyscan := @proc1; +end; + +procedure testproc; +begin + if not (_copyscan=@proc1) then + begin + Writeln(' Problem procvar equality'); + Halt(1); + end + else + Writeln(' No problem with procedure equality'); +end; + +begin + setproc; + testproc; +end. diff --git a/tests/tbs/tb0232.pp b/tests/tbs/tb0232.pp new file mode 100644 index 0000000000..ad793df626 --- /dev/null +++ b/tests/tbs/tb0232.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0272.pp } +{ No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) } + +program test_const_string; + + +function astring(s :string) : string; + +begin + astring:='Test string'+s; +end; + +procedure testvar(var s : string); +begin + writeln('testvar s is "',s,'"'); +end; + +procedure testconst(const s : string); +begin + writeln('testconst s is "',s,'"'); +end; + +procedure testvalue(s : string); +begin + writeln('testvalue s is "',s,'"'); +end; + +const + s : string = 'test'; + conststr = 'Const test'; +begin + testvalue(astring('e')); + testconst(astring(s)); + testconst(conststr); +end. + diff --git a/tests/tbs/tb0233.pp b/tests/tbs/tb0233.pp new file mode 100644 index 0000000000..ffeadb2b2a --- /dev/null +++ b/tests/tbs/tb0233.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0273.pp } +{ small array pushing to array of char procedure is wrong OK 0.99.13 (PFV) } + +Program CharArr; + +Var CharArray : Array[1..4] Of Char; + + S : String; + +Begin + CharArray:='BUG?'; + S:=CharArray; + WriteLn(S); { * This is O.K. * } + WriteLn(CharArray); { * GENERAL PROTECTION FAULT. * } + if CharArray<>'BUG?' then + begin + Writeln('Error comparing charaay to constant string'); + Halt(1); + end; +End. + diff --git a/tests/tbs/tb0234.pp b/tests/tbs/tb0234.pp new file mode 100644 index 0000000000..854cae0ae9 --- /dev/null +++ b/tests/tbs/tb0234.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0274.pp } +{ @(proc) is not allowed OK 0.99.13 (PFV) } + +type + proc=procedure(a:longint); + +procedure prc(a:longint); +begin +end; + +var + p : proc; +begin + p:=@prc; + p:=@(prc); { should this be allowed ? } +end. diff --git a/tests/tbs/tb0235.pp b/tests/tbs/tb0235.pp new file mode 100644 index 0000000000..d40ce6b53d --- /dev/null +++ b/tests/tbs/tb0235.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0275.pp } +{ too many warnings } + +var + d : single; +begin + writeln(longint(d)); +end. diff --git a/tests/tbs/tb0236.pp b/tests/tbs/tb0236.pp new file mode 100644 index 0000000000..14867dce20 --- /dev/null +++ b/tests/tbs/tb0236.pp @@ -0,0 +1,50 @@ +{ %CPU=i386 } +{ Old file: tbs0276.pp } +{ Asm, intel reference parsing incompatibility OK 0.99.13 (PFV) } + +{$asmmode intel} +type + trec = record + ypos, + xpos : longint; + end; + + z80cont = record + dummy : longint; + page: array [0..11,0..16383] of byte; + end; + +var + rec : tRec; + myz80 : z80cont; + error : boolean; + test : byte; +begin + error:=false; + test:=23; + rec.xpos:=1; + myz80.page[0,5]:=15; + asm + lea edi, Rec + cmp byte ptr [edi+tRec.Xpos], 1 + jne @error + cmp byte ptr [edi].trec.Xpos, 1 + jne @error + mov ecx, 5 + mov dh,byte ptr myz80.page[ecx] + cmp dh,15 + jne @error + mov byte ptr myz80.page[ecx],51 + jmp @noerror + @error: + mov byte ptr error,1 + @noerror: + end; + if error or (test<>23) or (myz80.page[0,5]<>51) then + begin + Writeln('Error in assembler code generation'); + Halt(1); + end + else + Writeln('Correct assembler generated'); +end. diff --git a/tests/tbs/tb0237.pp b/tests/tbs/tb0237.pp new file mode 100644 index 0000000000..9e3a786a5d --- /dev/null +++ b/tests/tbs/tb0237.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0277.pp } +{ typecasting with const not possible OK 0.99.13 (PFV) } + + program bug0277; + const test_byte=pchar(1); + begin + writeln('Hello world'); + end. diff --git a/tests/tbs/tb0238.pp b/tests/tbs/tb0238.pp new file mode 100644 index 0000000000..e9dce8e71c --- /dev/null +++ b/tests/tbs/tb0238.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0278.pp } +{ (* in conditional code is handled wrong for tp,delphi OK 0.99.13 (PFV) } + +{$ifdef fpc}{$mode tp}{$endif} +unit tb0238; + +interface + +{ +a string constant within $IFDEF that +contains "(*" causes an error; +compile it with "ppc386 test -So" or "-Sd" +} + +var + c : char; + +{$IFDEF not_defined} +const + c = 'b''(* + +{ $else} + +var + c : char; + +{$ENDIF} + + +implementation + +end. diff --git a/tests/tbs/tb0239.pp b/tests/tbs/tb0239.pp new file mode 100644 index 0000000000..62a4cbd69a --- /dev/null +++ b/tests/tbs/tb0239.pp @@ -0,0 +1,40 @@ +{ Old file: tbs0279.pp } +{ crash with ansistring and new(^ansistring) OK 0.99.13 (PFV) } + +{$H+} +Program AnsiTest; +uses + erroru; + +Type + PS=^String; +var + mem : ptrint; + + +procedure test; +var + P:PS; +Begin + p:=New(PS); + P^:=''; + P^:=P^+'BLAH'; + P^:=P^+' '+P^; + Writeln(P^); + Dispose(P); + + New(P); + P^:=''; + P^:=P^+'BLAH'; + P^:=P^+' '+P^; + Writeln(P^); + Dispose(P); +end; + +begin + DoMem(mem); + test; + if DoMem(mem)<>0 then + halt(1); +end. + diff --git a/tests/tbs/tb0240.pp b/tests/tbs/tb0240.pp new file mode 100644 index 0000000000..beaf247861 --- /dev/null +++ b/tests/tbs/tb0240.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0280.pp } +{ problem with object finalization. OK 0.99.13 (FK) } +{$mode objfpc} +{$H+} + +uses + Erroru; + +type + TMyClass = class + s: String; + end; + +procedure dotest; + +var + c: TMyClass; + s : string; + +begin + s:='world'; + s:='Hallo '+s; + writeln((plongint(s)-4)^); + c := TMyClass.Create; + writeln(ptrint(c.s)); + c.s := Copy('Test', 1, 4); + writeln((pptrint(c.s)-4)^); + c.free; +end; + +var + mem : sizeint; +begin + DoMem(mem); + dotest; + if DoMem(mem)<>0 then + Halt(1); +end. diff --git a/tests/tbs/tb0241.pp b/tests/tbs/tb0241.pp new file mode 100644 index 0000000000..c695bd4a4c --- /dev/null +++ b/tests/tbs/tb0241.pp @@ -0,0 +1,41 @@ +{ %OPT=-al } +{ %SKIPTARGET=macos } +{ On macos, PPCAsm chokes on this and crashes} + +{ this forces use of GNU as } +{ Old file: tbs0282.pp } +{ long mangledname problem with -Aas OK 0.99.13 (PFV) } + + +type very____long_____string___identifier= string[200]; + +procedure test(very__long_variable01: very____long_____string___identifier; + very__long_variable02: very____long_____string___identifier; + very__long_variable03: very____long_____string___identifier; + very__long_variable04: very____long_____string___identifier; + very__long_variable05: very____long_____string___identifier; + very__long_variable06: very____long_____string___identifier; + very__long_variable07: very____long_____string___identifier; + very__long_variable08: very____long_____string___identifier; + very__long_variable09: very____long_____string___identifier; + very__long_variable10: very____long_____string___identifier; + very__long_variable11: very____long_____string___identifier; + very__long_variable12: very____long_____string___identifier; + very__long_variable13: very____long_____string___identifier; + very__long_variable14: very____long_____string___identifier; + very__long_variable15: very____long_____string___identifier; + very__long_variable16: very____long_____string___identifier; + very__long_variable17: very____long_____string___identifier; + very__long_variable18: very____long_____string___identifier); +begin + writeln('hi!'); +end; + +begin + writeln('vreemd!'); + test('','','','','','','','','','', + '','','','','','','',''); +end. + + + diff --git a/tests/tbs/tb0241b.pp b/tests/tbs/tb0241b.pp new file mode 100644 index 0000000000..f59ac32630 --- /dev/null +++ b/tests/tbs/tb0241b.pp @@ -0,0 +1,45 @@ +{ %OPT=-al } +{ %SKIPTARGET=macos } +{ On macos, PPCAsm chokes on this and crashes} + +{ this forces use of GNU as } +{ Old file: tbs0282.pp } +{ long mangledname problem with -Aas OK 0.99.13 (PFV) } + + +type very____long_____string___identifier= string[200]; + +procedure test(very__long_variable01: very____long_____string___identifier; + very__long_variable02: very____long_____string___identifier; + very__long_variable03: very____long_____string___identifier; + very__long_variable04: very____long_____string___identifier; + very__long_variable05: very____long_____string___identifier; + very__long_variable06: very____long_____string___identifier; + very__long_variable07: very____long_____string___identifier; + very__long_variable08: very____long_____string___identifier; + very__long_variable09: very____long_____string___identifier; + very__long_variable10: very____long_____string___identifier; + very__long_variable11: very____long_____string___identifier; + very__long_variable12: very____long_____string___identifier; + very__long_variable13: very____long_____string___identifier; + very__long_variable14: very____long_____string___identifier; + very__long_variable15: very____long_____string___identifier; + very__long_variable16: very____long_____string___identifier; + very__long_variable17: very____long_____string___identifier; + very__long_variable18: very____long_____string___identifier); +begin + writeln('hi!'); +end; + +var + p : pointer; + +begin + writeln('vreemd!'); + test('','','','','','','','','','', + '','','','','','','',''); + p:=@test; +end. + + + diff --git a/tests/tbs/tb0242.pp b/tests/tbs/tb0242.pp new file mode 100644 index 0000000000..5a55143d26 --- /dev/null +++ b/tests/tbs/tb0242.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0283.pp } +{ bugs in constant char comparison evaluation OK 0.99.13 (PFV) } + +const dirsep = '\'; + +begin + if dirsep = '/' + then + begin + writeln('bug!'); + Halt(1); + end + else + writeln('ok'); +end. diff --git a/tests/tbs/tb0243.pp b/tests/tbs/tb0243.pp new file mode 100644 index 0000000000..aaa0b511aa --- /dev/null +++ b/tests/tbs/tb0243.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0284b.pp } +{ } + +unit tb0243; +interface +type + o1=object + p : longint; + end; + +implementation +end. diff --git a/tests/tbs/tb0244.pp b/tests/tbs/tb0244.pp new file mode 100644 index 0000000000..a046552549 --- /dev/null +++ b/tests/tbs/tb0244.pp @@ -0,0 +1,22 @@ +{ %CPU=i386 } +{ Old file: tbs0285.pp } +{ Asm, TYPE not support in intel mode OK 0.99.13 (PFV) } + +{$asmmode intel} + +TYPE something = RECORD big:LONGINT; small:BYTE; END; + +FUNCTION typesize:INTEGER; ASSEMBLER; +ASM + MOV EAX, TYPE something +END; + +BEGIN + writeln(typesize); + if typesize<>sizeof(something) then + begin + Writeln('Error in type inside intel asm'); + Halt(1); + end; +END. + diff --git a/tests/tbs/tb0245.pp b/tests/tbs/tb0245.pp new file mode 100644 index 0000000000..453cd58a5b --- /dev/null +++ b/tests/tbs/tb0245.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0286.pp } +{ #$08d not allowed as Char constant OK 0.99.13 (PFV) } + +var + c : char; +begin + c:=#$08d; +end. diff --git a/tests/tbs/tb0246.pp b/tests/tbs/tb0246.pp new file mode 100644 index 0000000000..e99afa0c28 --- /dev/null +++ b/tests/tbs/tb0246.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0287.pp } +{ (true > false) not supported OK 0.99.13 (PFV) } + +var + b,bb : boolean; +begin + b:=(true > false); + if b then + writeln('ok 1') + else + halt(1); + b:=true; + b:=(b > false); + if b then + writeln('ok 2') + else + halt(1); + b:=false; + bb:=true; + if b<bb then + writeln('ok 3') + else + halt(1); +end. diff --git a/tests/tbs/tb0247.pp b/tests/tbs/tb0247.pp new file mode 100644 index 0000000000..6b696e1515 --- /dev/null +++ b/tests/tbs/tb0247.pp @@ -0,0 +1,39 @@ +{ Old file: tbs0288.pp } +{ crash with virtual method in except part OK 0.99.13 (PFV) } + +{$mode objfpc} + +uses sysutils; +const + test_run : boolean = false; + +type + zz=class(tobject) + procedure test;virtual; + procedure test1;virtual; + end; +procedure zz.test; +begin + writeln('ok'); + test_run:=true; +end; +procedure zz.test1; +begin + try + raise exception.create('zz'); + except + on e:exception do test; + end; +end; +var + z:zz; +begin + z:=zz.create; + z.test1; + z.destroy; + if not test_run then + begin + Writeln('Problem with virtual method in except block'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0248.pp b/tests/tbs/tb0248.pp new file mode 100644 index 0000000000..41055d656b --- /dev/null +++ b/tests/tbs/tb0248.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0289.pp } +{ no hint/note for unused types : implemented with -vnh OK 0.99.13 (PM) } + + +procedure p; +type + k1 = word; +begin +end; + +type + k2 = word; +begin +end. diff --git a/tests/tbs/tb0249.pp b/tests/tbs/tb0249.pp new file mode 100644 index 0000000000..125c2e25f0 --- /dev/null +++ b/tests/tbs/tb0249.pp @@ -0,0 +1,14 @@ +unit tb0249; + +interface +type + rec=object + i : longint; + nrs : (one,two,three); + end; +var + brec : rec; + +implementation + +end. diff --git a/tests/tbs/tb0250.pp b/tests/tbs/tb0250.pp new file mode 100644 index 0000000000..2aabe9e6c3 --- /dev/null +++ b/tests/tbs/tb0250.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0290.pp } +{ problem with storing hex numbers in integers } + +{ $R+ would give compile time errors } +{$R-} + +var i,j : integer; + +begin + { the following line gives a warning and $ffff is changed to $7fff!} + i := $ffff; + if i <> $ffff then + begin + Writeln('i:=$ffff loads ',i,'$7fff if i is integer !'); + end; + j := 65535; + if j <> 65535 then + begin + Writeln('j:=65535 loads ',j,' if j is integer !'); + end; + if ($ffff=65535) and (i<>j) then + begin + Writeln('i and j are different !!!'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0251.pp b/tests/tbs/tb0251.pp new file mode 100644 index 0000000000..1d4ffb782c --- /dev/null +++ b/tests/tbs/tb0251.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0291.pp } +{ @procvar in tp mode bugss OK 0.99.13 (PFV) } + +{$ifdef fpc}{$mode tp}{$endif} + +function ReturnString: string; +begin + ReturnString := 'A string'; +end; + +procedure AcceptString(S: string); +begin + WriteLn('Got: ', S); + if S<>'A string' then + begin + writeln('ERROR!'); + halt(1); + end; +end; + +type + TStringFunc = function: string; + +const + SF: TStringFunc = ReturnString; +var + S2: TStringFunc; +begin + @S2:=@ReturnString; + AcceptString(ReturnString); + AcceptString(SF); + AcceptString(S2); +end. diff --git a/tests/tbs/tb0252.pp b/tests/tbs/tb0252.pp new file mode 100644 index 0000000000..ee8d76f542 --- /dev/null +++ b/tests/tbs/tb0252.pp @@ -0,0 +1,50 @@ +{ Old file: tbs0292.pp } +{ objects not finalized when disposed OK 0.99.13 (FK) } + +{$mode objfpc} + +type + pobj = ^tobj; + tobj = object + a: ansistring; + constructor init(s: ansistring); + destructor done; + end; + + PAnsiRec = ^TAnsiRec; + TAnsiRec = Packed Record + Maxlen, + len, + ref : Longint; + First : Char; + end; + +const firstoff = sizeof(tansirec)-1; + +var o: pobj; + t: ansistring; + +constructor tobj.init(s: ansistring); +begin + a := s; +end; + +destructor tobj.done; +begin +end; + +const + s : string = ' with suffix'; +var + refbefore : longint; +begin + t:='test'+s; + refbefore:=pansirec(pointer(t)-firstoff)^.ref; + writeln('refcount before init: ',pansirec(pointer(t)-firstoff)^.ref); + new(o,init(t)); + writeln('refcount after init: ',pansirec(pointer(t)-firstoff)^.ref); + dispose(o,done); + writeln('refcount after done: ',pansirec(pointer(t)-firstoff)^.ref); + if refbefore<>pansirec(pointer(t)-firstoff)^.ref then + Halt(1); +end. diff --git a/tests/tbs/tb0254.pp b/tests/tbs/tb0254.pp new file mode 100644 index 0000000000..03573d6b4b --- /dev/null +++ b/tests/tbs/tb0254.pp @@ -0,0 +1,42 @@ +{ Old file: tbs0294.pp } +{ parameter with the same name as function is allowed in tp7/delphi Yes, but in BP this leads to being unable to set the return value ! } + +{$mode tp} +{ this is allowed in BP !!! + but its complete nonsense because + this code sets parameter test + so the return value can not be set at all !!!!! + of course in Delphi you can use result so there it + makes sense to allow this ! PM } +function test(var test:longint):longint; +var + x : longint; +begin + { in BP the arg is change here !! } + test:=1; + x:=3; +end; + +function st(var st : string) : string; +begin + st:='OK'; +end; + +var t : longint; + myst : string; +begin + t:=2; + myst:='Before'; + test(t); + st(myst); + if (t<>1) then + begin + writeln('Test arg in Test function is not handled like in BP'); + halt(1); + end; + if (myst<>'OK') then + begin + writeln('St arg in St string function is not handled like in BP'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0255.pp b/tests/tbs/tb0255.pp new file mode 100644 index 0000000000..09cdacd997 --- /dev/null +++ b/tests/tbs/tb0255.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0295.pp } +{ forward type definition is resolved wrong OK 0.99.13 (PFV) } + +type + t1=longint; + +procedure p; +type + pt1=^t1; + t1=string; +var + t : t1; + p : pt1; +begin + p:=@t; + p^:='test'; +end; + +begin + p; +end. diff --git a/tests/tbs/tb0256.pp b/tests/tbs/tb0256.pp new file mode 100644 index 0000000000..30d6b98b2b --- /dev/null +++ b/tests/tbs/tb0256.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0296.pp } +{ exit(string) does not work (web form bugs 613) OK 0.99.13 (PM) } + + +function test : string; + + begin + test:='This should not be printed'; + exit('this should be printed'); + end; + +begin + writeln(test); + if test<>'this should be printed' then + Halt(1); +end. diff --git a/tests/tbs/tb0257.pp b/tests/tbs/tb0257.pp new file mode 100644 index 0000000000..495de55242 --- /dev/null +++ b/tests/tbs/tb0257.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0297.pp } +{ calling of interrupt procedure allowed but wrong code generated OK 0.99.13 (PM) } + +program test_int; + +procedure int;interrupt; +begin +end; + +begin + int; +end. diff --git a/tests/tbs/tb0258.pp b/tests/tbs/tb0258.pp new file mode 100644 index 0000000000..09205f4b54 --- /dev/null +++ b/tests/tbs/tb0258.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0299.pp } +{ passing Array[0..1] of char by value to proc leads to problems OK 0.99.13 (PM) +passing Array[0..1] of char by value to proc leads to problems } + +type + TwoChar = Array[0..1] of char; + Empty = Record + End; +const + asd : TwoChar = ('a','b'); + +procedure Tester(i:TwoChar; a: Empty;l : longint;var ll : longint); +begin + i[0]:=i[1]; + Writeln('l = ',l,' @l = ',hexstr(longint(@l),8),' @a = ',hexstr(longint(@a),8)); + inc(ll); +end; + +var + a : Empty; + l,ll : longint; +begin + l:=6; + ll:=15; + Writeln(Sizeof(asd)); + Tester(asd,a,l,ll); + Writeln(asd); + if (ll<>16) then + Begin + Writeln('Error with passing value parameter of type array [1..2] of char'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0259.pp b/tests/tbs/tb0259.pp new file mode 100644 index 0000000000..1f540903fc --- /dev/null +++ b/tests/tbs/tb0259.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0302.pp } +{ inherited property generates wrong assembler OK 0.99.13 (PFV) } + +{$ifdef fpc}{$mode objfpc}{$endif} +type + c1=class + Ffont : longint; + property Font:longint read Ffont; + end; + + c2=class(c1) + function GetFont:longint; + end; + +function c2.GetFont:longint; +begin + result:=Font; + result:=inherited Font; +end; + +begin +end. diff --git a/tests/tbs/tb0260.pp b/tests/tbs/tb0260.pp new file mode 100644 index 0000000000..c1287e61ed --- /dev/null +++ b/tests/tbs/tb0260.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0303.pp } +{ One more InternalError(10) out of register ! OK 0.99.13 (FK) } + + + type + intarray = array[1..1000,0..1] of longint; + + procedure test; + var + ar : intarray; + i : longint; + procedure local; + begin + i:=4; + ar[i,0]:=56; + ar[i-1,0]:=pred(ar[i,0]); + end; + begin + local; + end; + +begin + test; +end. diff --git a/tests/tbs/tb0261.pp b/tests/tbs/tb0261.pp new file mode 100644 index 0000000000..0d5c6e73eb --- /dev/null +++ b/tests/tbs/tb0261.pp @@ -0,0 +1,34 @@ +{ %CPU=i386 } +{ Old file: tbs0304.pp } +{ Label redefined when inlining assembler OK 0.99.13 (PFV) } + +{$asmmode intel} +{$inline on} + +var + cb : word; + +procedure A(B: word); assembler; inline; +{$ifdef CPUI386} +asm + MOV AX,B + CMP AX,[CB] + JZ @@10 + MOV [CB],AX +@@10: +end; +{$endif CPUI386} +{$ifdef CPU68K} +asm + move.w b,d0 + cmp.w cb,d0 + beq @L10 + move.w d0,cb +@L10: +end; +{$endif CPU68K} + +begin + a(1); + a(2); +end. diff --git a/tests/tbs/tb0262.pp b/tests/tbs/tb0262.pp new file mode 100644 index 0000000000..86ba125acb --- /dev/null +++ b/tests/tbs/tb0262.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0305.pp } +{ Finally is not handled correctly after inputting 0 } + +{$mode objfpc} +uses + sysutils; + +var i,j,k:real; +const except_called : boolean = false; +begin + i:=100; + j:=0; + try + k:=i/j; + writeln(k:5:3); + except + k:=0; + writeln('Illegal Input'); + except_called:=true; + end; + if not except_called then + begin + Writeln('Error in except handling'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0263.pp b/tests/tbs/tb0263.pp new file mode 100644 index 0000000000..93382f6fa5 --- /dev/null +++ b/tests/tbs/tb0263.pp @@ -0,0 +1,50 @@ +{ %RESULT=217 } + +{ Old file: tbs0306.pp } +{ Address is not popped with exit in try...except block OK 0.99.13 (PFV) } + +{$MODE objfpc} +{$H+} + +{ + Don't forget break,continue support +} + +program stackcrash; +uses sysutils; +type + TMyClass = class + public + procedure Proc1; + procedure Proc2; + end; + +procedure TMyClass.Proc1; +var + x, y: Integer; +begin + try + exit; + except + on e: Exception do begin e.Message := '[Proc1]' + e.Message; raise e end; + end; +end; + +procedure TMyClass.Proc2; +var + x: array[0..7] of Byte; + crash: Boolean; +begin + crash := True; // <--- ! This corrupts the stack?!? + raise Exception.Create('I will crash now...'); +end; + +var + obj: TMyClass; +begin + obj := TMyClass.Create; + obj.Proc1; + WriteLn('Proc1 done, calling Proc2...'); + obj.Proc2; + WriteLn('Proc2 done'); +end. diff --git a/tests/tbs/tb0264.pp b/tests/tbs/tb0264.pp new file mode 100644 index 0000000000..981b661141 --- /dev/null +++ b/tests/tbs/tb0264.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0307.pp } +{ "with object_type" doesn't work correctly! OK 0.99.13 (?) } + +type + tobj = object + l: longint; + constructor init; + procedure setV(v: longint); + destructor done; + end; + +constructor tobj.init; +begin + l := 0; +end; + +procedure tobj.setV(v: longint); +begin + l := v; +end; + +destructor tobj.done; +begin +end; + +var t: tobj; + +begin + t.init; + with t do + setV(5); + writeln(t.l, ' (should be 5!)'); + if t.L<>5 then + Halt(1); + t.done; +end. diff --git a/tests/tbs/tb0265.pp b/tests/tbs/tb0265.pp new file mode 100644 index 0000000000..df6014bba1 --- /dev/null +++ b/tests/tbs/tb0265.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0308.pp } +{ } + +uses ub0265; + +begin + writeln(coursedb.name(60)); +end. diff --git a/tests/tbs/tb0267.pp b/tests/tbs/tb0267.pp new file mode 100644 index 0000000000..83337268a5 --- /dev/null +++ b/tests/tbs/tb0267.pp @@ -0,0 +1,85 @@ +{ %CPU=i386 } +{ Old file: tbs0309.pp } +{ problem with ATT assembler written by bin writer OK 0.99.14 (PFV) } + +{ This code was first written by Florian + to test the GDB output for FPU + he thought first that FPU output was wrong + but in fact it is a bug in FPC :( } +program bug0309; + +var + a,b : double; + _as,bs : single; + al,bl : extended; + aw,bw : integer; + ai,bi : longint; + ac : comp; +begin +{$ifdef CPU86} +{$asmmode att} + asm + fninit; + end; + a:=1; + b:=2; + asm + movl $1,%eax + fldl a + fldl b + faddp %st,%st(1) + fstpl a + end; + { the above generates wrong code in binary writer + fldl is replaced by flds !! + if using -alt option to force assembler output + all works correctly PM } + writeln('a = ',a,' should be 3'); + if a<>3.0 then + Halt(1); + a:=1.0; + a:=a+b; + writeln('a = ',a,' should be 3'); + _as:=0; + al:=0; + asm + fldl a + fsts _as + fstpt al + end; + if (_as<>3.0) or (al<>3.0) then + Halt(1); + ai:=5; + bi:=5; + asm + fildl ai + fstpl a + end; + if a<>5.0 then + Halt(1); + + ac:=5; + asm + fildl ai + fstpl a + end; + if a<>5.0 then + Halt(1); + aw:=-4; + bw:=45; + asm + fildw aw + fstpl a + end; + if a<>-4.0 then + Halt(1); + ac:=345; + asm + fildq ac + fstpl a + end; + if a<>345.0 then + Halt(1); + +{$endif CPU86} +end. diff --git a/tests/tbs/tb0268.pp b/tests/tbs/tb0268.pp new file mode 100644 index 0000000000..083f4b775b --- /dev/null +++ b/tests/tbs/tb0268.pp @@ -0,0 +1,147 @@ +{ Old file: tbs0312.pp } +{ Again the problem of local procs inside methods } + +{ Program that showss a problem if + Self is not reloaded in %esi register + at entry in local procedure inside method } + +uses + objects; + +type +{$ifndef FPC} + sw_integer = integer; +{$endif not FPC} + + PMYObj = ^TMyObj; + + TMyObj = Object(TObject) + x : longint; + Constructor Init(ax : longint); + procedure display;virtual; + end; + + PMYObj2 = ^TMyObj2; + + TMyObj2 = Object(TMyObj) + y : longint; + Constructor Init(ax,ay : longint); + procedure display;virtual; + end; + + PMyCollection = ^TMyCollection; + + TMyCollection = Object(TCollection) + function At(I : sw_integer) : PMyObj; + procedure DummyThatShouldNotBeCalled;virtual; + end; + + { TMy is also a TCollection so that + ShowMy and DummyThatShouldNotBeCalled are at same position in VMT } + TMy = Object(TCollection) + Col : PMyCollection; + MyObj : PMyObj; + ShowMyCalled : boolean; + constructor Init; + destructor Done;virtual; + procedure ShowAll; + procedure AddMyObj(x : longint); + procedure AddMyObj2(x,y : longint); + procedure ShowMy;virtual; + end; + + Constructor TMyObj.Init(ax : longint); + begin + Inherited Init; + x:=ax; + end; + + Procedure TMyObj.Display; + begin + Writeln('x = ',x); + end; + + Constructor TMyObj2.Init(ax,ay : longint); + begin + Inherited Init(ax); + y:=ay; + end; + + Procedure TMyObj2.Display; + begin + Writeln('x = ',x,' y = ',y); + end; + + Function TMyCollection.At(I : sw_integer) : PMyObj; + begin + At:=Inherited At(I); + end; + + Procedure TMyCollection.DummyThatShouldNotBeCalled; + begin + Writeln('This method should never be called'); + Abstract; + end; + + Constructor TMy.Init; + + begin + New(Col,Init(5,5)); + MyObj:=nil; + ShowMyCalled:=false; + end; + + Destructor TMy.Done; + begin + Dispose(Col,Done); + Inherited Done; + end; + + Procedure TMy.ShowAll; + + procedure ShowIt(P : pointer);{$ifdef TP}far;{$endif} + begin + ShowMy; + PMyObj(P)^.Display; + end; + begin + Col^.ForEach(@ShowIt); + end; + + Procedure TMy.ShowMy; + begin + if assigned(MyObj) then + MyObj^.Display; + ShowMyCalled:=true; + end; + + Procedure TMy.AddMyObj(x : longint); + + begin + MyObj:=New(PMyObj,Init(x)); + Col^.Insert(MyObj); + end; + + Procedure TMy.AddMyObj2(x,y : longint); + begin + MyObj:=New(PMyObj2,Init(x,y)); + Col^.Insert(MyObj); + end; + +var + My : TMy; +begin + My.Init; + My.AddMyObj(5); + My.AddMyObj2(4,3); + My.AddMyObj(43); + { MyObj field is now a PMyObj with value 43 } + My.ShowAll; + If not My.ShowMyCalled then + begin + Writeln('ShowAll does not work correctly'); + Halt(1); + end; + My.Done; + +end. diff --git a/tests/tbs/tb0269.pp b/tests/tbs/tb0269.pp new file mode 100644 index 0000000000..7ea6324c89 --- /dev/null +++ b/tests/tbs/tb0269.pp @@ -0,0 +1,29 @@ +{ %CPU=i386} + +{ Old file: tbs0313.pp } +{ } + + {$asmmode intel} + TYPE + TPoint3 = RECORD + x,y,z:Single; + END; + + OPERATOR + (CONST p1,p2:TPoint3) p : TPoint3; Assembler; + ASM + mov EBX,[p1] + mov EDI,[p2] + mov EDX,[p] + movq MM0,[EBX] + pfadd MM0,[EDI] + movq [EDX],MM0 + { Now the correct way would be something like: } + movd MM0,[EBX+8] // [movd reg??,mem?? - invalid combination of opcod + movd MM1,[EDI+8] // and here, too + pfadd MM0,MM1 + movd [EDX+8],MM0 // and here + femms + END; + +begin +end. diff --git a/tests/tbs/tb0270.pp b/tests/tbs/tb0270.pp new file mode 100644 index 0000000000..95fa12dbf6 --- /dev/null +++ b/tests/tbs/tb0270.pp @@ -0,0 +1,24 @@ +{ %CPU=i386 } +{ Old file: tbs0316.pp } +{ } + +{$asmmode intel} + +procedure test(b : longint); assembler; +type + splitlong = packed record b1, b2, b3, b4 : Byte; end; +asm + mov splitlong(b).b2, al +end; + +{$asmmode att} + +procedure test2(b : longint); assembler; +type + splitlong = packed record b1, b2, b3, b4 : Byte; end; +asm + movb splitlong(b).b2, %al +end; + +begin +end. diff --git a/tests/tbs/tb0271.pp b/tests/tbs/tb0271.pp new file mode 100644 index 0000000000..621fce29ba --- /dev/null +++ b/tests/tbs/tb0271.pp @@ -0,0 +1,10 @@ +{ %OPT= -Sen } + +{ Old file: tbs0317.pp } + +{ This shouldn't give a warning, because it can be used in an other program } +var + exportedc : longint;cvar;public; +begin + exportedc:=0; +end. diff --git a/tests/tbs/tb0272.pp b/tests/tbs/tb0272.pp new file mode 100644 index 0000000000..407400d803 --- /dev/null +++ b/tests/tbs/tb0272.pp @@ -0,0 +1,15 @@ +{ %OPT=-Sen -vnw } +{ %RESULT=217 } + +{ Old file: tbs0318.pp } + +{$mode objfpc} +uses sysutils; + +{ The exception is used in the raise statement, so no Note should be thrown } +var + e : exception; +begin + e:=exception.create('test'); + raise e; +end. diff --git a/tests/tbs/tb0273.pp b/tests/tbs/tb0273.pp new file mode 100644 index 0000000000..fc3668bf96 --- /dev/null +++ b/tests/tbs/tb0273.pp @@ -0,0 +1,69 @@ +{ Old file: tbs0319.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +function a:longint; +var + a : longint; +begin + a:=1; +end; + +type + cl=class + k : longint; + procedure p1; + procedure p2; + end; + + o = class + nonsense :string; + procedure flup(nonsense:string); + end; + + o2 = class + nonsense :string; + procedure flop; + procedure flup(nonsense:longint); + procedure flup2(flop:longint); + end; + +procedure o.flup(nonsense:string); +begin +end; + +procedure o2.flop; +begin +end; + +procedure o2.flup(nonsense:longint); +var + l : longint; +begin + l:=nonsense; +end; + +procedure o2.flup2(flop:longint); +var + l : longint; +begin + l:=flop; + flup(flop); +end; + + +procedure cl.p1; +var + k : longint; +begin +end; + +procedure cl.p2; +var + p1 : longint; +begin +end; + +begin +end. diff --git a/tests/tbs/tb0274.pp b/tests/tbs/tb0274.pp new file mode 100644 index 0000000000..86835b8fa4 --- /dev/null +++ b/tests/tbs/tb0274.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0321.pp } +{ } + +{$mode delphi} +type + tfunc = function : longint stdcall; + +begin +end. diff --git a/tests/tbs/tb0275.pp b/tests/tbs/tb0275.pp new file mode 100644 index 0000000000..1d7014ded7 --- /dev/null +++ b/tests/tbs/tb0275.pp @@ -0,0 +1,28 @@ +{ %CPU=i386 } +{ Old file: tbs0322.pp } +{ } + +{$ifdef fpc}{$asmmode intel}{$endif} +var + boxes : record + pbox : longint; + pbox2 : longint; + end; +var + s1,s2 : longint; +begin +asm + mov s1,type boxes.pbox + mov s2,type boxes +end; + if s1<>sizeof(boxes.pbox) then + begin + writeln('Wrong size for TYPE'); + halt(1); + end; + if s2<>sizeof(boxes) then + begin + writeln('Wrong size for TYPE'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0276.pp b/tests/tbs/tb0276.pp new file mode 100644 index 0000000000..d5d37513e2 --- /dev/null +++ b/tests/tbs/tb0276.pp @@ -0,0 +1,55 @@ +{ Old file: tbs0327.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} +unit tb0276; +interface + +type + tc=class + procedure l(i:integer);overload; + procedure l(s:string);overload; + end; + + procedure l2(i:integer);overload; + procedure l2(s:string);overload; + +implementation + + procedure l3(i:integer);forward;overload; + procedure l3(s:string);forward;overload; + +procedure tc.l(i:integer); +begin +end; + +procedure tc.l(s:string); +begin +end; + +procedure l2(i:integer); +begin +end; + +procedure l2(s:string); +begin +end; + +procedure l3(i:integer);overload; +begin +end; + +procedure l3(s:string); +begin +end; + +procedure k(l:longint);overload; +begin +end; + +procedure k(l:string);overload; +begin +end; + +begin +end. diff --git a/tests/tbs/tb0277.pp b/tests/tbs/tb0277.pp new file mode 100644 index 0000000000..8f848992fa --- /dev/null +++ b/tests/tbs/tb0277.pp @@ -0,0 +1,72 @@ +{ Old file: tbs0329.pp } +{ } + +{$packrecords c} + +type + SHORT=smallint; + WINBOOL = longbool; + WCHAR=word; + UINT=cardinal; + + COORD = record + X : SHORT; + Y : SHORT; + end; + + KEY_EVENT_RECORD = packed record + bKeyDown : WINBOOL; + wRepeatCount : WORD; + wVirtualKeyCode : WORD; + wVirtualScanCode : WORD; + case longint of + 0 : ( UnicodeChar : WCHAR; + dwControlKeyState : DWORD; ); + 1 : ( AsciiChar : CHAR ); + end; + + MOUSE_EVENT_RECORD = record + dwMousePosition : COORD; + dwButtonState : DWORD; + dwControlKeyState : DWORD; + dwEventFlags : DWORD; + end; + + WINDOW_BUFFER_SIZE_RECORD = record + dwSize : COORD; + end; + + MENU_EVENT_RECORD = record + dwCommandId : UINT; + end; + + FOCUS_EVENT_RECORD = record + bSetFocus : WINBOOL; + end; + + INPUT_RECORD = record + EventType : WORD; + case longint of + 0 : ( KeyEvent : KEY_EVENT_RECORD ); + 1 : ( MouseEvent : MOUSE_EVENT_RECORD ); + 2 : ( WindowBufferSizeEvent : WINDOW_BUFFER_SIZE_RECORD ); + 3 : ( MenuEvent : MENU_EVENT_RECORD ); + 4 : ( FocusEvent : FOCUS_EVENT_RECORD ); + end; + +const +{$ifdef cpu68k} + { GNU C only aligns at word boundaries + for m68k cpu PM } + correct_size = 18; +{$else } + correct_size = 20; +{$endif } +begin + if sizeof(INPUT_RECORD)<>correct_size then + begin + writeln('Wrong packing for Packrecords C and union ',sizeof(INPUT_RECORD),' instead of ',correct_size); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0278.pp b/tests/tbs/tb0278.pp new file mode 100644 index 0000000000..e84b57a964 --- /dev/null +++ b/tests/tbs/tb0278.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0330.pp } +{ } + +{$ifdef fpc}{$mode objfpc}{$endif} +uses + Classes; + +type + TMyClass = class(TPersistent); + +var + MyVar: Integer; + + +type + TMyClass2 = class(TObject) + procedure MyProc; + end; + + TMyOtherClass = class(TPersistent); + +procedure TMyClass2.MyProc; +var + MyImportantVar: Integer; +begin +end; + +begin +end. diff --git a/tests/tbs/tb0279.pp b/tests/tbs/tb0279.pp new file mode 100644 index 0000000000..8511799638 --- /dev/null +++ b/tests/tbs/tb0279.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0331.pp } +{ } + +{$mode tp} +unit tb0279; + + interface + + procedure a(s : string); + + implementation + + procedure a; + + begin + end; + +end. diff --git a/tests/tbs/tb0280.pp b/tests/tbs/tb0280.pp new file mode 100644 index 0000000000..a9e12a7158 --- /dev/null +++ b/tests/tbs/tb0280.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0332.pp } +{ } + +{$MODE objfpc} +uses Classes; +var + o: TComponent; + begin + o := TComponent(TComponent.NewInstance); + o.Create(nil); + o.Free; + end. + + diff --git a/tests/tbs/tb0281.pp b/tests/tbs/tb0281.pp new file mode 100644 index 0000000000..fbb514134b --- /dev/null +++ b/tests/tbs/tb0281.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0333.pp } +{ } + +{$if not(defined(CPUI386)) and not(defined(CPUX86_64))} + {$define COMP_IS_INT64} +{$endif} + + +var + a,b : comp; + s1,s2 : string; +begin + a:=11384563; + b:=a*a; +{$ifdef COMP_IS_INT64} + str(a*a,s1); + str(b,s2); +{$else not COMP_IS_INT64} + str(a*a:0:0,s1); + str(b:0:0,s2); +{$endif COMP_IS_INT64} + writeln(s1); + writeln(s2); + if (s1<>'129608274700969') or (s2<>'129608274700969') then + begin + writeln('Error with comp type rounding'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0282.pp b/tests/tbs/tb0282.pp new file mode 100644 index 0000000000..fd91b7f07b --- /dev/null +++ b/tests/tbs/tb0282.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0334.pp } +{ } + +{$ifdef fpc}{$mode objfpc}{$endif} + +type + tvarrec=record + vpointer : pointer; + end; +var + r : tvarrec; + b : boolean; +function Next: TVarRec; +begin + next:=r; +end; + +begin + r.vpointer:=@b; + { The result of next is loaded and a value is assigned } + with Next do + boolean(VPointer^) := true; + if not b then + writeln('Error with assigning to function result'); +end. diff --git a/tests/tbs/tb0283.pp b/tests/tbs/tb0283.pp new file mode 100644 index 0000000000..aa5aee4e55 --- /dev/null +++ b/tests/tbs/tb0283.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0335.pp } +{ } + +{$mode delphi} +procedure f;stdcall export; +asm +end; + +begin +end. diff --git a/tests/tbs/tb0284.pp b/tests/tbs/tb0284.pp new file mode 100644 index 0000000000..a5f36c623f --- /dev/null +++ b/tests/tbs/tb0284.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0336.pp } +{ } + +{$mode objfpc} +Uses classes,sysutils; + + +const dsmerged=0; + dsopenerror=1; + dscreateerror=2; + dsconverterror=3; + dsmismatcherror=4; + dscrcerror=5; + dserror=6; + +type tvsmergediffs=class + procedure execute; + end; + + tvsdiffitem= class + status : longint; + end; + +EMismatchedDiffError =class(exception); +EDiffCrcCompareError= class(exception); + +procedure TvsMergeDiffs.Execute; +var + Stream: tFileStream; + Item: TvsDiffItem; + a : longint; +begin + try + Item.Status := dsMerged; + except + { Only the number of on xx do statements seems to matter, not + which ones, try commenting 3 or 4 out} + on EFOpenError do Item.Status := dsOpenError; + on EFCreateError do Item.Status := dsCreateError; + on EConvertError do Item.Status := dsConvertError; + on EMismatchedDiffError do Item.Status := dsMismatchError; + on EDiffCrcCompareError do Item.Status := dsCrcError; + on Exception do Item.Status := dsError; + end; +end; + +begin +end. diff --git a/tests/tbs/tb0285.pp b/tests/tbs/tb0285.pp new file mode 100644 index 0000000000..f24d8707cb --- /dev/null +++ b/tests/tbs/tb0285.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0337.pp } +{ } + +program vartest; + +{$ifdef fpc}{$mode objfpc}{$endif} + +uses + Classes; + +type + TMyComponent = class(TComponent) + aaaaaaaaaa: TComponent; + b: TComponent; + private + public + constructor Create(AOwner: TComponent); override; + end; + + +constructor TMyComponent.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + aaaaaaaaaa := TComponent.Create(Self); +end; + +var + MyComponent: TMyComponent; + +begin + MyComponent := TMyComponent.Create(nil); +end. diff --git a/tests/tbs/tb0286.pp b/tests/tbs/tb0286.pp new file mode 100644 index 0000000000..e7756e30a7 --- /dev/null +++ b/tests/tbs/tb0286.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0338.pp } +{ } + +{$mode delphi} + +{$define skip} + +begin + writeln('Hello world!'); +{$ifndef skip} + write('}'); +{$endif skip} +end. diff --git a/tests/tbs/tb0287.pp b/tests/tbs/tb0287.pp new file mode 100644 index 0000000000..b4e88712b4 --- /dev/null +++ b/tests/tbs/tb0287.pp @@ -0,0 +1,23 @@ +{ %OPT=-Sen } + +{ Old file: tbs0339.pp } + +type + rec=record + x,y : longint; + end; +var + r : array[1..10] of rec; + i : longint; +begin + i:=1; + with r[i] do + begin + x:=1; + y:=1; + end; + with r[i] do + begin + writeln(x,y); + end; +end. diff --git a/tests/tbs/tb0288.pp b/tests/tbs/tb0288.pp new file mode 100644 index 0000000000..bd26791e89 --- /dev/null +++ b/tests/tbs/tb0288.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0340.pp } +{ } + +{$packenum 1} +type + t = (a,b,c,d,e); + +const arr: array[0..4] of t = (a,b,c,d,e); + +var + x: byte; + +begin + x := 0; + writeln(ord(arr[x]),' ',ord(arr[x+1]),' ',ord(arr[x+2]),' ',ord(arr[x+3]),' ',ord(arr[x+4])); + for x:=0 to 4 do + if ord(arr[x])<>x then + begin + writeln('error in {$packenum 1}'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0289.pp b/tests/tbs/tb0289.pp new file mode 100644 index 0000000000..ecf663470e --- /dev/null +++ b/tests/tbs/tb0289.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0341.pp } +{ } + +procedure IncLimit(var B: Byte; const Limit: Byte; const Incr: Byte); +begin +end; +procedure IncLimit(var B: Longint; const Limit: Longint; const Incr: Longint); +begin +end; + +var + b : byte; +begin + inclimit(b,128,3); +end. + diff --git a/tests/tbs/tb0290.pp b/tests/tbs/tb0290.pp new file mode 100644 index 0000000000..69ea5dc291 --- /dev/null +++ b/tests/tbs/tb0290.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0344.pp } +{ } + +var + r : record + word : array[1..2] of word; + end; +begin +end. diff --git a/tests/tbs/tb0292.pp b/tests/tbs/tb0292.pp new file mode 100644 index 0000000000..59a37776df --- /dev/null +++ b/tests/tbs/tb0292.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0346b.pp } +{ } + +unit tb0292; +interface + +{ this uses system.word } +procedure p(w:word); + +implementation +uses + ub0292; + +{ this uses tbs0346a.word } +procedure p(w:word); +begin +end; + +end. diff --git a/tests/tbs/tb0293.pp b/tests/tbs/tb0293.pp new file mode 100644 index 0000000000..b4c16fc500 --- /dev/null +++ b/tests/tbs/tb0293.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0348.pp } +{ } + +{$mode delphi} + +type fluparr=array[0..1000] of longint; + flupptr=^fluparr; + +var flup : Flupptr; + Flupresult : longint; + flupa : fluparr; +begin + flup:=@flupa; + flupresult:=flup[5]; +end. diff --git a/tests/tbs/tb0294.pp b/tests/tbs/tb0294.pp new file mode 100644 index 0000000000..c50eff3af3 --- /dev/null +++ b/tests/tbs/tb0294.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0350.pp } +{ } + +var + c : char; + i : integer; +begin + i:=integer(c); + c:=char(i); +end. + diff --git a/tests/tbs/tb0295.pp b/tests/tbs/tb0295.pp new file mode 100644 index 0000000000..0fe270016d --- /dev/null +++ b/tests/tbs/tb0295.pp @@ -0,0 +1,28 @@ +{ %VERSION=1.1 } + +{ Old file: tbs0353.pp } +{ } + +Var + I : Int64; + j : longint; + K : Int64; + err : boolean; +begin + I:=2; + Writeln(i); + K:=1 shl 62; + For j:=1 to 61 do + begin + I:=I*2; + If I/k*100>100 then + begin + Writeln('Error'); + err:=true; + end + else + Writeln(j:2,': ',i:20,' ',i div 1024:20,' ',(i/k*100):4:1); + end; + if err then + halt(1); +end. diff --git a/tests/tbs/tb0296.pp b/tests/tbs/tb0296.pp new file mode 100644 index 0000000000..e13f7c0bea --- /dev/null +++ b/tests/tbs/tb0296.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0355.pp } +{ } + +{MvdV; published in core. + Element that is in the type zz too is not recognised as such. + } + +type xx=(notinsubset1,insubset1,insubset2,notinsubset2); + zz=insubset1..insubset2; + + ll=record + yy:zz; + end; + +const oo : array[0..1] of ll = ( + (yy:insubset1), + (yy:insubset2)); +begin +end. + diff --git a/tests/tbs/tb0298.pp b/tests/tbs/tb0298.pp new file mode 100644 index 0000000000..ff6d15a5db --- /dev/null +++ b/tests/tbs/tb0298.pp @@ -0,0 +1,36 @@ +{$mode objfpc} +type + tobject1 = class + readl : longint; + function readl2 : longint; + procedure writel(ll : longint); + procedure writel2(ll : longint); + property l : longint read readl write writel; + property l2 : longint read readl2 write writel2; + end; + +procedure tobject1.writel(ll : longint); + + begin + end; + +procedure tobject1.writel2(ll : longint); + + begin + end; + +function tobject1.readl2 : longint; + + begin + end; + +var + object1 : tobject1; + i : longint; + +begin + object1:=tobject1.create; + i:=object1.l; + i:=object1.l2; + object1.l:=123; +end. diff --git a/tests/tbs/tb0299.pp b/tests/tbs/tb0299.pp new file mode 100644 index 0000000000..a11d2af11c --- /dev/null +++ b/tests/tbs/tb0299.pp @@ -0,0 +1,45 @@ +{$mode objfpc} +type + tmyclass = class of tmyobject; + + tmyobject = class + end; + +{ only a stupid test routine } +function getanchestor(c : tclass) : tclass; + + var + l : longint; + + begin + getanchestor:=tobject; + l:=l+1; + end; + +var + classref : tclass; + myclassref : tmyclass; + +const + constclassref1 : tclass = tobject; + constclassref2 : tclass = nil; + constclassref3 : tclass = tobject; + +begin + { simple test } + classref:=classref; + { more difficult } + classref:=myclassref; + classref:=tobject; + myclassref:=tmyobject; + + classref:=getanchestor(myclassref); + if (upcase(constclassref1.classname)<>'TOBJECT') or + (constclassref2<>nil) or + (upcase(myclassref.classname)<>'TMYOBJECT') or + (upcase(classref.classname)<>'TOBJECT') then + begin + writeln('Error'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0300.pp b/tests/tbs/tb0300.pp new file mode 100644 index 0000000000..b5ece15c3b --- /dev/null +++ b/tests/tbs/tb0300.pp @@ -0,0 +1,204 @@ +{$Mode objfpc} + +{ + This unit introduces some basic classes as they are defined in Delphi. + These classes should be source compatible to their Delphi counterparts: + TPersistent + TComponent +} + +Unit tb0300; + +{$M+} + +Interface + +Type + +{ --------------------------------------------------------------------- + Forward Declarations. + ---------------------------------------------------------------------} + + TComponent = Class; + TFiler = Class; + TPersistent = Class; + +{ --------------------------------------------------------------------- + TFiler + ---------------------------------------------------------------------} + + TFiler = Class (TObject) + Protected + FAncestor : TComponent; + FIgnoreChildren : Boolean; + FRoot : TComponent; + Private + Public + Published + { Methods } + Constructor Create {(Stream : TStream; BufSize : Longint) }; + Destructor Destroy; override; + Procedure FlushBuffer; virtual; abstract; + { Properties } + Property Root : TComponent Read FRoot Write FRoot; + Property Ancestor : TComponent Read FAncestor Write FAncestor; + Property IgnoreChildren : Boolean Read FIgnoreChildren Write FIgnoreChildren; + end; + +{ --------------------------------------------------------------------- + TPersistent + ---------------------------------------------------------------------} + + TPersistent = Class (TObject) + Private + Procedure AssignError (Source : TPersistent); + Protected + Procedure AssignTo (Dest : TPersistent); + Procedure DefineProperties (Filer : TFiler); Virtual; + Public + { Methods } + Destructor Destroy; Override; + Procedure Assign (Source : TPersistent); virtual; + Published + end; + +{ --------------------------------------------------------------------- + TComponent + ---------------------------------------------------------------------} + + TComponentState = Set of ( csLoading, csReading, CsWriting, csDestroying, + csDesigning, csAncestor, csUpdating, csFixups ); + TComponentStyle = set of ( csInheritable,csCheckPropAvail ); + TComponentName = String; + + TComponent = Class (TPersistent) + Protected + FComponentState : TComponentState; + FComponentStyle : TComponentStyle; + FName : TComponentName; + + FOwner : TComponent; + Function GetComponent (Index : Longint) : TComponent; + Function GetComponentCount : Longint; + Function GetComponentIndex : Longint; + Procedure SetComponentIndex (Value : Longint); + Procedure Setname (Value : TComponentName); + Private + Public + { Methods } + { Properties } + Property ComponentCount : Longint Read GetComponentCount; { RO } + Property ComponentIndex : Longint Read GetComponentIndex write SetComponentIndex; { R/W } + // Property Components [Index : LongInt] : TComponent Read GetComponent; { R0 } + Property ComponentState : TComponentState Read FComponentState; { RO } + Property ComponentStyle : TcomponentStyle Read FComponentStyle; { RO } + Property Owner : TComponent Read Fowner; { RO } + Published + Property Name : TComponentName Read FName Write Setname; + end; + + + + +Implementation + +{ --------------------------------------------------------------------- + TComponent + ---------------------------------------------------------------------} + +Function TComponent.GetComponent (Index : Longint) : TComponent; + +begin +end; + + + +Function TComponent.GetComponentCount : Longint; + +begin +end; + + + +Function TComponent.GetComponentIndex : Longint; + +begin +end; + + + +Procedure TComponent.SetComponentIndex (Value : Longint); + +begin +end; + + + + +Procedure TComponent.Setname (Value : TComponentName); + +begin +end; + + + +{ --------------------------------------------------------------------- + TFiler + ---------------------------------------------------------------------} + +Constructor TFiler.Create {(Stream : TStream; BufSize : Longint) }; + +begin +end; + + + + +Destructor TFiler.Destroy; + +begin +end; + + + + +{ --------------------------------------------------------------------- + TPersistent + ---------------------------------------------------------------------} + +Procedure TPersistent.AssignError (Source : TPersistent); + +begin +end; + + + +Procedure TPersistent.AssignTo (Dest : TPersistent); + +begin +end; + + + +Procedure TPersistent.DefineProperties (Filer : TFiler); + +begin +end; + + + +Destructor TPersistent.Destroy; + +begin +end; + + + +Procedure TPersistent.Assign (Source : TPersistent); + +begin +end; + + + +end. diff --git a/tests/tbs/tb0301.pp b/tests/tbs/tb0301.pp new file mode 100644 index 0000000000..48c05b5e4c --- /dev/null +++ b/tests/tbs/tb0301.pp @@ -0,0 +1,55 @@ +uses + crt; + +begin + textcolor(blue); + writeln('blue'); + + textcolor(green); + writeln('green'); + + textcolor(cyan); + writeln('cyan'); + + textcolor(red); + writeln('red'); + + textcolor(magenta); + writeln('magenta'); + + textcolor(brown); + writeln('brown'); + + textcolor(lightgray); + writeln('lightgray'); + + textcolor(darkgray); + writeln('darkgray'); + + textcolor(lightblue); + writeln('lightblue'); + + textcolor(lightgreen); + writeln('lightgreen'); + + textcolor(lightcyan); + writeln('lightcyan'); + + textcolor(lightred); + writeln('lightred'); + + textcolor(lightmagenta); + writeln('lightmagenta'); + + textcolor(yellow); + writeln('yellow'); + + textcolor(white); + writeln('white'); + + textcolor(white+blink); + writeln('white blinking'); + + textcolor(lightgray); + writeln; +end. diff --git a/tests/tbs/tb0302.pp b/tests/tbs/tb0302.pp new file mode 100644 index 0000000000..73b43a5a26 --- /dev/null +++ b/tests/tbs/tb0302.pp @@ -0,0 +1,23 @@ +{$mode objfpc} + +{ tests forward class types } + +type + tclass1 = class; + + tclass2 = class + class1 : tclass1; + end; + +var + c : tclass1; + +type + tclass1 = class(tclass2) + i : longint; + end; + +begin + c:=tclass1.create; + c.i:=12; +end. diff --git a/tests/tbs/tb0303.pp b/tests/tbs/tb0303.pp new file mode 100644 index 0000000000..d70caf5cfd --- /dev/null +++ b/tests/tbs/tb0303.pp @@ -0,0 +1,43 @@ +{$mode objfpc} + +type + tclass1 = class + procedure a;virtual; + procedure b;virtual; + end; + + tclass2 = class(tclass1) + procedure a;override; + procedure b;override; + procedure c;virtual; + end; + + + procedure tclass1.a; + + begin + end; + + procedure tclass1.b; + + begin + end; + + procedure tclass2.a; + + begin + end; + + procedure tclass2.b; + + begin + end; + + + procedure tclass2.c; + + begin + end; + +begin +end. diff --git a/tests/tbs/tb0304.pp b/tests/tbs/tb0304.pp new file mode 100644 index 0000000000..3fc97557c2 --- /dev/null +++ b/tests/tbs/tb0304.pp @@ -0,0 +1,13 @@ +{ %TARGET=win32 } +{ %NORUN } +library test; + + procedure exporttest;export; + + begin + end; + + exports exporttest; + +begin +end. diff --git a/tests/tbs/tb0305.pp b/tests/tbs/tb0305.pp new file mode 100644 index 0000000000..b066bf60f9 --- /dev/null +++ b/tests/tbs/tb0305.pp @@ -0,0 +1,47 @@ +{$mode objfpc} + +type + tobject2 = class + i : longint; + procedure y; + constructor create; + class procedure x; + class procedure v;virtual; + end; + + procedure tobject2.y; + + begin + Writeln('Procedure y called'); + end; + + class procedure tobject2.v; + + begin + end; + + class procedure tobject2.x; + + begin + v; + end; + + constructor tobject2.create; + + begin + end; + + type + tclass2 = class of tobject2; + + var + a : class of tobject2; + object2 : tobject2; + +begin + a:=tobject2; + a.x; + tobject2.x; + object2:=tobject2.create; + object2:=a.create; +end. diff --git a/tests/tbs/tb0306.pp b/tests/tbs/tb0306.pp new file mode 100644 index 0000000000..941c3b9ac4 --- /dev/null +++ b/tests/tbs/tb0306.pp @@ -0,0 +1,41 @@ +{$mode objfpc} + +type + tobject2 = class + constructor create; + function rname : string; + procedure wname(const s : string); + property name : string read rname write wname; + end; + + tclass2 = class of tobject2; + +var + o2 : tobject2; + c2 : tclass2; + +constructor tobject2.create; + + begin + inherited create; + end; + +procedure tobject2.wname(const s : string); + + begin + end; + +function tobject2.rname : string; + + begin + end; + +begin + o2:=tobject2.create; + o2.name:='1234'; + writeln(o2.name); + o2.destroy; + c2:=tobject2; + o2:=c2.create; + o2.destroy; +end. diff --git a/tests/tbs/tb0308.pp b/tests/tbs/tb0308.pp new file mode 100644 index 0000000000..9195bbb837 --- /dev/null +++ b/tests/tbs/tb0308.pp @@ -0,0 +1,15 @@ +uses + ub0308; + + var + r : tr; + + begin + r.a:=x; + if r.a=x then + begin + with r do + if a=y then + ; + end; + end. diff --git a/tests/tbs/tb0309.pp b/tests/tbs/tb0309.pp new file mode 100644 index 0000000000..e3dd5788bd --- /dev/null +++ b/tests/tbs/tb0309.pp @@ -0,0 +1,58 @@ +{$R+} +type + ta = object + constructor init; + destructor done; + procedure p;virtual; + end; + + pa = ^ta; + +constructor ta.init; + + begin + end; + +destructor ta.done; + + begin + end; + +procedure ta.p; + + begin + end; + +type + plongint = ^longint; + +var + p : pa; + data : array[0..4] of longint; + saveexit : pointer; + + procedure testerror; + begin + exitproc:=saveexit; + if errorcode=210 then + begin + errorcode:=0; + writeln('Object valid VMT check works'); + runerror(0); + end + else + halt(1); + end; + +begin + saveexit:=exitproc; + exitproc:=@testerror; + fillchar(data,sizeof(data),12); + p:=new(pa,init); + p^.p; + { the vmt pointer gets an invalid value: } + plongint(p)^:=longint(@data); + { causes runerror } + p^.p; + halt(1); +end. diff --git a/tests/tbs/tb0310.pp b/tests/tbs/tb0310.pp new file mode 100644 index 0000000000..7308dc6287 --- /dev/null +++ b/tests/tbs/tb0310.pp @@ -0,0 +1,74 @@ +program tb318; + +Type + TRec = record + X,Y : longint; + end; + + TRecFile = File of TRec; + +var TF : TRecFile; + LF : File of longint; + i,j,k,l : longint; + t : Trec; + +begin + Write ('Writing files...'); + assign (LF,'longint.dat'); + rewrite (LF); + for i:=1 to 10 do + write (LF,i); + close (LF); + Assign (TF,'TRec.dat'); + rewrite (TF); + for i:=1 to 10 do + for j:=1 to 10 do + begin + t.x:=i; + t.y:=j; + write (TF,T); + end; + close (TF); + writeln ('Done'); + reset (LF); + reset (TF); + Write ('Sequential read test...'); + for i:=1 to 10 do + begin + read (LF,J); + if j<>i then writeln ('Read of longint failed at :',i); + end; + for i:=1 to 10 do + for j:=1 to 10 do + begin + read (tf,t); + if (t.x<>i) or (t.y<>j) then + writeln ('Read of record failed at :',i,',',j); + end; + writeln ('Done.'); + Write ('Random access read test...'); + For i:=1 to 10 do + begin + k:=random(10); + seek (lf,k); + read (lf,j); + if j<>k+1 then + Writeln ('Failed random read of longint at pos ',k,' : ',j); + end; + For i:=1 to 10 do + for j:=1 to 10 do + begin + k:=random(10); + l:=random(10); + seek (tf,k*10+l); + read (tf,t); + if (t.x<>k+1) or (t.y<>l+1) then + Writeln ('Failed random read of longint at pos ',k,',',l,' : ',t.x,',',t.y); + end; + Writeln ('Done.'); + close (lf); + close (TF); + erase (lf); + erase (tf); + +end. diff --git a/tests/tbs/tb0311.pp b/tests/tbs/tb0311.pp new file mode 100644 index 0000000000..7aec067fc1 --- /dev/null +++ b/tests/tbs/tb0311.pp @@ -0,0 +1,37 @@ +{ problem of conversion between + smallsets and long sets } +type + +{ Command sets } + + PCommandSet = ^TCommandSet; + TCommandSet = set of Byte; + +Const + cmValid = 0; + cmQuit = 1; + cmError = 2; + cmMenu = 3; + cmClose = 4; + cmZoom = 5; + cmResize = 6; + cmNext = 7; + cmPrev = 8; + cmHelp = 9; + +{ Application command codes } + + cmCut = 20; + cmCopy = 21; + cmPaste = 22; + cmUndo = 23; + cmClear = 24; + cmTile = 25; + cmCascade = 26; + + CurCommandSet: TCommandSet = + [0..255] - [cmZoom, cmClose, cmResize, cmNext, cmPrev]; + + + begin + end. diff --git a/tests/tbs/tb0312.pp b/tests/tbs/tb0312.pp new file mode 100644 index 0000000000..5aee233bcc --- /dev/null +++ b/tests/tbs/tb0312.pp @@ -0,0 +1,36 @@ +{ show a problem with IOCHECK !! + inside reset(file) + we call reset(file,longint) + but we also emit a call to iocheck after and this is wrong !! PM } +program getret; + + var + ppfile : file; + +begin +{$ifndef macos} + assign(ppfile,'this_file_probably_does_not_exist&~"#'); +{$else} + {Max 32 chars in macos fielnames} + assign(ppfile,'this_file_probably_&~"#'); +{$endif} + +{$I-} + reset(ppfile,1); + if ioresult=0 then + begin +{$I+} + close(ppfile); + end + else + writeln('the file does not exist') ; +{$I-} + reset(ppfile); + if ioresult=0 then + begin +{$I+} + close(ppfile); + end + else + writeln('the file does not exist') ; +end. diff --git a/tests/tbs/tb0313.pp b/tests/tbs/tb0313.pp new file mode 100644 index 0000000000..03b1ffbd3a --- /dev/null +++ b/tests/tbs/tb0313.pp @@ -0,0 +1,13 @@ +uses ub0313; + +var + arec : rec; + +begin + arec.nrs:=one; + if arec.nrs<>one then + begin + Writeln('Error with enums inside objects'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0314.pp b/tests/tbs/tb0314.pp new file mode 100644 index 0000000000..7f33a31637 --- /dev/null +++ b/tests/tbs/tb0314.pp @@ -0,0 +1,39 @@ + +{ this program shows a possible problem + of name mangling in FPC (PM) } + procedure test; + + function a : longint; + begin + a:=1; + end; + + begin + writeln('a = ',a); + end; + + procedure test(b : byte); + + function a : longint; + begin + a:=2; + end; + + begin + writeln('b = ',b); + writeln('a = ',a); + end; + + type a = word; + + function test_(b : a) : longint; + begin + test_:=b; + end; + +begin + test(1); + test; + test(4); +end. + diff --git a/tests/tbs/tb0315.pp b/tests/tbs/tb0315.pp new file mode 100644 index 0000000000..ff1c7a83af --- /dev/null +++ b/tests/tbs/tb0315.pp @@ -0,0 +1,10 @@ +{ test for const string that is a char } + +const + C ='D'; + D = 'AD'; + PP : string[length(D)] = D; + P : String[length(c)] = C; + +begin +end. diff --git a/tests/tbs/tb0316.pp b/tests/tbs/tb0316.pp new file mode 100644 index 0000000000..e069193e11 --- /dev/null +++ b/tests/tbs/tb0316.pp @@ -0,0 +1,19 @@ +{ %OPT=-g } +{ the debug info created problems for very long mangled names + because the manglednames where shorten differently (PM) + fixed in v 0.99.9 } +program ts010021; + +var i : longint; + + type very_very_very_long_integer = longint; + + function ugly(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p : + very_very_very_long_integer) : longint; + + begin + ugly:=0; + end; + +begin +end. diff --git a/tests/tbs/tb0317.pp b/tests/tbs/tb0317.pp new file mode 100644 index 0000000000..edc96fdccd --- /dev/null +++ b/tests/tbs/tb0317.pp @@ -0,0 +1,46 @@ +program ts010022; + +const + EXCEPTIONCOUNT = 18; + exception_names : array[0..EXCEPTIONCOUNT-1] of pchar = ( + 'Division by Zero', + 'Debug', + 'NMI', + 'Breakpoint', + 'Overflow', + 'Bounds Check', + 'Invalid Opcode', + 'Coprocessor not available', + 'Double Fault', + 'Coprocessor overrun', + 'Invalid TSS', + 'Segment Not Present', + 'Stack Fault', + 'General Protection Fault', + 'Page fault', + ' ', + 'Coprocessor Error', + 'Alignment Check'); + + single_pchar : pchar = 'Alone test'; + +const filename = 'ts010022.tmp'; + +var en : pchar; + f : text; + st : string; +begin + assign(f,filename); + rewrite(f); + en:=single_pchar; + Writeln(f,en); + en:=exception_names[6]; + writeln(f,en); + close(f); + reset(f); + readln(f,st); + if st<>'Alone test' then halt(1); + readln(f,st); + if st<>'Invalid Opcode' then halt(1); + close(f); +end. diff --git a/tests/tbs/tb0318.pp b/tests/tbs/tb0318.pp new file mode 100644 index 0000000000..2d3b01acf4 --- /dev/null +++ b/tests/tbs/tb0318.pp @@ -0,0 +1,14 @@ +const + nl=#10; +type + cs=set of char; + +function p(c:cs):boolean; +begin + p:=(#10 in c); +end; + +begin + if p([#1..#255]-[nl]) then + halt(1); +end. diff --git a/tests/tbs/tb0319.pp b/tests/tbs/tb0319.pp new file mode 100644 index 0000000000..6192d02000 --- /dev/null +++ b/tests/tbs/tb0319.pp @@ -0,0 +1,35 @@ +{ %CPU=i386 } +{$asmmode att} + +const + Count=100; + +type + trec=record + a,b,c : longint; + end; + + +var + r : trec; +begin + asm + leal r,%edi + leal r,%esi + movl %es:46(%edi),%eax + movl 2+trec.b(%esi),%eax + movl $1,%ebx + movl trec.b(%esi,%ebx,(2*4)),%eax + movl r(,%ebx,(2*4)),%eax + xorl %esi,%esi + movl r.c(,%esi,(2*4)),%eax + movl Count,%eax + movl Count*100,%eax + movl trec.b+2,%eax + leal r,%esi + movl trec.b+2(%esi),%eax +{$ifdef go32v2} + movl %fs:(0x46c),%eax +{$endif} + end; +end. diff --git a/tests/tbs/tb0320.pp b/tests/tbs/tb0320.pp new file mode 100644 index 0000000000..b1354e3eae --- /dev/null +++ b/tests/tbs/tb0320.pp @@ -0,0 +1,30 @@ +{ %CPU=i386 } +{$asmmode intel} + +const + Count=100; + +type + trec=record + a,b : longint; + end; + +var + r : trec; +begin + asm + xor esi,esi + mov [esi+r],eax + lea esi,r + mov [esi+2+trec.b],eax + mov trec[esi].b,eax + mov eax,trec.b+2 + mov trec[esi].b+2,eax + mov eax,Count + mov eax,Count*100 +{$ifdef go32v2} + mov fs:[0468+trec.b],eax + mov fs:[046ch],eax +{$endif} + end; +end. diff --git a/tests/tbs/tb0321.pp b/tests/tbs/tb0321.pp new file mode 100644 index 0000000000..04136f33d8 --- /dev/null +++ b/tests/tbs/tb0321.pp @@ -0,0 +1,45 @@ +{ this test program test allocation of large pieces of stack } +{ this is especially necessary for win32 } + +procedure p1(a : array of byte); + + var + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p2; + + var + a : array[0..20000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p3; + + var + a : array[0..200000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + + +var + a : array[0..10000] of byte; + +begin + p1(a); + p2; + p3; +end. + diff --git a/tests/tbs/tb0322.pp b/tests/tbs/tb0322.pp new file mode 100644 index 0000000000..28319a6216 --- /dev/null +++ b/tests/tbs/tb0322.pp @@ -0,0 +1,26 @@ +{ %CPU=i386 } +{$IFDEF FPC} +{$ASMMODE INTEL} +{$ENDIF} +{$N+} + +FUNCTION Floor(M2:Comp):LONGINT;assembler; + +VAR X : COMP; + X2 : LONGINT; + X3 : Double; + s : single; + +ASM + FLD QWord Ptr X // Here S_IL must be changed to + // S_FL, i.e. the compiler must generate + // fldl "X" instead of fldq "X" which is wrong + fld X2 // No mem64, so no problem + FLD QWord Ptr X3 // This one goes wrong under AS + FilD QWord Ptr X // This one translates to fildq and is accepted? + fild X2 // No mem64, so no problem + FiLD QWord Ptr X3 // This one translates to fildq and is accepted? +end; + +BEGIN +END. diff --git a/tests/tbs/tb0323.pp b/tests/tbs/tb0323.pp new file mode 100644 index 0000000000..c853d5e5b5 --- /dev/null +++ b/tests/tbs/tb0323.pp @@ -0,0 +1,13 @@ +// checks type cast of nil in const statement + type + THandle = longint; + WSAEVENT = THandle; + const + WSA_INVALID_EVENT = WSAEVENT(nil); + + var + l : longint; + +begin + l:=WSA_INVALID_EVENT*1; +end. diff --git a/tests/tbs/tb0324.pp b/tests/tbs/tb0324.pp new file mode 100644 index 0000000000..04136f33d8 --- /dev/null +++ b/tests/tbs/tb0324.pp @@ -0,0 +1,45 @@ +{ this test program test allocation of large pieces of stack } +{ this is especially necessary for win32 } + +procedure p1(a : array of byte); + + var + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p2; + + var + a : array[0..20000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p3; + + var + a : array[0..200000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + + +var + a : array[0..10000] of byte; + +begin + p1(a); + p2; + p3; +end. + diff --git a/tests/tbs/tb0325.pp b/tests/tbs/tb0325.pp new file mode 100644 index 0000000000..fede1db11d --- /dev/null +++ b/tests/tbs/tb0325.pp @@ -0,0 +1,20 @@ +{$mode delphi} +type + tc1 = class + l : longint; + property p : longint read l; + end; + + tc2 = class(tc1) + { in Delphi mode } + { parameters can have the same name as properties } + procedure p1(p : longint); + end; + +procedure tc2.p1(p : longint); + + begin + end; + +begin +end. diff --git a/tests/tbs/tb0326.pp b/tests/tbs/tb0326.pp new file mode 100644 index 0000000000..548fa8603b --- /dev/null +++ b/tests/tbs/tb0326.pp @@ -0,0 +1,18 @@ +var + d1,d2 :double; + i1,i2 : int64; + c1,c2 : dword; + +begin + c1:=10; + c2:=100; + i1:=1000; + i2:=10000; + d1:=c1/c2; + d2:=i1/i2; + if d1<>d2 then + begin + writeln('error'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0327.pp b/tests/tbs/tb0327.pp new file mode 100644 index 0000000000..7a39833f6b --- /dev/null +++ b/tests/tbs/tb0327.pp @@ -0,0 +1,12 @@ +type ta = array[1..1,1..100] of integer; + +procedure t(a: ta); +begin +end; + +var a: ta; + +begin + t(a); +end. + diff --git a/tests/tbs/tb0328.pp b/tests/tbs/tb0328.pp new file mode 100644 index 0000000000..dac295d824 --- /dev/null +++ b/tests/tbs/tb0328.pp @@ -0,0 +1,77 @@ +{ %VERSION=1.1 } +{ %OPT=-Or } +{ test for full boolean eval and register usage with b+ } + +{$b+} + +var + funcscalled: byte; + ok: boolean; + +function function1: boolean; +begin + writeln('function1 called!'); + inc(funcscalled); + function1 := false; +end; + +function function2: boolean; +begin + writeln('function2 called!'); + inc(funcscalled); + function2 := false; +end; + +function function3: boolean; +begin + writeln('function3 called!'); + inc(funcscalled); + function3 := false; +end; + +function function4: boolean; +begin + writeln('function4 called!'); + inc(funcscalled); + function4 := false; +end; + +function test2: boolean; +var j, k, l, m: longint; +begin + test2 := true; + m := 0; +{ get as much regvars occupied as possible } + for j := 1 to 1000 do + for k := 1 to 1000 do + for l := k downto 0 do + inc(m,j - k + l); + if (j = 5) and (k = 0) and (l = 100) and function1 then + begin + test2 := false; + writeln('bug'); + end; +end; + +begin + ok := true; + funcscalled := 0; + if function1 and function2 and function3 and function4 then + begin + writeln('bug!'); + end; + ok := funcscalled = 4; + if ok then + writeln('all functions called!') + else + writeln('not all functions called'); + ok := test2 and (funcscalled = 5); + if ok then + writeln('test2 passed') + else writeln('test2 not passed'); + if not ok then + begin + writeln('full boolean evaluation is not working!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0329.pp b/tests/tbs/tb0329.pp new file mode 100644 index 0000000000..93a8a9971e --- /dev/null +++ b/tests/tbs/tb0329.pp @@ -0,0 +1,8 @@ +{$mode objfpc} +var + o : tobject; + +begin + if assigned(o) then + halt(1); +end. diff --git a/tests/tbs/tb0331.pp b/tests/tbs/tb0331.pp new file mode 100644 index 0000000000..101387659a --- /dev/null +++ b/tests/tbs/tb0331.pp @@ -0,0 +1,13 @@ +{$mode objfpc} + +{ tests assignements and compare } + +var + o1,o2 : tobject; + +begin + o1:=nil; + o2:=o1; + if o2<>nil then + halt(1); +end. diff --git a/tests/tbs/tb0332.pp b/tests/tbs/tb0332.pp new file mode 100644 index 0000000000..1089dbdb46 --- /dev/null +++ b/tests/tbs/tb0332.pp @@ -0,0 +1,5 @@ +var + l : farpointer; +begin + l:=ptr(0,0); +end. diff --git a/tests/tbs/tb0333.pp b/tests/tbs/tb0333.pp new file mode 100644 index 0000000000..f2cad1bb0e --- /dev/null +++ b/tests/tbs/tb0333.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0001.pp } +{ tests a bugs in the .ascii output (#0 and too long) OK 0.9.2 } + +program smalltest; + const + teststr : string = ' '#9#255#0; +begin + writeln(teststr); + teststr := 'gaga'; + writeln(teststr); + if teststr<>'gaga' then halt(1); +end. diff --git a/tests/tbs/tb0334.pp b/tests/tbs/tb0334.pp new file mode 100644 index 0000000000..086dc78737 --- /dev/null +++ b/tests/tbs/tb0334.pp @@ -0,0 +1,15 @@ +{$mode objfpc} + +uses + sysutils; + +var + s : tintegerset; + +begin + if sizeof(s)<>sizeof(integer) then + begin + writeln('Wrong size of Sysutils.TIntegerSet (',sizeof(s),')'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0335.pp b/tests/tbs/tb0335.pp new file mode 100644 index 0000000000..5ff485b979 --- /dev/null +++ b/tests/tbs/tb0335.pp @@ -0,0 +1,23 @@ +{ %CPU=i386 } +{$asmmode intel} + +var + a : array[0..5] of byte; + +function f : byte;assembler; + + asm + mov ebx,offset a + mov ecx,0 + mov al,[ebx+4*ecx] + end; + +begin + fillchar(a,5,255); + a[0]:=0; + if f<>0 then + begin + writeln('Scale factor problem in asmmode intel!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0336.pp b/tests/tbs/tb0336.pp new file mode 100644 index 0000000000..7cacb0260f --- /dev/null +++ b/tests/tbs/tb0336.pp @@ -0,0 +1,52 @@ +var + l : longint; + d : dword; + s : string; + code : integer; + +procedure do_error(l : longint); + + begin + writeln('Error near number ',l); + halt(1); + end; + +begin + s:='4294967295'; + val(s,d,code); + if code<>0 then + do_error(1); + s:='4294967296'; + val(s,d,code); +{$ifdef CPU64} + if code<>0 then +{$else CPU64} + if code=0 then +{$endif CPU64} + do_error(1); + + s:='2147483647'; + val(s,l,code); + if code<>0 then + do_error(3); + s:='2147483648'; + val(s,l,code); +{$ifdef CPU64} + if code<>0 then +{$else CPU64} + if code=0 then +{$endif CPU64} + do_error(4); + s:='-2147483648'; + val(s,l,code); + if code<>0 then + do_error(5); + s:='-2147483649'; + val(s,l,code); +{$ifdef CPU64} + if code<>0 then +{$else CPU64} + if code=0 then +{$endif CPU64} + do_error(6); +end. diff --git a/tests/tbs/tb0337.pp b/tests/tbs/tb0337.pp new file mode 100644 index 0000000000..b8d2beafbe --- /dev/null +++ b/tests/tbs/tb0337.pp @@ -0,0 +1,5 @@ +var + s : string; +begin + s:={$ifdef fpc}'~[v]~'{$else}'~['#25']~'{$endif}; +end. diff --git a/tests/tbs/tb0338.pp b/tests/tbs/tb0338.pp new file mode 100644 index 0000000000..161ae30b18 --- /dev/null +++ b/tests/tbs/tb0338.pp @@ -0,0 +1,14 @@ +{$h+} + +Type + TMyRec = Record + AString : AnsiString; + end; + PMyRec = ^TMyRec; + +Var + M : PMyRec; + +begin + M:=New(PmyRec); +end. diff --git a/tests/tbs/tb0339.pp b/tests/tbs/tb0339.pp new file mode 100644 index 0000000000..eeb1381eea --- /dev/null +++ b/tests/tbs/tb0339.pp @@ -0,0 +1,15 @@ +{$mode TP} +uses ub0339; +type + r = packed record + Foo : Boolean; + Bar : (No, Yes); + Baz : 0 .. 3; + Qux : -1 .. 0; + Fred : 1 .. 7 + end; +begin + Writeln ('AAA: Size of packed record r = ', SizeOf (r), ' bytes.'); + Writeln ('AAA: Size of packed record r2 = ', SizeOf (r2), ' bytes.'); + PrintSize; +end. diff --git a/tests/tbs/tb0340.pp b/tests/tbs/tb0340.pp new file mode 100644 index 0000000000..2a6451bd92 --- /dev/null +++ b/tests/tbs/tb0340.pp @@ -0,0 +1,32 @@ +{$mode objfpc} +var + v : tvarrec; + error : boolean; +procedure p(a:array of const); +var + i : integer; +begin + for i:=low(a) to high(a) do + with a[i] do + begin + case vtype of + vtInteger : + begin + writeln('Integer: ',VInteger); + if VInteger=1000 then + Error:=false; + end; + else + writeln('Error!'); + end; + end; +end; + +begin + error:=true; + v.vtype:=vtInteger; + v.VInteger:=1000; + p(v); + if Error then + Halt(1); +end. diff --git a/tests/tbs/tb0341.pp b/tests/tbs/tb0341.pp new file mode 100644 index 0000000000..13547850e3 --- /dev/null +++ b/tests/tbs/tb0341.pp @@ -0,0 +1,30 @@ +{ %cpu=i386 } +program test_assembler; + +procedure test_att; +begin +{$asmmode att} + asm + ret + lret + iret + iretw + end; +end; + +procedure test_intel; +begin +{$asmmode intel} + asm + ret + retf + retn + iret + iretd + iretw + end; +end; + +begin + Writeln('This is just to test special assembler instructions'); +end. diff --git a/tests/tbs/tb0342.pp b/tests/tbs/tb0342.pp new file mode 100644 index 0000000000..1739002b0d --- /dev/null +++ b/tests/tbs/tb0342.pp @@ -0,0 +1,6 @@ +unit tb0342; +interface +uses + ub0342a; +implementation +end. diff --git a/tests/tbs/tb0343.pp b/tests/tbs/tb0343.pp new file mode 100644 index 0000000000..51739fe918 --- /dev/null +++ b/tests/tbs/tb0343.pp @@ -0,0 +1,6 @@ +{$R+} +var + i : int64; +begin + i:=high(cardinal); +end. diff --git a/tests/tbs/tb0344.pp b/tests/tbs/tb0344.pp new file mode 100644 index 0000000000..3f47694a49 --- /dev/null +++ b/tests/tbs/tb0344.pp @@ -0,0 +1,37 @@ +{ %version=1.1 } + +{$R+} +var + s : string; + error : boolean; +begin + error:=false; + str(high(int64),s); + if s<>'9223372036854775807' then + begin + writeln('high(int64) error!: "',s,'"'); + error:=true; + end; + str(low(int64),s); + if s<>'-9223372036854775808' then + begin + writeln('low(int64) error!: "',s,'"'); + error:=true; + end; +{$ifdef fpc} + str(high(qword),s); + if s<>'18446744073709551615' then + begin + writeln('high(qword) error!: "',s,'"'); + error:=true; + end; + str(low(qword),s); + if s<>'0' then + begin + writeln('low(qword) error!: "',s,'"'); + error:=true; + end; +{$endif} + if error then + halt(1); +end. diff --git a/tests/tbs/tb0345.pp b/tests/tbs/tb0345.pp new file mode 100644 index 0000000000..a97ef9ae0c --- /dev/null +++ b/tests/tbs/tb0345.pp @@ -0,0 +1,11 @@ +{%cpu=i386} + +{$asmmode intel} +begin +asm + mov eax, 1; + mov ebx, eax; + { first comment }{ second comment } + mov ecx, eax; +end; +end. diff --git a/tests/tbs/tb0346.pp b/tests/tbs/tb0346.pp new file mode 100644 index 0000000000..c43914e3e6 --- /dev/null +++ b/tests/tbs/tb0346.pp @@ -0,0 +1,22 @@ +{ %version=1.1 } + +{$MODE DELPHI} +type +aClass=class + private + aa:longint; + procedure bb(index:integer;value:longint); + public + property cc:longint index 1 read aa write bb; +end; +procedure AClass.bb(index:integer;value:longint); + begin + aa:=value; + end; +var + C:aClass; +begin + C:=aClass.Create; + C.cc:=1; + writeln(C.cc); +end. diff --git a/tests/tbs/tb0347.pp b/tests/tbs/tb0347.pp new file mode 100644 index 0000000000..f43d4c96d0 --- /dev/null +++ b/tests/tbs/tb0347.pp @@ -0,0 +1,17 @@ +{$mode objfpc} +{$M+} + +type + tenum = (te_first,te_second,te_third,te_fourth,te_fifth); + + tenumrange = te_second..te_fourth; + + tc1 = class + public + fe : tenumrange; + published + property enumrange : tenumrange read fe write fe; + end; + +begin +end. diff --git a/tests/tbs/tb0348.pp b/tests/tbs/tb0348.pp new file mode 100644 index 0000000000..ef79495919 --- /dev/null +++ b/tests/tbs/tb0348.pp @@ -0,0 +1,7 @@ +{ %VERSION=1.1 } + + const + GUID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}'; + +begin +end. diff --git a/tests/tbs/tb0349.pp b/tests/tbs/tb0349.pp new file mode 100644 index 0000000000..f1bdd8322d --- /dev/null +++ b/tests/tbs/tb0349.pp @@ -0,0 +1,35 @@ +{ %VERSION=1.1} +var + p : pwidechar; + c1,c2 : widechar; + i : longint; + a : ansistring; + w : widestring; + err : boolean; + +const somestr : pwidechar = 'blaat'; + +begin + p:=@c1; + i:=0; + c2:=p[i]; + + w:='hello'; + a:=w; + + writeln(a); + if a<>'hello' then + err:=true; + writeln(w); + if w<>'hello' then + err:=true; + + p:=''; + p:='hello'; + writeln(widestring(p)); + if widestring(p)<>'hello' then + err:=true; + + if err then + halt(1); +end. diff --git a/tests/tbs/tb0350.pp b/tests/tbs/tb0350.pp new file mode 100644 index 0000000000..46365953b9 --- /dev/null +++ b/tests/tbs/tb0350.pp @@ -0,0 +1,9 @@ +{ %VERSION=1.1 } +{$mode objfpc} +var + a : longint absolute 0; + +begin + if @a<>nil then + halt(1); +end. diff --git a/tests/tbs/tb0351.pp b/tests/tbs/tb0351.pp new file mode 100644 index 0000000000..7018bd64c6 --- /dev/null +++ b/tests/tbs/tb0351.pp @@ -0,0 +1,10 @@ +{ %VERSION=1.1 } +{$mode objfpc} +type + i = interface; + + i = interface + end; + +begin +end. diff --git a/tests/tbs/tb0352.pp b/tests/tbs/tb0352.pp new file mode 100644 index 0000000000..37b1e96ca7 --- /dev/null +++ b/tests/tbs/tb0352.pp @@ -0,0 +1,9 @@ +procedure p(var w:word); +begin +end; + +var + i : smallint; +begin + p(word(i)); +end. diff --git a/tests/tbs/tb0353.pp b/tests/tbs/tb0353.pp new file mode 100644 index 0000000000..6bca853599 --- /dev/null +++ b/tests/tbs/tb0353.pp @@ -0,0 +1,11 @@ +{ %VERSION=1.1 } + + const + c1 = widechar(0); + c2 = widechar(#0); + c3 = #123; + c4 = #1234; + + +begin +end. diff --git a/tests/tbs/tb0354.pp b/tests/tbs/tb0354.pp new file mode 100644 index 0000000000..0ace52436c --- /dev/null +++ b/tests/tbs/tb0354.pp @@ -0,0 +1,7 @@ +{ %VERSION=1.1 } +{$mode delphi} +type + a = function ( ) : boolean; + +begin +end. diff --git a/tests/tbs/tb0355.pp b/tests/tbs/tb0355.pp new file mode 100644 index 0000000000..55420365a9 --- /dev/null +++ b/tests/tbs/tb0355.pp @@ -0,0 +1,22 @@ +{$mode delphi} + +const + CSV_Internal = 10; + +type + PTypeRec = ^TTypeRec; + TTypeRec = record + atypeid: Word; + end; + + +function ChangeType(newtype: PTypeRec): Pointer; + +begin + if NewType.AtypeID = CSV_Internal then + begin + end; +end; + +begin +end. diff --git a/tests/tbs/tb0356.pp b/tests/tbs/tb0356.pp new file mode 100644 index 0000000000..6d87191411 --- /dev/null +++ b/tests/tbs/tb0356.pp @@ -0,0 +1,27 @@ +{$mode objfpc} +type + tc = class + function test(var c: tc): boolean; + left,right: tc; + end; + + testfunc = function(var c: tc):boolean of object; + + function foreach(var c: tc; p: testfunc): boolean; + begin + if not assigned(c) then + exit; + end; + + + function tc.test(var c: tc): boolean; + begin + { if you use @test, the compiler tries to get the address of the } + { function result instead of the address of the method (JM) } + result := foreach(c.left,@self.test); + result := foreach(c.right,@self.test) or result; + end; + + +begin +end. diff --git a/tests/tbs/tb0357.pp b/tests/tbs/tb0357.pp new file mode 100644 index 0000000000..7f32030b4c --- /dev/null +++ b/tests/tbs/tb0357.pp @@ -0,0 +1,14 @@ +{ %version=1.1 } + +{$ifdef fpc}{$MODE OBJFPC}{$endif} +uses sysutils; +var + p:pointer; +begin + try + getmem(p, 1000000000); + except + on eoutofmemory do writeln('out of memory!'); + end; + writeln('program lasts...') +end. diff --git a/tests/tbs/tb0358.pp b/tests/tbs/tb0358.pp new file mode 100644 index 0000000000..f2842276ab --- /dev/null +++ b/tests/tbs/tb0358.pp @@ -0,0 +1,6 @@ +{ %version=1.1 } +type + __u64 = 0..High(Int64); // Create unsigned Int64 (with 63 bits) + +begin +end. diff --git a/tests/tbs/tb0359.pp b/tests/tbs/tb0359.pp new file mode 100644 index 0000000000..fd0aef6c7f --- /dev/null +++ b/tests/tbs/tb0359.pp @@ -0,0 +1,18 @@ +{ %version=1.1 } +{ %TARGET=linux } + +{$linklib c} + +type + tprintfproc=procedure(t:pchar);varargs;cdecl; + +procedure printf(t:pchar);varargs;cdecl;external; + +var + t : tprintfproc; +begin + printf('Proc test %d %s %f'#10,1,'test',1234.5678); + + t:=@printf; + t('Procvar test %d %s %f'#10,2,'test',1234.5678); +end. diff --git a/tests/tbs/tb0360.pp b/tests/tbs/tb0360.pp new file mode 100644 index 0000000000..2b26244a68 --- /dev/null +++ b/tests/tbs/tb0360.pp @@ -0,0 +1,12 @@ +{ %version=1.1 } + +{$mode delphi} + +type + e = ( + PTRACE_SINGLESTEP = 9, + PT_STEP = PTRACE_SINGLESTEP + ); + +begin +end. diff --git a/tests/tbs/tb0361.pp b/tests/tbs/tb0361.pp new file mode 100644 index 0000000000..0728a2967d --- /dev/null +++ b/tests/tbs/tb0361.pp @@ -0,0 +1,8 @@ +type + e=(one,two,three); + +var + a : array[0..cardinal(two)+1] of byte; + +begin +end. diff --git a/tests/tbs/tb0362.pp b/tests/tbs/tb0362.pp new file mode 100644 index 0000000000..006d4831c4 --- /dev/null +++ b/tests/tbs/tb0362.pp @@ -0,0 +1,13 @@ +{$R+} + +type + size_t = Cardinal; + +function CMSG_ALIGN(len: size_t): size_t; +begin + CMSG_ALIGN := (len + SizeOf(size_t) - 1) and (not (SizeOf(size_t) - 1)); +end; + + +begin +end. diff --git a/tests/tbs/tb0363.pp b/tests/tbs/tb0363.pp new file mode 100644 index 0000000000..d91ce14f30 --- /dev/null +++ b/tests/tbs/tb0363.pp @@ -0,0 +1,23 @@ +{ %VERSION=1.1 } + +procedure p1(const a:array of byte); +var + l : longint; +begin + l:=length(a); + writeln('openarray length: ',l); + if l<>9 then + halt(1); +end; + +var + a : array[2..10] of byte; + l : longint; +begin + l:=length(a); + writeln('length of a ',l); + if l<>9 then + halt(1); + + p1(a); +end. diff --git a/tests/tbs/tb0364.pp b/tests/tbs/tb0364.pp new file mode 100644 index 0000000000..bb87109fcd --- /dev/null +++ b/tests/tbs/tb0364.pp @@ -0,0 +1,36 @@ +uses + sysutils; + +{ comment by submitter: + The following statement (which works in Delphi) + result:=Format('%10.n', [ival*1.0]); + generated an unhandled exception (and said: Missing argument in format ""). + Checking the Delphi documentation, it agrees with the fpc documentation + (units.pdf), that a dot should be followed by a <prec> (but Delphi does + not appear to explicitly state that prec should be an integer). + It appears that Delphi is treating this like %10.0n, although it is + potentially undefined behaviour. The fpc documentation indicates I + should get an EConversionError exception if there are problems. + (Actually the documentation may be inconsistent, since it also says + I may get an EConvertError exception.) + + If I change the format string to %10.0n, the program runs OK using + fpc, however, my thousand separators do not appear. +} + +var + s : string; + ival : integer; + +begin + ThousandSeparator:='.'; + DecimalSeparator:=','; + ival:=1234; + s:=Format('%10.n', [ival*1.0]); + writeln('s: "',s,'"'); + if s<>' 1.234' then + begin + writeln('Problem with Format'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0365.pp b/tests/tbs/tb0365.pp new file mode 100644 index 0000000000..12470612f0 --- /dev/null +++ b/tests/tbs/tb0365.pp @@ -0,0 +1,6 @@ +var + t : textfile; + +begin + assign(t,'test'); +end. diff --git a/tests/tbs/tb0366.pp b/tests/tbs/tb0366.pp new file mode 100644 index 0000000000..6468a86630 --- /dev/null +++ b/tests/tbs/tb0366.pp @@ -0,0 +1,38 @@ +{$ifdef fpc}{$mode objfpc}{$endif} + +uses + ub0366; + +type + tc2=class + public + FHeight : integer; + procedure p1; + end; + +procedure tc2.p1; +var + c1 : tc1; +begin + FHeight:=10; + c1:=tc1.create; + with c1 do + begin + Height:=FHeight; + end; + writeln('c1.Height: ',c1.Height,' (should be 10)'); + if c1.Height<>10 then + begin + writeln('ERROR!'); + halt(1); + end; + c1.free; +end; + +var + c2 : tc2; +begin + c2:=tc2.create; + c2.p1; + c2.free; +end. diff --git a/tests/tbs/tb0367.pp b/tests/tbs/tb0367.pp new file mode 100644 index 0000000000..c6b952d119 --- /dev/null +++ b/tests/tbs/tb0367.pp @@ -0,0 +1,28 @@ +{ %CPU=i386 } +{ %VERSION=1.1 } + +{$ifdef fpc} + {$mode delphi} + {$asmmode intel} +{$endif} + +function LRot(Value:Byte) : Byte; assembler; +asm + MOV CL, Value + MOV Result, CL + MOV AL, 20 +end; + + +var + i : Byte; +begin + i:=LRot(10); + writeln('LRot(10) = ',i,' (should be 10)'); + if i<>10 then + begin + writeln('ERROR!'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0368.pp b/tests/tbs/tb0368.pp new file mode 100644 index 0000000000..09f82a918a --- /dev/null +++ b/tests/tbs/tb0368.pp @@ -0,0 +1,17 @@ +type + tproc = procedure of object; + trec = record + l1,l2 : ptrint; + end; +var + pfn : tproc; + +begin + pfn:=nil; + if (trec(pfn).l1<>0) or + (trec(pfn).l2<>0) then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0369.pp b/tests/tbs/tb0369.pp new file mode 100644 index 0000000000..98b302639c --- /dev/null +++ b/tests/tbs/tb0369.pp @@ -0,0 +1,37 @@ + +type + ptchar=^tchar; + tchar=packed record + c : char; + end; + +function inl(l:ptchar):ptchar; +begin + inc(l); + inl:=l; +end; + +var + i : longint; + j : ptchar; + s : string; + error : boolean; +begin + error:=false; + s:='012345789'; + j:=@s[1]; + for i:=1to 8 do + begin + writeln(inl(j)^.c); + If (inl(j)^.c<>s[i+1]) Then + error:=true; + inc(j); + end; + if error then + begin + writeln('Error!'); + halt(1); + end; +end. + + diff --git a/tests/tbs/tb0370.pp b/tests/tbs/tb0370.pp new file mode 100644 index 0000000000..59c344b2b6 --- /dev/null +++ b/tests/tbs/tb0370.pp @@ -0,0 +1,11 @@ +{ %VERSION=1.1 } + +{$mode delphi} +type + tenum = (e1,e2,e3); + +const + e256 = tenum(256); + +begin +end. diff --git a/tests/tbs/tb0371.pp b/tests/tbs/tb0371.pp new file mode 100644 index 0000000000..627c5f1892 --- /dev/null +++ b/tests/tbs/tb0371.pp @@ -0,0 +1,28 @@ +{ %VERSION=1.1 } +{ %target=win32 } + +{$mode delphi} +unit tb0371; + +interface + + const + dllname = 'lalala'; + + type + pinteger = ^integer; + + procedure p1(var i : integer);overload; + procedure p1(i : pinteger);overload; + procedure p2(var i : integer);overload; + procedure p2(i : pinteger);overload; + +implementation + + procedure p1(var i : integer);overload;external dllname; + procedure p1(i : pinteger);overload;external dllname; + procedure p2(var i : integer);external dllname name 'lalala'; + procedure p2(i : pinteger);external dllname name 'lalala'; + +begin +end. diff --git a/tests/tbs/tb0372.pp b/tests/tbs/tb0372.pp new file mode 100644 index 0000000000..1c1de4da36 --- /dev/null +++ b/tests/tbs/tb0372.pp @@ -0,0 +1,23 @@ +{ %VERSION=1.1 } +{$ifdef fpc}{$mode objfpc}{$endif} +{$J+} + +type + imyinterface = interface + // this program isn't supposed to run so the guid doesn't matter } + ['{00000000-0000-0000-0000-000000000000}'] + procedure p; + end; + +const + iid_imyinterface = imyinterface; + iid2 : tguid = '{00000000-0000-0000-0000-000000000000}'; + +var + g : tguid; +begin + g:=imyinterface; + g:=iid_imyinterface; + g:=iid2; + iid2:=iid_imyinterface; +end. diff --git a/tests/tbs/tb0373.pp b/tests/tbs/tb0373.pp new file mode 100644 index 0000000000..484c731a76 --- /dev/null +++ b/tests/tbs/tb0373.pp @@ -0,0 +1,9 @@ +{ %VERSION=1.1 } +{$ifdef fpc}{$mode delphi}{$endif} +type + tmyinterface = interface + procedure p(p : longint); // Delphi allows this + end; + +begin +end. diff --git a/tests/tbs/tb0374.pp b/tests/tbs/tb0374.pp new file mode 100644 index 0000000000..86ea2e8808 --- /dev/null +++ b/tests/tbs/tb0374.pp @@ -0,0 +1,23 @@ +{ %VERSION=1.1 } +{$mode delphi} +type + tc1 = class + procedure a;overload;virtual; + end; + + tc2 = class(tc1) + procedure a;override; + end; + +procedure tc1.a; + + begin + end; + +procedure tc2.a; + + begin + end; + +begin +end. diff --git a/tests/tbs/tb0375.pp b/tests/tbs/tb0375.pp new file mode 100644 index 0000000000..2e86c6b452 --- /dev/null +++ b/tests/tbs/tb0375.pp @@ -0,0 +1,20 @@ +{ %VERSION=1.1 } +{$ifdef fpc}{$mode objfpc}{$endif} + +type + i1 = interface + procedure intfp; + end; + + tc1 = class(tinterfacedobject,i1) + procedure i1.intfp = p; + procedure p; + end; + +procedure tc1.p; + + begin + end; + +begin +end. diff --git a/tests/tbs/tb0376.pp b/tests/tbs/tb0376.pp new file mode 100644 index 0000000000..5e14f8599a --- /dev/null +++ b/tests/tbs/tb0376.pp @@ -0,0 +1,17 @@ +{%OPT=-Sew} +{$mode objfpc} + +function f: longint; +var + a: longint absolute result; +begin + a := 5; +end; + +begin + if f<>5 then + begin + writeln('error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0377.pp b/tests/tbs/tb0377.pp new file mode 100644 index 0000000000..035df7e398 --- /dev/null +++ b/tests/tbs/tb0377.pp @@ -0,0 +1,19 @@ +{$ifdef fpc}{$mode tp}{$endif} + +{$ifdef ENDIAN_BIG} +begin +end. +{$else} +var + i : longint; + j : word; +begin + j:=5; + i:=-1; + { this is allowed in tp7 } + byte(i):=j; + writeln('i: ',i,' (should be -251)'); + if i<>-251 then + halt(1); +end. +{$endif} diff --git a/tests/tbs/tb0378.pp b/tests/tbs/tb0378.pp new file mode 100644 index 0000000000..246bdd9533 --- /dev/null +++ b/tests/tbs/tb0378.pp @@ -0,0 +1,8 @@ +{$mode delphi} + +procedure p(); +begin +end; + +begin +end. diff --git a/tests/tbs/tb0380.pp b/tests/tbs/tb0380.pp new file mode 100644 index 0000000000..c36f622218 --- /dev/null +++ b/tests/tbs/tb0380.pp @@ -0,0 +1,10 @@ +{ %version=1.1 } + +uses ub0380; +procedure p1(s:string);overload; +begin +end; + +begin + p1(1); +end. diff --git a/tests/tbs/tb0381.pp b/tests/tbs/tb0381.pp new file mode 100644 index 0000000000..5666641a24 --- /dev/null +++ b/tests/tbs/tb0381.pp @@ -0,0 +1,14 @@ +{ %VERSION=1.1 } +var + w : widechar; + +begin + case w of + 'A' : ; + 'B' : ; + #1234: ; + #8888: ; + #8889..#9999: ; + 'Z'..'a': ; + end; +end. diff --git a/tests/tbs/tb0382.pp b/tests/tbs/tb0382.pp new file mode 100644 index 0000000000..3b54f1b9ef --- /dev/null +++ b/tests/tbs/tb0382.pp @@ -0,0 +1,7 @@ +{$J+} +const + w1 : word = 1; + +begin + w1:=2; +end. diff --git a/tests/tbs/tb0383.pp b/tests/tbs/tb0383.pp new file mode 100644 index 0000000000..7f408fde3b --- /dev/null +++ b/tests/tbs/tb0383.pp @@ -0,0 +1,14 @@ +type + enum1 = (one,two,three); + enum2 = (een,twee,drie); + +procedure p1(e:enum1); +begin +end; + +var + e2 : enum2; +begin + e2:=een; + p1(enum1(e2)); +end. diff --git a/tests/tbs/tb0384.pp b/tests/tbs/tb0384.pp new file mode 100644 index 0000000000..a663816be2 --- /dev/null +++ b/tests/tbs/tb0384.pp @@ -0,0 +1,30 @@ +{$mode delphi} +var + count : longint; + +procedure p1(w:word);overload; +begin + writeln('word'); + count:=count or 1; +end; + +procedure p1(l:longint);overload; +begin + writeln('longint'); + count:=count or 2; +end; + +var + f1 : procedure(l:longint); + f2 : procedure(w:word); +begin + f1:=p1; + f2:=p1; + f1(1); + f2(1); + if count<>3 then + begin + writeln('ERROR!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0385.pp b/tests/tbs/tb0385.pp new file mode 100644 index 0000000000..28779e3d39 --- /dev/null +++ b/tests/tbs/tb0385.pp @@ -0,0 +1,29 @@ +var + count : longint; + +procedure p1(w:word);overload; +begin + writeln('word'); + count:=count or 1; +end; + +procedure p1(l:longint);overload; +begin + writeln('longint'); + count:=count or 2; +end; + +var + f1 : procedure(l:longint); + f2 : procedure(w:word); +begin + f1:=@p1; + f2:=@p1; + f1(1); + f2(1); + if count<>3 then + begin + writeln('ERROR!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0386.pp b/tests/tbs/tb0386.pp new file mode 100644 index 0000000000..f24f4e53ce --- /dev/null +++ b/tests/tbs/tb0386.pp @@ -0,0 +1,17 @@ +{ %version=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} +uses ub0386; +type + tobj2 = class (tobj1) + { this will try to override tobj.proc1, it should not + see tobj1.proc1 } + procedure proc1 (a: integer);override; + end; + +procedure tobj2.proc1 (a: integer); +begin +end; + +begin +end. diff --git a/tests/tbs/tb0387.pp b/tests/tbs/tb0387.pp new file mode 100644 index 0000000000..2f9191a650 --- /dev/null +++ b/tests/tbs/tb0387.pp @@ -0,0 +1,33 @@ +{ %VERSION=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} +type + tobj1 = class + procedure proc1 (a: char); + end; + + tobj2 = class (tobj1) + procedure proc1 (a: integer);overload; + end; + +procedure tobj1.proc1 (a: char); +begin + write('tobj1.proc1(a:char) called: '); + writeln (a); +end; + +procedure tobj2.proc1 (a: integer); +begin + write('tobj2.proc1(a:integer) called: '); + writeln (a); +end; + +var + obj1: tobj1; + obj2: tobj2; +begin + obj1:=tobj1.create; + obj2:=tobj2.create; + + obj2.proc1 ('a'); +end. diff --git a/tests/tbs/tb0388.pp b/tests/tbs/tb0388.pp new file mode 100644 index 0000000000..225eb91d31 --- /dev/null +++ b/tests/tbs/tb0388.pp @@ -0,0 +1,51 @@ +{ %VERSION=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} +type + tobj = class + procedure proc1 (a: integer);virtual; + end; + + tobj1 = class(tobj) + procedure proc1 (a: integer);overload;override; + procedure proc1 (a: char);overload; + end; + + tobj2 = class (tobj1) + procedure proc1 (a: integer);override; + end; + +procedure tobj.proc1 (a: integer); +begin + write('tobj.proc1(a:integer) called: '); + writeln (a); +end; + +procedure tobj1.proc1 (a: integer); +begin + write('tobj1.proc1(a:integer) called: '); + writeln (a); +end; + +procedure tobj1.proc1 (a: char); +begin + write('tobj1.proc1(a:char) called: '); + writeln (a); +end; + +procedure tobj2.proc1 (a: integer); +begin + write('tobj2.proc1(a:integer) called: '); + writeln (a); +end; + +var + obj1: tobj1; + obj2: tobj2; +begin + obj1:=tobj1.create; + obj2:=tobj2.create; + + obj2.proc1 (100); + obj2.proc1 ('a'); +end. diff --git a/tests/tbs/tb0389.pp b/tests/tbs/tb0389.pp new file mode 100644 index 0000000000..d457cde4c9 --- /dev/null +++ b/tests/tbs/tb0389.pp @@ -0,0 +1,59 @@ +{ %VERSION=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} +type + tobj = class + procedure proc1 (a: integer);overload;virtual; + procedure proc1 (a: extended);overload; + end; + + tobj1 = class(tobj) + procedure proc1 (a: integer);overload;override; + procedure proc1 (a: char);overload; + end; + + tobj2 = class (tobj1) + procedure proc1 (a: integer);override; + end; + +procedure tobj.proc1 (a: integer); +begin + write('tobj.proc1(a:integer) called: '); + writeln (a); +end; + +procedure tobj.proc1 (a: extended); +begin + write('tobj.proc1(a:extended) called: '); + writeln (a); +end; + +procedure tobj1.proc1 (a: integer); +begin + write('tobj1.proc1(a:integer) called: '); + writeln (a); +end; + +procedure tobj1.proc1 (a: char); +begin + write('tobj1.proc1(a:char) called: '); + writeln (a); +end; + +procedure tobj2.proc1 (a: integer); +begin + write('tobj2.proc1(a:integer) called: '); + writeln (a); +end; + +var + obj1: tobj1; + obj2: tobj2; +begin + obj1:=tobj1.create; + obj2:=tobj2.create; + + obj2.proc1 (100); + obj2.proc1 ('a'); + obj2.proc1 (123.456); +end. diff --git a/tests/tbs/tb0390.pp b/tests/tbs/tb0390.pp new file mode 100644 index 0000000000..1873437f3b --- /dev/null +++ b/tests/tbs/tb0390.pp @@ -0,0 +1,30 @@ +{$ifdef fpc}{$mode objfpc}{$endif} +type + tobj = class + procedure proc1 (a: integer);virtual; + end; + + tobj1 = class (tobj) + procedure proc1 (a: char);overload; + end; + + tobj2 = class (tobj1) + { this will try to override tobj1.proc1 which is not + allowed and therefor needs an error } + procedure proc1 (a: integer);override; + end; + +procedure tobj.proc1 (a: integer); +begin +end; + +procedure tobj1.proc1 (a: char); +begin +end; + +procedure tobj2.proc1 (a: integer); +begin +end; + +begin +end. diff --git a/tests/tbs/tb0391.pp b/tests/tbs/tb0391.pp new file mode 100644 index 0000000000..2eb6c0dc69 --- /dev/null +++ b/tests/tbs/tb0391.pp @@ -0,0 +1,37 @@ +{ %version=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} +uses ub0391; + +type + tc1 = class + procedure p1(l:longint); + procedure p2; + end; + +procedure tc1.p1(l:longint); +begin + writeln('longint: ',l); +end; + + +procedure tc1.p2; +var + c2 : tc2; +begin + c2:=tc2.create; + { the next code should take tc1.p1(longint) as the tc2.p1 can not + be seen from here! } + with c2 do + p1(100); + c2.free; +end; + + +var + c1 : tc1; +begin + c1:=tc1.create; + c1.p2; + c1.free; +end. diff --git a/tests/tbs/tb0392.pp b/tests/tbs/tb0392.pp new file mode 100644 index 0000000000..4cbee7c99f --- /dev/null +++ b/tests/tbs/tb0392.pp @@ -0,0 +1,13 @@ +var + l: longint; + a: array[0..1] of char; + +begin + l := 50; + str(l,a); + if a <> '50' then + begin + writeln('error'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0393.pp b/tests/tbs/tb0393.pp new file mode 100644 index 0000000000..4abe1f0b86 --- /dev/null +++ b/tests/tbs/tb0393.pp @@ -0,0 +1,7 @@ +{ %OPT=-Sg} + +label 1; +begin + goto 1; +1: +end. diff --git a/tests/tbs/tb0394.pp b/tests/tbs/tb0394.pp new file mode 100644 index 0000000000..82a3130689 --- /dev/null +++ b/tests/tbs/tb0394.pp @@ -0,0 +1,30 @@ +{ %version=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} + +var + err : boolean; +procedure Demo(x:array of longint); + var + i:longint; + begin + if high(x)<>4 then + err:=true + else if x[4]<>14 then + err:=true; + for i:=low(x)to high(x)do + writeln(i,' ',x[i]); + end; +var + y:array[10..40]of longint; + i:longint; +begin + for i:=10 to 40 do + y[i]:=i; + Demo(slice(y,5)); + if err then + begin + writeln('ERROR!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0395.pp b/tests/tbs/tb0395.pp new file mode 100644 index 0000000000..73daed7cb8 --- /dev/null +++ b/tests/tbs/tb0395.pp @@ -0,0 +1,12 @@ +{ %VERSION=1.1 } +type + dummyrec = record + i : int64; + end; + +var + d: double; +begin + d := double(dummyrec($ffffffff80000000)); +end. + diff --git a/tests/tbs/tb0396.pp b/tests/tbs/tb0396.pp new file mode 100644 index 0000000000..5a512adc5c --- /dev/null +++ b/tests/tbs/tb0396.pp @@ -0,0 +1,10 @@ +{ %VERSION=1.1 } +{$ifdef fpc}{$mode objfpc}{$endif} +type + to2 = interface + function bufwrite(eat : boolean = true) : integer;stdcall; + end; + +begin +end. + diff --git a/tests/tbs/tb0397.pp b/tests/tbs/tb0397.pp new file mode 100644 index 0000000000..d03762afb5 --- /dev/null +++ b/tests/tbs/tb0397.pp @@ -0,0 +1,8 @@ +{ %version=1.1} +{$codepage cp850} +begin + if ord(widechar('Ž'))<>196 then + halt(1); + halt(0); +end. + diff --git a/tests/tbs/tb0398.pp b/tests/tbs/tb0398.pp new file mode 100644 index 0000000000..39d879aa18 --- /dev/null +++ b/tests/tbs/tb0398.pp @@ -0,0 +1,13 @@ +{ %version=1.1} +{$codepage cp850} +begin + if ord(widechar(#196))<>9472 then + halt(1); + if ord(#0196)<>196 then + halt(1); + if ord(widechar(#$a6))<>170 then + halt(1); + if ord(#$0a6)<>166 then + halt(1); + halt(0); +end. diff --git a/tests/tbs/tb0399.pp b/tests/tbs/tb0399.pp new file mode 100644 index 0000000000..912c4d4e51 --- /dev/null +++ b/tests/tbs/tb0399.pp @@ -0,0 +1,20 @@ +procedure error; + begin + writeln('Problem with octal constants'); + halt(1); + end; + +begin + if 8<>&10 then + error; + if 1<>&1 then + error; + if 64<>&100 then + error; + if 33<>&41 then + error; + if 33<>&41 then + error; + if 12345678<>&57060516 then + error; +end. diff --git a/tests/tbs/tb0400.pp b/tests/tbs/tb0400.pp new file mode 100644 index 0000000000..181d7ff952 --- /dev/null +++ b/tests/tbs/tb0400.pp @@ -0,0 +1,16 @@ +{ %version=1.1} +{$mode delphi} +var + b : byte; + i : smallint; + i64 : int64; + q : qword; + p : pointer; + +begin + p:=pointer(b); + p:=pointer(i); + p:=pointer(i64); + p:=pointer(q); +end. + diff --git a/tests/tbs/tb0401.pp b/tests/tbs/tb0401.pp new file mode 100644 index 0000000000..38a74ad62a --- /dev/null +++ b/tests/tbs/tb0401.pp @@ -0,0 +1,21 @@ +{ %version=1.1 } +var + b1,b2 : boolean; + c : char; + +begin + b1:=false; + b2:=true; + c:=char(b1 and b2); + if c<>#0 then + halt(1); + c:=char(b1 or b2); + if c<>#1 then + halt(1); + c:=char(b1); + if c<>#0 then + halt(1); + c:=char(b2); + if c<>#1 then + halt(1); +end. diff --git a/tests/tbs/tb0402.pp b/tests/tbs/tb0402.pp new file mode 100644 index 0000000000..85d28651c5 --- /dev/null +++ b/tests/tbs/tb0402.pp @@ -0,0 +1,16 @@ +{ %version=1.1 } +{$mode objfpc} +type + ta = array of longint; + +procedure p(i : iunknown;a : ta = nil); + + begin + end; + +var + o : tinterfacedobject; + +begin + p(o); +end. diff --git a/tests/tbs/tb0403.pp b/tests/tbs/tb0403.pp new file mode 100644 index 0000000000..f72520c34a --- /dev/null +++ b/tests/tbs/tb0403.pp @@ -0,0 +1,16 @@ +{$mode objfpc} + +type + tclass = class + procedure t; virtual; + end; + +procedure tclass.t; +begin +end; + +var + p: pointer; +begin + p := @tclass.t; +end. diff --git a/tests/tbs/tb0404.pp b/tests/tbs/tb0404.pp new file mode 100644 index 0000000000..9a91dfdc27 --- /dev/null +++ b/tests/tbs/tb0404.pp @@ -0,0 +1,17 @@ +type + G = object + public + B:procedure; + { the 1.1 compiler parses the next "public" as a procdirective of the preceding procedure } + public + constructor init; + end; + + constructor G.init; + begin + B:=nil; + end; + +begin +end. + diff --git a/tests/tbs/tb0405.pp b/tests/tbs/tb0405.pp new file mode 100644 index 0000000000..fc0e99528d --- /dev/null +++ b/tests/tbs/tb0405.pp @@ -0,0 +1,39 @@ +{ %version=1.1 } + +{$ifdef fpc}{$mode objfpc}{$endif} + +var + err : boolean; + +type + tc1=class + constructor Create;overload; + end; + + tc2=class(tc1) + constructor Create(l:longint=0);overload; + end; + +constructor tc1.create; +begin + writeln('tc1.create()'); +end; + +constructor tc2.create(l:longint); +begin + writeln('tc2.create()'); + err:=false; +end; + +var + c : tc2; +begin + err:=true; + c:=tc2.create(); + c.free; + if err then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0406.pp b/tests/tbs/tb0406.pp new file mode 100644 index 0000000000..1078cbcdd7 --- /dev/null +++ b/tests/tbs/tb0406.pp @@ -0,0 +1,11 @@ +unit tb0406; + +{$ifndef WITH_FULL} + +interface +uses ub0406; + +implementation + +end. +{$endif} diff --git a/tests/tbs/tb0407.pp b/tests/tbs/tb0407.pp new file mode 100644 index 0000000000..25c7f024e7 --- /dev/null +++ b/tests/tbs/tb0407.pp @@ -0,0 +1,45 @@ +{ %version=1.1 } + +{$ifdef fpc}{$mode delphi}{$endif} + +var + err : boolean; + +type + tc1=class(tinterfacedobject) + constructor Create;overload; + constructor Create(s:string);overload; + end; + + tc2=class(tc1) + constructor Create(l1,l2:longint);overload; + end; + +constructor tc1.create; +begin + err:=true; +end; + +constructor tc1.create(s:string); +begin + err:=true; +end; + +constructor tc2.create(l1,l2:longint); +begin + { The next line should do nothing } + inherited; +end; + +var + c : tc2; +begin + err:=false; + c:=tc2.create(1,1); + c.free; + if err then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0408.pp b/tests/tbs/tb0408.pp new file mode 100644 index 0000000000..1d67d351e5 --- /dev/null +++ b/tests/tbs/tb0408.pp @@ -0,0 +1,22 @@ +{ This passes under Delphi and Borland pascal } +{ for objects, classes don't pass, cf. /tbf/tb0125 } +type + + tobjsymbol = object + end; + + tobjderivedsymbol = object(tobjsymbol) + end; + + + +procedure testobject(var t: tobjsymbol); +begin +end; + + +var + myobject : tobjderivedsymbol; +begin + testobject(myobject); +end. diff --git a/tests/tbs/tb0409.pp b/tests/tbs/tb0409.pp new file mode 100644 index 0000000000..c49e8df1de --- /dev/null +++ b/tests/tbs/tb0409.pp @@ -0,0 +1,21 @@ +{ %version=1.1 } +type + myl = type longint; + +var + i1,i2,i3 : myl; + l : longint; + +procedure p(i : myl);overload; +begin +end; + +procedure p(i : longint);overload; +begin +end; + +begin + i1:=i2+i3; + l:=i1+l; + inc(i3); +end. diff --git a/tests/tbs/tb0410.pp b/tests/tbs/tb0410.pp new file mode 100644 index 0000000000..fbb15acf41 --- /dev/null +++ b/tests/tbs/tb0410.pp @@ -0,0 +1,22 @@ +{ %version=1.1 } +uses + variants; + +procedure p1(f : single); + begin + end; + +procedure p2(l : longint); + begin + end; + +var + v : variant; + l : longint; + +begin + v:=1; + p1(v); + p2(v); + l:=v; +end. diff --git a/tests/tbs/tb0411.pp b/tests/tbs/tb0411.pp new file mode 100644 index 0000000000..0f43afb0b8 --- /dev/null +++ b/tests/tbs/tb0411.pp @@ -0,0 +1,16 @@ +{ %version=1.1} + +{$mode objfpc} + +type + ta = array of longint; + +function f : ta; + begin + setlength(result,10); + end; + +begin + f[1]:=1; +end. + diff --git a/tests/tbs/tb0412.pp b/tests/tbs/tb0412.pp new file mode 100644 index 0000000000..bbf8d304c6 --- /dev/null +++ b/tests/tbs/tb0412.pp @@ -0,0 +1,30 @@ +{ %version=1.1 } +{$mode objfpc} +{$r+} +uses + sysutils; + +var + a : array of longint; + +begin + try + a[10]:=1; + except + setlength(a,3); + a[0]:=1; + a[1]:=1; + a[2]:=1; + try + a[3]:=1; + except + try + a[-1]:=1; + except + halt(0); + end; + end; + end; + writeln('Problem with dyn. array range checking'); + halt(1); +end. diff --git a/tests/tbs/tb0413.pp b/tests/tbs/tb0413.pp new file mode 100644 index 0000000000..fc8f8c7cfb --- /dev/null +++ b/tests/tbs/tb0413.pp @@ -0,0 +1,22 @@ +{$mode fpc} + +var + s : ansistring; + ss : shortstring; + as : ansistring; + c : char; + +begin + as:='ansistring'; + ss:='shortstring'; + c:='C'; + s:=s+as; + s:=s+c; + s:=s+ss; + s:=s+s; + if s<>'ansistringCshortstringansistringCshortstring' then + begin + writeln('Problem with ansistring appending'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0414.pp b/tests/tbs/tb0414.pp new file mode 100644 index 0000000000..00f7a9f963 --- /dev/null +++ b/tests/tbs/tb0414.pp @@ -0,0 +1,43 @@ +{ %CPU=m68k } + +{ This tests the $E+ compiler + switch. It verifies if the + switch is correctly enabled + depending on the target OS + for m68k. +} +program tb0414; +{$ifdef amiga} +{ Emulation is off by default } +{$ifopt E-} +{$error Emulation is disabled by default for amiga!!} +{$endif} +{$endif} + +{$ifdef atari} +{ Emulation is off by default } +{$ifopt E-} +{$error Emulation is disabled by default for amiga!!} +{$endif} +{$endif} + + +{$ifdef netbsd} +{ Emulation is on by default } +{$ifopt E+} +{$error Emulation is enabled by default for unix!!} +{$endif} +{$endif} + +{$ifdef linux} +{ Emulation is on by default } +{$ifopt E+} +{$error Emulation is enabled by default for unix!!} +{$endif} +{$endif} + + + + +Begin +End. diff --git a/tests/tbs/tb0415.pp b/tests/tbs/tb0415.pp new file mode 100644 index 0000000000..78ce700535 --- /dev/null +++ b/tests/tbs/tb0415.pp @@ -0,0 +1,48 @@ +{ %CPU=i386 } + +{ + Testing if using the same local label in two + procedures does not create an error PM +} + +program test_local_labels; + + +{$asmmode att} + +procedure att_test1; assembler; + +asm + jmp .Llocal +.Llocal: +end; + +procedure att_test2; assembler; + +asm + jmp .Llocal +.Llocal: +end; + +{$asmmode intel} + +procedure intel_test1; assembler; + +asm + jmp @@Llocal +@@Llocal: +end; + +procedure intel_test2; assembler; + +asm + jmp @@Llocal +@@Llocal: +end; + +begin + att_test1; + att_test2; + intel_test1; + intel_test2; +end. diff --git a/tests/tbs/tb0416.pp b/tests/tbs/tb0416.pp new file mode 100644 index 0000000000..d4e3350cf9 --- /dev/null +++ b/tests/tbs/tb0416.pp @@ -0,0 +1,19 @@ +function f: string; + + procedure t; + begin + f := 'test'; + end; + +begin + t; +end; + + +begin + if f <> 'test' then + begin + writeln('error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0417.pp b/tests/tbs/tb0417.pp new file mode 100644 index 0000000000..646b9d0839 --- /dev/null +++ b/tests/tbs/tb0417.pp @@ -0,0 +1,36 @@ +{ Testing smallset + normset } +{ with respect to normset + smallset } + + +type + charset=set of char; + + var + err : byte; + tr,tr2 : charset; + + + procedure test(const k:charset); + + begin + tr:=[#7..#10]+k; + tr2:=k+[#7..#10]; + end; + + begin + err:=0; + Test([#20..#32]); + if not(#32 in tr) then + err:=1; + if ([#33..#255]*tr <> []) then + err:=2; + if (tr<>[#7..#10,#20..#32]) then + err:=3; + if (tr<>tr2) then + err:=4; + if err<>0 then + begin + Writeln('Bug in set handling, see err:=',err); + halt(1); + end; + end. diff --git a/tests/tbs/tb0418.pp b/tests/tbs/tb0418.pp new file mode 100644 index 0000000000..55c165ce7c --- /dev/null +++ b/tests/tbs/tb0418.pp @@ -0,0 +1,9 @@ + +procedure array_test(b: integer; parr: array of word; c: integer); +begin +end; + + +begin + array_test(0,[12,33,45],0); +end. diff --git a/tests/tbs/tb0419.pp b/tests/tbs/tb0419.pp new file mode 100644 index 0000000000..42af8d0def --- /dev/null +++ b/tests/tbs/tb0419.pp @@ -0,0 +1,21 @@ + +var + nc : integer; + test_w : word; + +procedure array_test(b: integer; parr: array of word; c: integer);cdecl; +begin + nc:=c; + test_w:=parr[2]; +end; + + +begin + nc:=5; + test_w:=$abcd; + array_test(0,[1,2,3,4],56); + if (nc<>56) or (test_w<>3) then + begin + Writeln('Wrong code generated'); + end; +end. diff --git a/tests/tbs/tb0420.pp b/tests/tbs/tb0420.pp new file mode 100644 index 0000000000..10f477fd84 --- /dev/null +++ b/tests/tbs/tb0420.pp @@ -0,0 +1,11 @@ + +procedure array_test(b: integer; parr: array of word; c: integer);cdecl; +begin +end; + + +var + a: array[1..12] of word; +begin + array_test(0,a,0); +end. diff --git a/tests/tbs/tb0421.pp b/tests/tbs/tb0421.pp new file mode 100644 index 0000000000..87fa7ba63a --- /dev/null +++ b/tests/tbs/tb0421.pp @@ -0,0 +1,16 @@ +{ %version=1.1 } +{ %recompile } + +uses ub0421a; + +var + c : cl3; +begin + c:=cl3.create; + writeln(c.f); + if (c.f<>10) then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0422.pp b/tests/tbs/tb0422.pp new file mode 100644 index 0000000000..ddea88f3a1 --- /dev/null +++ b/tests/tbs/tb0422.pp @@ -0,0 +1,28 @@ +{$ifdef fpc}{$mode delphi}{$endif} + +type + tcl = class + function f1 : tvarrec; virtual; + end; + +var + f : function : tvarrec of object; + +function tcl.f1 : tvarrec; +begin + fillchar(result,sizeof(result),0); +end; + + +procedure p1(v : tvarrec); + begin + end; + + +var + c : tcl; +begin + c:=tcl.create; + f:=c.f1; + p1(f); +end. diff --git a/tests/tbs/tb0423.pp b/tests/tbs/tb0423.pp new file mode 100644 index 0000000000..74b14fc063 --- /dev/null +++ b/tests/tbs/tb0423.pp @@ -0,0 +1,13 @@ +{$ifdef fpc}{$mode delphi}{$endif} + +type + tmethod = record + code,data : pointer; + end; + +var + p : procedure(l : longint) of object; + +begin + tmethod(p).data:=nil; +end. diff --git a/tests/tbs/tb0424.pp b/tests/tbs/tb0424.pp new file mode 100644 index 0000000000..4ae0371002 --- /dev/null +++ b/tests/tbs/tb0424.pp @@ -0,0 +1,33 @@ +{ %VERSION=1.1 } +{ %OPT=-Sew -vw } + +{$MODE OBJFPC} + +{ This tests that implemented abstract methods do not cause any warnings } +type + tmyclass = class + procedure myabstract; virtual; abstract; + end; + + tmyclass2 = class(tmyclass) + procedure myabstract ; override; + end; + + + procedure tmyclass2.myabstract; + begin + end; + + +var + cla : tmyclass2; +Begin + cla := tmyclass2.create; +end. + +{ + $Log: tb0424.pp,v $ + Revision 1.2 2005/02/14 17:13:35 peter + * truncate log + +} diff --git a/tests/tbs/tb0425.pp b/tests/tbs/tb0425.pp new file mode 100644 index 0000000000..efb2e3dc80 --- /dev/null +++ b/tests/tbs/tb0425.pp @@ -0,0 +1,8 @@ +{$mode delphi} + +var + glResizeBuffersMESA: procedure(); cdecl; + +begin + if not Assigned(glResizeBuffersMESA) then; +end. diff --git a/tests/tbs/tb0426.pp b/tests/tbs/tb0426.pp new file mode 100644 index 0000000000..681d3b76a6 --- /dev/null +++ b/tests/tbs/tb0426.pp @@ -0,0 +1,12 @@ +{ %VERSION=1.1 } +uses ub0426; + + +Begin + myroutine; + myroutine2; + myroutine3; + z:=0; +end. + + diff --git a/tests/tbs/tb0427.pp b/tests/tbs/tb0427.pp new file mode 100644 index 0000000000..8bcd2d08f3 --- /dev/null +++ b/tests/tbs/tb0427.pp @@ -0,0 +1,80 @@ +{$MODE objFPC} +unit tb0427; +// Purpose: Demonstrate Internal Error #10 +// +// Version: Free Pascal Compiler version 1.0.6 [2002/04/23] for i386 +// Copyright (c) 1993-2002 by Florian Klaempfl +// +// Compiler Output: +// Free pascal Compiler version 1.0.6 [2002/04/23] for i386 +// Copyright (c) 1993-2002 by Florian Klaempfl +// Target OS: Win32 for i386 +// Compiling c:\windows\desktop\files\projects\sageapi\t.pas +// t.pas(68,51) Fatal: Internal error 10 +// +// Bug Contributor: +// Jason Sage +// jazesage@aol.com +// +// Date Contributed: 2002-12-01 +// System OS: MS Windows ME v4.90.3000 +// System: Compaq, Genuine Intel, Intel(r) Celeron(tm) processor +// 63.0MB Ram +// +interface + +implementation + +type TClass = class + protected + VBuf: ^word; + public + constructor Init; + destructor Done; + procedure Test(p_dwNewWidth, p_dwNewHeight: Cardinal); +end; + +var + MyClass: TClass; + +constructor TClass.Init; begin GetMem(VBuf,2); end; + +destructor TClass.Done; begin freemem(VBuf); end; + +procedure TClass.Test(p_dwNewWidth, p_dwNewHeight: Cardinal); +var + OldVBuf: ^word; + t,s: Cardinal; + w,h: Cardinal; // preserve Width and Height of VC + wData: word; +begin + getmem(OldVBuf,1); freemem(OldVBuf); // shutoff hint + w:=w; h:=h; // shut off hint + OldVBuf:=VBuf; + GetMem(VBuf, p_dwNewWidth * p_dwNewHeight * 2); + for t:=1 to W do // won't cause error if you do this the more efficient + begin // way: for t:=0 to W-1 do + for s:=1 to H do// for s:=0 to H-1 do + begin // and replace the [(t-1)+((s-1)*W)] logic to [t+s*w] + if (t<=p_dwNewWidth) and (s<=p_dwNewHeight) then + begin + { + // This is the work around that I used in my UNIT and the code Works + wData:=OldVBuf[(t-1)+(s-1)*H]; + VBuf[(t-1)+((s-1)*p_dwNewWidth)]:=wData; + } + + // This way causes an Internal Error 10 from the compiler. + VBuf[(t-1)+((s-1)*p_dwNewWidth)]:=OldVBuf[(t-1)+(s-1)*H]; + end; + end; + end; + Freemem(OldVBuf); +end; + +begin + MyClass:=TClass.Init; + MyClass.Test(1,1); + MyClass.Done; +end. + diff --git a/tests/tbs/tb0428.pp b/tests/tbs/tb0428.pp new file mode 100644 index 0000000000..46d484a2f1 --- /dev/null +++ b/tests/tbs/tb0428.pp @@ -0,0 +1,34 @@ +{ Testing smallset + normset } +{ with respect to normset + smallset } + + +type + charset=set of char; + + var + tr,tr2 : charset; + + + procedure test(const k:charset); + + begin + tr:=[#7..#10]+k; + tr2:=k+[#7..#10]; + if (tr<>tr2) then + begin + Writeln('Bug in set handling'); + halt(1); + end; + end; + + begin + Test([#20..#32]); + if not(#32 in tr) or ([#33..#255]*tr <> []) or + (tr<>[#7..#10,#20..#32]) or + (tr<>tr2) then + begin + Writeln('Bug in set handling'); + halt(1); + end; + + end. diff --git a/tests/tbs/tb0429.pp b/tests/tbs/tb0429.pp new file mode 100644 index 0000000000..c5a15dcba0 --- /dev/null +++ b/tests/tbs/tb0429.pp @@ -0,0 +1,45 @@ +{ %version=1.1 } + +var + err : boolean; + +procedure lowercase(c:char);overload; +begin + writeln('char'); +end; +procedure lowercase(c:shortstring);overload; +begin + writeln('short'); + err:=false; +end; +procedure lowercase(c:ansistring);overload; +begin + writeln('ansi'); +end; + +var + w : widestring; + s : ansistring; + i : longint; +begin + err:=true; + { this should choosse the shortstring version } + lowercase(w); + if err then + begin + writeln('Wrong lowercase Error!'); + halt(1); + end; + + { check if ansistring pos() call is not broken } + s:=''; + for i:=1 to 300 do s:=s+'.'; + s:=s+'test'; + if pos('test',s)<>301 then + begin + writeln('Pos(ansistring) Error!'); + halt(1); + end; + +end. + diff --git a/tests/tbs/tb0430.pp b/tests/tbs/tb0430.pp new file mode 100644 index 0000000000..37598a94b4 --- /dev/null +++ b/tests/tbs/tb0430.pp @@ -0,0 +1,19 @@ +{$ifdef fpc}{$mode delphi}{$endif} + +function f1:pointer; +begin + result:=nil; +end; + +var + func: function:pointer; +begin + func:=f1; + { Assigned() works on the procvar and does not + call func } + if not assigned(func) then + begin + writeln('ERROR!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0431.pp b/tests/tbs/tb0431.pp new file mode 100644 index 0000000000..bf5341729c --- /dev/null +++ b/tests/tbs/tb0431.pp @@ -0,0 +1,26 @@ +{ the smallest falling test I ever found PM } +{ the code generated a shll #0,%edx on i386 + which was bad but harmless... + but on m68K it generated a asl.l #0,%d2 + which is not correct ... } + +const + has_errors : boolean = false; +var + x : longint; +begin + x:=5; + x:=x*1; + if x<>5 then + has_errors:=true; + x:=5; + x:=x shl 0; + if x<>5 then + has_errors:=true; + x:=5; + x:=x shr 0; + if x<>5 then + has_errors:=true; + if has_errors then + halt(1); +end. diff --git a/tests/tbs/tb0432.pp b/tests/tbs/tb0432.pp new file mode 100644 index 0000000000..e1e9b93b18 --- /dev/null +++ b/tests/tbs/tb0432.pp @@ -0,0 +1,30 @@ +{ %KNOWNRUNERROR=2 On some OS invalid date are converted to valid ones, thus test fails} +uses Dos; +var + f : file; + l : longint; + dt : datetime; +begin + assign(f,'tb0432.tmp'); + rewrite(f); + close(f); + + { Set Invalid date } + dt.year:=2001; + dt.month:=2; + dt.day:=30; + packtime(dt,l); + + SetFTime(f,l); + writeln(doserror); + + if doserror<>13 then + begin + Writeln('Wrong doserror'); + if doserror=0 then + runerror(2) + else + halt(1); + end; + +end. diff --git a/tests/tbs/tb0433.pp b/tests/tbs/tb0433.pp new file mode 100644 index 0000000000..f04806c478 --- /dev/null +++ b/tests/tbs/tb0433.pp @@ -0,0 +1,37 @@ +{$ifdef fpc} +{$mode tp} +{$endif fpc} + +function times2(x : longint) : longint; + +begin + times2:=2*x; +end; + +var + x:function(x:longint):longint; + y:pointer absolute x; + z,w,v:pointer; +begin + z:=@@x; + w:=addr(@x); + v:=@(addr(x)); + writeln(longint(y),' ',longint(z),' ',longint(w),' ',longint(v)); + if (z<>w) or (z<>v) then + begin + writeln('Addr Error'); + halt(1); + end; + if (y<>nil) then + begin + writeln('Absolute Error'); + halt(1); + end; + x:=times2; + if (y<>@times2) then + begin + writeln('Absolute Error'); + halt(1); + end; + +end. diff --git a/tests/tbs/tb0433a.pp b/tests/tbs/tb0433a.pp new file mode 100644 index 0000000000..a3b70eefd7 --- /dev/null +++ b/tests/tbs/tb0433a.pp @@ -0,0 +1,32 @@ +{$ifdef fpc} +{$mode delphi} +{$endif fpc} + +function times2(x : longint) : longint; + +begin + times2:=2*x; +end; + +var + x:function(x:longint):longint; + y:pointer absolute x; + z,w,v:pointer; +begin + x:=times2; + z:=@x; + w:=addr(x); + v:=@times2; + writeln(longint(y),' ',longint(z),' ',longint(w),' ',longint(v)); + if (z<>w) or (z<>v) or (y<>z) then + begin + writeln('Addr Error'); + halt(1); + end; + if (y<>@times2) then + begin + writeln('Absolute Error'); + halt(1); + end; + +end. diff --git a/tests/tbs/tb0433b.pp b/tests/tbs/tb0433b.pp new file mode 100644 index 0000000000..3fa52fc684 --- /dev/null +++ b/tests/tbs/tb0433b.pp @@ -0,0 +1,37 @@ +{$ifdef fpc} +{$mode fpc} +{$endif fpc} + +function times2(x : longint) : longint; + +begin + times2:=2*x; +end; + +var + x:function(x:longint):longint; + y:pointer absolute x; + z,w,v:pointer; +begin + z:=@x; + w:=addr(x); + v:=@y; + writeln(longint(y),' ',longint(z),' ',longint(w),' ',longint(v)); + if (z<>w) or (z<>v) then + begin + writeln('Addr Error'); + halt(1); + end; + if (y<>nil) then + begin + writeln('Absolute Error'); + halt(1); + end; + x:=@times2; + if (y<>pointer(@times2)) then + begin + writeln('Absolute Error'); + halt(1); + end; + +end. diff --git a/tests/tbs/tb0434.pp b/tests/tbs/tb0434.pp new file mode 100644 index 0000000000..eecc4f8bae --- /dev/null +++ b/tests/tbs/tb0434.pp @@ -0,0 +1,19 @@ + +function dummy : longint; +begin + dummy:=1; +end; + +var + x:function:longint; + x2:function:longint; + y:pointer absolute x; + y2:pointer absolute x2; +begin + x2:=@dummy; + if (y<>nil) or (y2<>pointer(@dummy)) then + begin + Writeln('Wrong code generated for absolute to procvarsmy'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0435.pp b/tests/tbs/tb0435.pp new file mode 100644 index 0000000000..acdb3631be --- /dev/null +++ b/tests/tbs/tb0435.pp @@ -0,0 +1,10 @@ + +{$ifdef fpc}{$mode Delphi}{$endif} + +var + x:function(x:longint):longint; + y:pointer absolute x; +begin + if y<>nil then + halt(1); +end. diff --git a/tests/tbs/tb0436.pp b/tests/tbs/tb0436.pp new file mode 100644 index 0000000000..a811088260 --- /dev/null +++ b/tests/tbs/tb0436.pp @@ -0,0 +1,15 @@ +{$mode objfpc} + +procedure pext(a:array of extended); +begin +end; + +procedure p(a:array of const); +begin +end; + +begin + p([0.0]); + p([pi]); + pext([0.0]); +end. diff --git a/tests/tbs/tb0437.pp b/tests/tbs/tb0437.pp new file mode 100644 index 0000000000..664c16d937 --- /dev/null +++ b/tests/tbs/tb0437.pp @@ -0,0 +1,6 @@ +{ %version=1.1} +uses + ub0437c; + +begin +end. diff --git a/tests/tbs/tb0438.pp b/tests/tbs/tb0438.pp new file mode 100644 index 0000000000..63d501219e --- /dev/null +++ b/tests/tbs/tb0438.pp @@ -0,0 +1,33 @@ +{$ifdef fpc}{$mode objfpc}{$endif} + +procedure p(a : array of const); + var + i : integer; + begin + for i:=low(a) to high(a) do + begin + write(i,': '); + if (a[i].vtype=vtpchar) then + begin + writeln('"',a[i].vpchar,'"'); + if (a[i].vpchar<>'test') then + begin + writeln('Wrong string content'); + halt(1); + end; + end + else + begin + writeln('No string type (',a[i].vtype,')'); + halt(1); + end; + end; + end; + +var + a : array[0..25] of char; + +begin + a:='test'; + p([a,a]); +end. diff --git a/tests/tbs/tb0439.pp b/tests/tbs/tb0439.pp new file mode 100644 index 0000000000..7d0ebc1315 --- /dev/null +++ b/tests/tbs/tb0439.pp @@ -0,0 +1,9 @@ +{$mode delphi} + +var + a : array[0..32] of char; + p : pchar; + i : integer; +begin + p:=a+i; +end. diff --git a/tests/tbs/tb0440.pp b/tests/tbs/tb0440.pp new file mode 100644 index 0000000000..3a84ae2f79 --- /dev/null +++ b/tests/tbs/tb0440.pp @@ -0,0 +1,10 @@ +{$mode delphi} +uses ub0440; + +procedure ub0440; +begin +end; + +begin + ub0440; +end. diff --git a/tests/tbs/tb0441.pp b/tests/tbs/tb0441.pp new file mode 100644 index 0000000000..8320c34d11 --- /dev/null +++ b/tests/tbs/tb0441.pp @@ -0,0 +1,12 @@ +{$mode fpc} + +operator :=(x:LongInt)RESULT:ShortString; + begin + Val(RESULT,x); + end; + +var + s:ShortString; +begin + s:=12; +end. diff --git a/tests/tbs/tb0442.pp b/tests/tbs/tb0442.pp new file mode 100644 index 0000000000..fe2ace5b24 --- /dev/null +++ b/tests/tbs/tb0442.pp @@ -0,0 +1,7 @@ +{ %version=1.1 } +const + CUnicodeNormal1 : WideChar = WideChar($FEFF); + CUnicodeNormal2 : WideChar = #12; + +begin +end. diff --git a/tests/tbs/tb0443.pp b/tests/tbs/tb0443.pp new file mode 100644 index 0000000000..7d3048997b --- /dev/null +++ b/tests/tbs/tb0443.pp @@ -0,0 +1,21 @@ +{ %version=1.1} +{$ifdef fpc} + {$mode delphi} +{$else} +type + qword = int64; +{$endif} + +var + b : byte; + i : smallint; + i64 : int64; + q : qword; + p : pointer; + +begin + p:=pointer(b); + p:=pointer(i); + p:=pointer(i64); + p:=pointer(q); +end. diff --git a/tests/tbs/tb0444.pp b/tests/tbs/tb0444.pp new file mode 100644 index 0000000000..66ab245587 --- /dev/null +++ b/tests/tbs/tb0444.pp @@ -0,0 +1,14 @@ +{$mode delphi} +unit tb0444; +interface + +function Trunc(const x : Single) : Integer; + +implementation + +function Trunc(const x : Single) : Integer; + register; +asm +end; + +end. diff --git a/tests/tbs/tb0445.pp b/tests/tbs/tb0445.pp new file mode 100644 index 0000000000..eb5b146f32 --- /dev/null +++ b/tests/tbs/tb0445.pp @@ -0,0 +1,12 @@ +type + tproc = procedure(self,l2:longint); + +procedure p(l1,l2:longint); +begin +end; + +var + pv : tproc; +begin + pv:={$ifdef fpc}@{$endif}p; +end. diff --git a/tests/tbs/tb0446.pp b/tests/tbs/tb0446.pp new file mode 100644 index 0000000000..e4d6f72ca3 --- /dev/null +++ b/tests/tbs/tb0446.pp @@ -0,0 +1,13 @@ +var + a : array[0..9] of char; + pc : pchar; +begin + a:='1'; + if a=nil then + halt(1); + pc:=@a; + if pc<>'1' then + halt(1); + writeln('OK') +end. + diff --git a/tests/tbs/tb0447.pp b/tests/tbs/tb0447.pp new file mode 100644 index 0000000000..87445de35c --- /dev/null +++ b/tests/tbs/tb0447.pp @@ -0,0 +1,15 @@ +{ %version=1.1 } + +{$R+} +var + a : cardinal; + b : longint; +begin + a := 0; + b := -1; + if a > b then + writeln ('OK') + else + halt(1); +end. + diff --git a/tests/tbs/tb0447a.pp b/tests/tbs/tb0447a.pp new file mode 100644 index 0000000000..b61aa0274e --- /dev/null +++ b/tests/tbs/tb0447a.pp @@ -0,0 +1,14 @@ +{ %version=1.1 } + +var + a : cardinal; + b : longint; +begin + a := 0; + b := -1; + if a > b then + writeln ('OK') + else + halt(1); +end. + diff --git a/tests/tbs/tb0448.pp b/tests/tbs/tb0448.pp new file mode 100644 index 0000000000..8986a35989 --- /dev/null +++ b/tests/tbs/tb0448.pp @@ -0,0 +1,26 @@ +{$mode delphi} + +var + err : boolean; + +procedure p1(s:string);overload; +begin +end; + +procedure p1(l:longint);overload; +begin + err:=false; +end; + +var + pv : procedure(l:longint); +begin + err:=true; + pv:=p1; + pv(1); + if err then + begin + writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0449.pp b/tests/tbs/tb0449.pp new file mode 100644 index 0000000000..a7f6a017e3 --- /dev/null +++ b/tests/tbs/tb0449.pp @@ -0,0 +1,20 @@ +{ %RESULT=217 } + +{$ifdef fpc} +{$mode objfpc} +{$endif} +uses SysUtils; + +type + EWbcError = class of Exception; + +Begin + raise EwbcError.create('Hello'); +end. + +{ + $Log: tb0449.pp,v $ + Revision 1.3 2005/02/14 17:13:35 peter + * truncate log + +} diff --git a/tests/tbs/tb0450.pp b/tests/tbs/tb0450.pp new file mode 100644 index 0000000000..865102fa8d --- /dev/null +++ b/tests/tbs/tb0450.pp @@ -0,0 +1,16 @@ + +var + i: single; +Begin + case round(i) of + 0: WriteLn; + 1: WriteLn; + end; +end. + +{ + $Log: tb0450.pp,v $ + Revision 1.2 2005/02/14 17:13:35 peter + * truncate log + +} diff --git a/tests/tbs/tb0451.pp b/tests/tbs/tb0451.pp new file mode 100644 index 0000000000..ea6f2fb075 --- /dev/null +++ b/tests/tbs/tb0451.pp @@ -0,0 +1,74 @@ +{ %version=1.1 } + +{$mode delphi} + +{ taken from fpc-devel mailing list, posted by } +{ "Morten Juel Skovrup" <ms@mek.dtu.dk> } +program tb0451; + +procedure error(l : longint); + begin + writeln('Error: ',l); + halt(1); + end; + +type + TDoubleArray = array of Double; + TTestProp = + record + TestItem : Double; + end; + TTestPropArray = array of TTestProp; + + TTestClass = + class + private + FTestProp: TTestPropArray; + public + constructor Create; + destructor Destroy; override; + property TestProp : TTestPropArray read FTestProp; + end; + +procedure Init(var AnArray : array of Double); +var + i : Integer; +begin + for i:=0 to High(AnArray) do + AnArray[i] := 1; +end; + +var + Test : TDoubleArray; + i : Integer; + TestClass : TTestClass; + +constructor TTestClass.Create; +begin + inherited Create; + SetLength(FTestProp,2); +end; + +destructor TTestClass.Destroy; +begin + Finalize(FTestProp); + inherited Destroy; +end; + +begin + SetLength(Test,5); + Init(Test); //!!! FPC compile error - Delphi compiles fine... + for i:=0 to High(Test) do + if test[i]<>1 then + error(1); + Finalize(Test); + + TestClass := TTestClass.Create; + with TestClass.TestProp[1] do //!!! FPC stops with runtime-error 201 + TestItem := 2; + if TestClass.TestProp[0].TestItem<>0 then + error(2); + if TestClass.TestProp[1].TestItem<>2 then + error(3); + TestClass.Free; +end. diff --git a/tests/tbs/tb0453.pp b/tests/tbs/tb0453.pp new file mode 100644 index 0000000000..7ae8a43dd0 --- /dev/null +++ b/tests/tbs/tb0453.pp @@ -0,0 +1,47 @@ +{$MODE objfpc} +uses SysUtils, Classes; +type + TFirstClass = class + constructor Create; + destructor Destroy; override; + end; + TSecondClass = class(TFirstClass) + constructor Create; + destructor Destroy; override; + end; + +constructor TFirstClass.Create; +begin + raise Exception.Create(''); +end; + +destructor TFirstClass.Destroy; +begin + WriteLn('TFirstClass.Destroy'); + inherited Destroy; +end; + +constructor TSecondClass.Create; +begin + inherited Create; +end; + +destructor TSecondClass.Destroy; +begin + WriteLn('TSecondClass.Destroy'); +end; + +var + o: TSecondClass; +begin + try + try + o := TSecondClass.Create; + finally + o.Free; + end; + except + on e: Exception do + WriteLn('Exception: ', e.Message); + end; +end. diff --git a/tests/tbs/tb0454.pp b/tests/tbs/tb0454.pp new file mode 100644 index 0000000000..9949f831d3 --- /dev/null +++ b/tests/tbs/tb0454.pp @@ -0,0 +1,33 @@ +program tb0454; +{ reported on fpc-devel by Jesus Reyes <jesusrmx@yahoo.com.mx> on 14 July 2003 } +{ as failing with 1.1 } +{$mode objfpc} +var + a,b: integer; + c,d,e,f: boolean; + +function Ok: boolean; +begin + result := ( a = b ) + and c = d + and e = f; +end; + +var + r: boolean; +begin + a := 1; + b := 2; + c := false; + d := true; + e := false; + f := true; + + r := Ok; + if not r then + begin + writeln('error, result should be true'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0455.pp b/tests/tbs/tb0455.pp new file mode 100644 index 0000000000..497daf43e1 --- /dev/null +++ b/tests/tbs/tb0455.pp @@ -0,0 +1,60 @@ +{$IFDEF FPC} +{$MODE DELPHI} +{$ENDIF} +uses classes; + + +type + HDC = Cardinal; + + TNotifyEventA = procedure (Sender:TObject) of object; + + TwolBrushes = class + public + FOnChange :TNotifyEventA; + procedure Wol_Changed; + property OnChange :TNotifyEventA read FOnChange Write FOnChange; + end; + + + TWOLBetaObject = class + public + mylocalvar : integer; + constructor Create(AOwner:TOBject); + protected + procedure DoBrushChange(Sender:TObject); + private + FBrush : TWolBrushes; + end; + + + procedure TWOLBetaObject.DoBrushChange(Sender:TObject); + var DC:HDC; + begin + mylocalvar:=12; + WriteLn('OK!'); + end; + + + procedure TwolBrushes.WOL_Changed; + begin + if Assigned(FOnChange) then FOnChange(Self); + end; + + + + +constructor TWOLBetaObject.Create(AOwner:TOBject); + begin + Inherited Create; + FBrush :=TWOLBrushes.Create; + FBrush.OnChange:=DoBrushChange; + end; + + +var + cla1: TWolbetaObject; +begin + cla1:=TWolBetaObject.create(nil); + cla1.FBrush.WOL_Changed; +end. diff --git a/tests/tbs/tb0456.pp b/tests/tbs/tb0456.pp new file mode 100644 index 0000000000..5630c8e3f3 --- /dev/null +++ b/tests/tbs/tb0456.pp @@ -0,0 +1,11 @@ +{$ifdef fpc}{$mode delphi}{$endif} + +type + c=class + function Byte: Byte; virtual; abstract; + function P(b: Byte):boolean; virtual; abstract; + end; + +begin +end. + diff --git a/tests/tbs/tb0457.pp b/tests/tbs/tb0457.pp new file mode 100644 index 0000000000..b75a9e9918 --- /dev/null +++ b/tests/tbs/tb0457.pp @@ -0,0 +1,27 @@ +{ %version=1.1} +{$mode objfpc} +program testa; + +Type + TA = array of Integer; + +var + A,B : TA; + I,J : Integer; +begin + Setlength(A,10); + For I:=0 to 9 do + A[I]:=I; + B:=Copy(A,3,6); + if High(B)<>5 then + begin + writeln('Error 1'); + halt(1); + end; + For I:=0 to High(B) do + if b[i]<>i+3 then + begin + writeln('Error 2'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0458.pp b/tests/tbs/tb0458.pp new file mode 100644 index 0000000000..7b9f38da48 --- /dev/null +++ b/tests/tbs/tb0458.pp @@ -0,0 +1,39 @@ +type smallword=word; + +Type LocalHeader = Record + Time : Longint; + End; + +Type PkZipObject = Object + Buf : longint; + + Constructor ZIPInit; + Procedure FindFirstEntry; Virtual; + End; {PkzipObject} + + PkzipPtr = ^PkzipObject; + + +Constructor PkzipObject.ZIPInit; +Begin +End; + + +Procedure PkzipObject.FindFirstEntry; +var LocalHeaderBuf: LocalHeader ABSOLUTE buf; +Begin + LocalHeaderBuf.Time:=12341234; +End; + +var + o : PkzipObject; + +begin + o.ZIPInit; + o.FindFirstEntry; + if o.Buf<>12341234 then + begin + writeln('error'); + halt(1); + end; +End. diff --git a/tests/tbs/tb0459.pp b/tests/tbs/tb0459.pp new file mode 100644 index 0000000000..a8de5d6d04 --- /dev/null +++ b/tests/tbs/tb0459.pp @@ -0,0 +1,34 @@ +{ %version=1.1 } +{$mode objfpc} +Type + IMyInterface = Interface + Function MyFunc : Integer; + end; + + TMyClass = Class(TInterfacedObject,IMyInterface) + Function MyOtherFunction : Integer; + // The following fails in FPC. + Function IMyInterface.MyFunc = MyOtherFunction; + end; + +Function TMyClass.MyOtherFunction : Integer; + +begin + Result:=23; +end; + +Var + A : TMyClass; + M : IMyInterface; + I : Integer; + +begin + A:=TMyClass.Create; + M:=A; + I:=M.MyFunc; + If (I<>23) then + begin + Writeln('Error calling interface'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb0460.pp b/tests/tbs/tb0460.pp new file mode 100644 index 0000000000..4f8e3819a8 --- /dev/null +++ b/tests/tbs/tb0460.pp @@ -0,0 +1,21 @@ +const + MinCurrency : Currency = -922337203685477.5807; + MaxCurrency : Currency = 922337203685477.5807; + +var + s : string; + +begin + str(MinCurrency:0:4,s); + if s<>'-922337203685477.5807' then + begin + writeln(s); + halt(1); + end; + str(MaxCurrency:0:4,s); + if s<>'922337203685477.5807' then + begin + writeln(s); + halt(1); + end; +end. diff --git a/tests/tbs/tb0461.pp b/tests/tbs/tb0461.pp new file mode 100644 index 0000000000..88a2bb8f40 --- /dev/null +++ b/tests/tbs/tb0461.pp @@ -0,0 +1,14 @@ +{ %version=1.1 } +{ %recompile } + +uses ub0461; + +procedure p; +begin + p1; +end; + +begin + p; +end. + diff --git a/tests/tbs/tb0462.pp b/tests/tbs/tb0462.pp new file mode 100644 index 0000000000..76c185acd9 --- /dev/null +++ b/tests/tbs/tb0462.pp @@ -0,0 +1,16 @@ +{ %version=1.1 } +type + RR = record + RA : WideString; + end; + +const + Z : RR = (RA: 'B'); + +begin + if z.ra<>'B' then + begin + writeln('error'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0464.pp b/tests/tbs/tb0464.pp new file mode 100644 index 0000000000..4494a202ce --- /dev/null +++ b/tests/tbs/tb0464.pp @@ -0,0 +1,12 @@ +{ %version=1.1 } +{$mode delphi} + +var + a1 : Array of Byte; + +begin + SetLength(a1,2); + a1[0]:=65; + a1[1]:=66; + WriteLn(AnsiString(a1)); +end. diff --git a/tests/tbs/tb0465.pp b/tests/tbs/tb0465.pp new file mode 100644 index 0000000000..b849004798 --- /dev/null +++ b/tests/tbs/tb0465.pp @@ -0,0 +1,10 @@ +program tb0465; + +{$mode delphi} + +var x:pointer; + +begin + x:=0; + x:=pointer(0); +end. diff --git a/tests/tbs/tb0466.pp b/tests/tbs/tb0466.pp new file mode 100644 index 0000000000..54ce119108 --- /dev/null +++ b/tests/tbs/tb0466.pp @@ -0,0 +1,13 @@ +var + outf : file of byte; + w : word; +begin + assign(outf, 'tb0466.tmp'); + rewrite(outf); + {only explicit typecasting helps: byte(10)} + write(outf, 10); + w:=20; + write(outf, w); + close(outf); +end. + diff --git a/tests/tbs/tb0467.pp b/tests/tbs/tb0467.pp new file mode 100644 index 0000000000..8132793b98 --- /dev/null +++ b/tests/tbs/tb0467.pp @@ -0,0 +1,26 @@ +{ %version=1.1 } +{$mode objfpc} +{$M+} +uses + typinfo; +type + tmyobject = class + protected + fs : single; + published + property s : single read fs write fs default 3.1415; + end; + +var + myobject : tmyobject; + +begin + myobject:=tmyobject.create; + SetFloatProp(myobject,'s',3); + if GetFloatProp(myobject,'s')<>3 then + begin + writeln('error'); + halt(1); + end; + myobject.free; +end. diff --git a/tests/tbs/tb0468.pp b/tests/tbs/tb0468.pp new file mode 100644 index 0000000000..c2d8b0f255 --- /dev/null +++ b/tests/tbs/tb0468.pp @@ -0,0 +1,36 @@ +{ %CPU=i386 } +{ %OPT=-Sg } +program tb0468; + +{$asmmode intel} + +procedure x; + +label a; + +var b:pointer; + +begin + b:=@a; +a: +end; + +procedure jumptabproc; assembler; + +label a,b,c,d; + +const jumptable:array[0..3] of pointer=(@a,@b,@b,@d); + +asm +a: + nop +b: + nop +c: + nop +d: + nop +end; + +begin +end. diff --git a/tests/tbs/tb0469.pp b/tests/tbs/tb0469.pp new file mode 100644 index 0000000000..8960f6e8cc --- /dev/null +++ b/tests/tbs/tb0469.pp @@ -0,0 +1,48 @@ +{ %version=1.1} +{ %opt=-vw } +{$mode objfpc} +type + to1 = class + procedure p1; + procedure p2;virtual; + procedure p3; + end; + + to2 = class(to1) + procedure p1; + procedure p2;virtual;reintroduce; + procedure p3;virtual; + end; + +procedure to1.p1; + begin + end; + + +procedure to1.p2; + begin + end; + + +procedure to1.p3; + begin + end; + + +procedure to2.p1; + begin + end; + + +procedure to2.p2; + begin + end; + + +procedure to2.p3; + begin + end; + + +begin +end. diff --git a/tests/tbs/tb0470.pp b/tests/tbs/tb0470.pp new file mode 100644 index 0000000000..6b4a42a119 --- /dev/null +++ b/tests/tbs/tb0470.pp @@ -0,0 +1,20 @@ +procedure proc1(p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20 : longint); + begin + end; + +procedure proc2; + var + l : dword; + begin + l:=$deadbeef; + proc1(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20); + if l<>$deadbeef then + begin + writeln('error'); + halt(1); + end; + end; + +begin + proc2; +end. diff --git a/tests/tbs/tb0471.pp b/tests/tbs/tb0471.pp new file mode 100644 index 0000000000..e4a20ea676 --- /dev/null +++ b/tests/tbs/tb0471.pp @@ -0,0 +1,32 @@ +{$mode delphi} + +const + err : boolean = true; + +type + tf = function:longint; +procedure p1(l:longint);overload; +begin + writeln('longint'); +end; + + +procedure p1(f:tf);overload; +begin + writeln('procvar'); + err:=false; +end; + +function vf:longint; +begin + vf:=10; +end; + +var + v : tf; +begin + v:=vf; + p1(v); + if err then + halt(1); +end. diff --git a/tests/tbs/tb0472.pp b/tests/tbs/tb0472.pp new file mode 100644 index 0000000000..fd31e7c346 --- /dev/null +++ b/tests/tbs/tb0472.pp @@ -0,0 +1,23 @@ +{$macro on} + +{$define aaa:=1234} +{$define bbb:=4321} + +{$define ccc:=aaa} // here aaa is already defined macros + +var + err : boolean; +begin + err:=true; +{$if aaa=ccc} // condition is equal + // but compiler not compiling this block, because + // don't take into account that value of macros ccc is macros also. + err:=false; + writeln('success'); +{$else} + writeln('failure'); +{$endif} + if err then + halt(1); +end. + diff --git a/tests/tbs/tb0473.pp b/tests/tbs/tb0473.pp new file mode 100644 index 0000000000..79b31e39e7 --- /dev/null +++ b/tests/tbs/tb0473.pp @@ -0,0 +1,11 @@ +const + w = $5000; +begin + writeln(hi(w)); + if hi(w)<>$50 then + begin + writeln('Error!'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0474.pp b/tests/tbs/tb0474.pp new file mode 100644 index 0000000000..8150bf3a61 --- /dev/null +++ b/tests/tbs/tb0474.pp @@ -0,0 +1,33 @@ +{ $mode objfpc} +const + WideNull = widechar(#0); + WideSpace = widechar(#32); + +var + w : widechar; + w2,w3 : widechar; +begin + w:=WideSpace; + w3:=WideSpace; + w2:=WideNull; + if not(w in [WideSpace]) then + begin + writeln('error 1'); + halt(1); + end; + if not(w in [WideNull..WideSpace]) then + begin + writeln('error 2'); + halt(1); + end; + if not(w in [WideNull..WideSpace,w3]) then + begin + writeln('error 3'); + halt(1); + end; + if not(w in [WideNull..WideSpace,w2..w3]) then + begin + writeln('error 4'); + halt(1); + end; +end. diff --git a/tests/tbs/tb0475.pp b/tests/tbs/tb0475.pp new file mode 100644 index 0000000000..7430478359 --- /dev/null +++ b/tests/tbs/tb0475.pp @@ -0,0 +1,21 @@ +{$mode delphi} +type + to1 = class + fp : longint; + property p : longint read fp write fp; + end; + +procedure p(const v); + begin + end; + +var + a : pchar; + o1 : to1; + +begin + o1:=to1.create; + p(a[0]); + p(o1.p); + o1.free; +end. diff --git a/tests/tbs/tb0476.pp b/tests/tbs/tb0476.pp new file mode 100644 index 0000000000..3fe585d4e5 --- /dev/null +++ b/tests/tbs/tb0476.pp @@ -0,0 +1,15 @@ +const + e = 'as'; + +procedure p(const p); + begin + if pchar(@p)^<>'a' then + begin + writeln('error'); + halt(1); + end; + end; + +begin + p(e[1]); +end. diff --git a/tests/tbs/tb0477.pp b/tests/tbs/tb0477.pp new file mode 100644 index 0000000000..2ddc8f39e1 --- /dev/null +++ b/tests/tbs/tb0477.pp @@ -0,0 +1,39 @@ +{$mode delphi} + +type + TProc = procedure of object; + + TTest = class + public + proc: TProc; + constructor Create; + procedure foo; + procedure bar; + end; + +constructor TTest.Create; +begin + inherited; + proc := nil; +end; + +procedure TTest.foo; +begin + writeln('foo'); +end; + +procedure TTest.bar; +begin + if @proc <> nil then proc; +end; + +var + t: TTest; + +begin + t := TTest.Create; + t.proc := t.foo; + t.bar; + t.Free; +end. + diff --git a/tests/tbs/tb0478.pp b/tests/tbs/tb0478.pp new file mode 100644 index 0000000000..aeec274abb --- /dev/null +++ b/tests/tbs/tb0478.pp @@ -0,0 +1,79 @@ +type + integer = longint; + +const + {** @abstract(Character encoding value: UTF-8 storage format)} + CHAR_ENCODING_UTF8 = 0; + {** @abstract(Character encoding value: unknown format)} + CHAR_ENCODING_UNKNOWN = -1; + {** @abstract(Character encoding value: UTF-32 Big endian)} + CHAR_ENCODING_UTF32BE = 1; + {** @abstract(Character encoding value: UTF-32 Little endian)} + CHAR_ENCODING_UTF32LE = 2; + {** @abstract(Character encoding value: UTF-16 Little endian)} + CHAR_ENCODING_UTF16LE = 3; + {** @abstract(Character encoding value: UTF-16 Big endian)} + CHAR_ENCODING_UTF16BE = 4; + {** @abstract(Character encoding value: One byte per character storage +format)} + CHAR_ENCODING_BYTE = 5; + {** @abstract(Character encoding value: UTF-16 unknown endian +(determined by BOM))} + CHAR_ENCODING_UTF16 = 6; + {** @abstract(Character encoding value: UTF-32 unknown endian +(determined by BOM))} + CHAR_ENCODING_UTF32 = 7; + + +function GetCharEncoding(alias: string; var _name: string): integer; +var + encoding: integer; + newencoding: integer; +begin + _name:=''; + if length(alias) = 0 then + Runerror(255); { FAILED! } + newencoding:=CHAR_ENCODING_UTF8; + encoding:=CHAR_ENCODING_BYTE; + case newencoding of + { currently unsupported } + CHAR_ENCODING_UNKNOWN: + Begin + end; + { verify if we are using the correct encoding } + CHAR_ENCODING_UTF16: + begin + if (encoding <> CHAR_ENCODING_UTF16BE) and + (encoding <> CHAR_ENCODING_UTF16LE) then + encoding:=255; + end; + { verify if we are using the correct encoding } + CHAR_ENCODING_UTF32: + begin + if (encoding <> CHAR_ENCODING_UTF32BE) and + (encoding <> CHAR_ENCODING_UTF32LE) then + encoding:=255; + end; + CHAR_ENCODING_UTF16BE, + CHAR_ENCODING_UTF16LE, + CHAR_ENCODING_UTF32LE, + CHAR_ENCODING_UTF32BE: + begin + end; + else + begin + encoding:=newencoding; + end; + end; + if encoding <> CHAR_ENCODING_UTF8 then + RunError(255); +end; + + +var + _encoding: string; +Begin + _encoding:='UTF-8'; + GetCharencoding(_encoding,_encoding); +end. + diff --git a/tests/tbs/tb0479.pp b/tests/tbs/tb0479.pp new file mode 100644 index 0000000000..de60a57c3d --- /dev/null +++ b/tests/tbs/tb0479.pp @@ -0,0 +1,55 @@ +{$mode delphi} + +var + err : boolean; + +Type + {copy-paste from LibX.pas} + XInt = Longint; + XUInt = Longword; + XHandle = Pointer; + XFile = XHandle; + XFileMode = Set Of ( + xFileModeRead, + xFileModeWrite + ); + XResult = XInt; + +Type + TTest = Class(TObject) + Constructor Create(Out Result: XResult; Const Handle: XFile; Const Mode: XFileMode); + End; + + TTest2 = Class(TTest) + Constructor Create(Out Result: XResult; Const FileName: AnsiString; Const Rights: XUInt); Overload; + Constructor Create(Out Result: XResult; Const FileName: AnsiString; Const Mode: XFileMode); Overload; + End; + +Constructor TTest.Create(Out Result: XResult; Const Handle: XFile; Const Mode: XFileMode); +Begin + WriteLn('TTest Create'); +End; + +Constructor TTest2.Create(Out Result: XResult; Const FileName: AnsiString; Const Rights: XUInt); +Begin + WriteLn('TTest2-1 Create'); +End; + +Constructor TTest2.Create(Out Result: XResult; Const FileName: AnsiString; Const Mode: XFileMode); +Begin + WriteLn('TTest2-2 Create'); + err:=false; +End; + +Var + T : TTest; + C : PAnsiChar; + X : XResult; + M : XFileMode; +Begin + err:=true; + C := 'Foo'; + T := TTest2.Create(X, C, M); + if err then + halt(1); +End. diff --git a/tests/tbs/tb0480.pp b/tests/tbs/tb0480.pp new file mode 100644 index 0000000000..ab2e1f3c72 --- /dev/null +++ b/tests/tbs/tb0480.pp @@ -0,0 +1,23 @@ +{$ifdef fpc}{$mode delphi}{$endif} + +procedure Test(const s1, s2: PAnsiChar); +begin + Writeln(s1); + Writeln(s2); + if ansistring(s1)<>ansistring(s2) then + begin + writeln('Error'); + halt(1); + end; +end; + +var + S: AnsiString; + P: PAnsiChar; +begin + S := 'Test'; + P := PAnsiChar(S); + Test(PAnsiChar('String:'+S+';'), PAnsiChar('String:'+S+';')); + Test(PAnsiChar('String:'+P+';'), PAnsiChar('String:'+P+';')); +end. + diff --git a/tests/tbs/tb0481.pp b/tests/tbs/tb0481.pp new file mode 100644 index 0000000000..981c6212d1 --- /dev/null +++ b/tests/tbs/tb0481.pp @@ -0,0 +1,9 @@ +type + trec = record + data : longint; + end; + prec = ^trec; + +begin + writeln(longint(@prec(0)^.data)); +end. diff --git a/tests/tbs/tb0482.pp b/tests/tbs/tb0482.pp new file mode 100644 index 0000000000..875ceb842d --- /dev/null +++ b/tests/tbs/tb0482.pp @@ -0,0 +1,22 @@ +{$mode objfpc} +uses + sysutils; + +resourcestring sMyNewErrorMessage = 'Illegal value: %d'; + +begin + try + raise Exception.CreateResFmt(@sMyNewErrorMessage, [-1]); + except + on e : exception do + begin + if e.message='Illegal value: -1' then + halt(0) + else + begin + writeln('error : ',e.message); + halt(1); + end; + end; + end; +end. diff --git a/tests/tbs/tb0483.pp b/tests/tbs/tb0483.pp new file mode 100644 index 0000000000..31ddb5fe9c --- /dev/null +++ b/tests/tbs/tb0483.pp @@ -0,0 +1,31 @@ +{$mode delphi} +{ this should be only allowed in delphi mode; it's a delphi bug } +uses + tb0483u; + +type + tmyclass2 = class(tmyclass1) + procedure x(var l : longint);message 1234; + end; + +procedure tmyclass2.x(var l : longint); + begin + inherited; + end; + +var + myclass2 : tmyclass2; + l : longint; + +begin + myclass2:=tmyclass2.create; + myclass2.x(l); + myclass2.free; + if testresult<>1 then + begin + writeln('error'); + halt(1); + end; + writeln('ok'); +end. + diff --git a/tests/tbs/tb0483u.pp b/tests/tbs/tb0483u.pp new file mode 100644 index 0000000000..24992681b9 --- /dev/null +++ b/tests/tbs/tb0483u.pp @@ -0,0 +1,33 @@ +{$mode delphi} +unit tb0483u; + +interface + + type + tmyclass1 = class + private + procedure x(var l : longint);message 1234; + public + procedure defaulthandler(var msg);override; + end; + + const + testresult : longint = 0; + + +implementation + + procedure tmyclass1.defaulthandler(var msg); + begin + writeln('error; being in tmyclass1.defaulthandler'); + halt(1); + end; + + + procedure tmyclass1.x(var l : longint); + begin + testresult:=1; + end; + +end. + diff --git a/tests/tbs/tb0484.pp b/tests/tbs/tb0484.pp new file mode 100644 index 0000000000..e9106c4852 --- /dev/null +++ b/tests/tbs/tb0484.pp @@ -0,0 +1,22 @@ +type + r1 = record + p : procedure stdcall; + i : longint; + end; + + r2 = record + p : procedure; + i : longint; + end; + + r3 = record + p : procedure + end; + + { ugly, but should work (FK) } + r4 = record + p : procedure stdcall + end; + +begin +end. diff --git a/tests/tbs/tb0485.pp b/tests/tbs/tb0485.pp new file mode 100644 index 0000000000..7c13107131 --- /dev/null +++ b/tests/tbs/tb0485.pp @@ -0,0 +1,156 @@ +{$mode objfpc} +program test05; + +uses + SysUtils; + + +type + QObjectH = class(TObject) end; + QWidgetH = class(QObjectH) end; + + +IQbase = interface(IUnknown) +end; + +TQBase = class(TInterfacedObject,IQBase) +protected + fQHandle : TObject; + function GetQHandle : TObject; + procedure SetQHandle(Value : TObject); +public + property QHandle : TObject read GetQHandle write SetQHandle; +end; + + + +IQObject = interface(IQBase) + function GetQHandle : QObjectH; + property QHandle : QObjectH read GetQHandle; +end; + + +TQObject = class(TQBase, IQObject) +protected + function GetQHandle : QObjectH; overload; + procedure SetQHandle(Value:QObjectH); + +public + property QHandle : QObjectH read GetQHandle write SetQHandle; + constructor CreateWrapper; + Constructor Create(name: PAnsiChar); overload; +end; + + +IQWidget = interface(IQObject) + function GetQHandle : QWidgetH; + property QHandle : QWidgetH read GetQHandle; + function Width: Integer; +end; + + +TQWidget = class(TQObject, IQWidget) +protected + function GetQHandle : QWidgetH; overload; + procedure SetQHandle(Value:QWidgetH); +public + property QHandle : QWidgetH read GetQHandle write SetQHandle; + constructor CreateWrapper; + Constructor Create(name: PAnsiChar); overload; + function Width: Integer; +end; + + +function TQObject.GetQHandle : QObjectH; +begin + if Self <> nil then Result := QObjectH(fQHandle) + else Result := nil; +end; + +procedure TQObject.SetQHandle(Value : QObjectH); +begin + fQHandle := TObject(Value); +end; + +constructor TQObject.CreateWrapper; +begin + inherited Create; +end; + + + +Constructor TQObject.Create(name: PAnsiChar); +begin + CreateWrapper; +end; + + + +function TQBase.GetQHandle : TObject; +begin + Result := fQHandle +end; + + +procedure TQBase.SetQHandle(Value : TObject); +begin + fQHandle:=Value; +end; + + + +function TQWidget.GetQHandle : QWidgetH; +begin + write(' entering TQWidget.GetQHandle ...'); + if Self <> nil then Result := QWidgetH(fQHandle) + else Result := nil; + writeln('...leaving entering TQWidget.GetQHandle'); +end; + +procedure TQWidget.SetQHandle(Value : QWidgetH); +begin + fQHandle := TObject(Value); +end; + +constructor TQWidget.CreateWrapper; +begin + write(' entering TQWidget.CreateWrapper ...'); + inherited Create; + writeln('...leaving TQWidget.CreateWrapper'); +end; + + + +Constructor TQWidget.Create(name: PAnsiChar); +begin + write('entering TQWidget.Create ...'); + CreateWrapper; + writeln('... leaving TQWidget.Create'); +end; + + + +function TQWidget.Width: Integer; +begin + write(' entering TQWidget.Width...'); + Result:=123; + writeln('...leaving TQWidget.Width'); +end; + + + +function GetWidget : IQWidget; +begin +Result := TQWidget.CreateWrapper; +end; + + +begin +writeln('GetWidget.Width (123)?:',GetWidget.Width); +if GetWidget.Width<>123 then + begin + writeln('error'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb0486.pp b/tests/tbs/tb0486.pp new file mode 100644 index 0000000000..5bf0b431e9 --- /dev/null +++ b/tests/tbs/tb0486.pp @@ -0,0 +1,32 @@ +{$mode delphi} +type + tprocedure = procedure; + pprocedure = ^tprocedure; + +var + l : longint; + +function _f1 : plongint; + begin + result:=@l; + end; + +var + f1 : function : plongint; + f2 : function : pprocedure; + +procedure p; + begin + l:=2; + end; + +begin + f1^:=1; + if l<>1 then + halt(1); + f2^:=p; + f2^; + if l<>2 then + halt(1); + writeln('ok'); +end. diff --git a/tests/tbs/tb0487.pp b/tests/tbs/tb0487.pp new file mode 100644 index 0000000000..2233a3eb8a --- /dev/null +++ b/tests/tbs/tb0487.pp @@ -0,0 +1,20 @@ +uses + variants; +var + v : variant; + i : longint; + +begin + v:=true; + if not(v) then + halt(1); + while not(v) do + halt(1); + i:=1; + repeat + if i>1 then + halt(1); + inc(i); + until v; + writeln('ok'); +end. diff --git a/tests/tbs/tb0488.pp b/tests/tbs/tb0488.pp new file mode 100644 index 0000000000..5eeeeaf6f6 --- /dev/null +++ b/tests/tbs/tb0488.pp @@ -0,0 +1,50 @@ +{ Source provided for Free Pascal Bug Report 3478 } +{ Submitted by "Michalis Kamburelis" on 2004-12-26 } +{ e-mail: michalis@camelot.homedns.org } +{ Before fixing bug 3477 this prints + FFFFFFF + FFFFFFFFFFFFFFFF + 0000000FFFFFFFFF + 9999999 + FFFFFFFF99999999 + 0000000999999999 + + After fixing 3477 with my patch this prints + FFFFFFF + FFFFFFFFFFFFFFFF + FFFFFFFFF + 9999999 + FFFFFFFF99999999 + 999999999 + so part of the problems are gone, but not all. + + Then, after fixing this bug with my simple patch it correctly prints + FFFFFFF + FFFFFFFF + FFFFFFFFF + 9999999 + 99999999 + 999999999 +} + +uses SysUtils,erroru; + +procedure Check(a,b:ansistring); +begin + if a<>b then + begin + writeln(a,' should be equal to ',b); + error; + end; +end; + +begin + check(WideFormat('%x', [$FFFFFFF]),'FFFFFFF'); + check(WideFormat('%x', [$FFFFFFFF]),'FFFFFFFF'); + check(WideFormat('%x', [$FFFFFFFFF]),'FFFFFFFFF'); + + check(WideFormat('%x', [$9999999]),'9999999'); + check(WideFormat('%x', [$99999999]),'99999999'); + check(WideFormat('%x', [$999999999]),'999999999'); +end. + diff --git a/tests/tbs/tb0489.pp b/tests/tbs/tb0489.pp new file mode 100644 index 0000000000..3cd606cb09 --- /dev/null +++ b/tests/tbs/tb0489.pp @@ -0,0 +1,26 @@ +{$mode delphi} +uses ub0489; +type oo = class + function getmyint:integer; + property someprop:integer read getmyint; + end; + +function oo.getmyint:integer; + +begin + result:=1; +end; + + + +procedure test2; + +var ch:char; + x : oo; + +begin + test(x.someprop,ch,1); +end; + +begin +end. diff --git a/tests/tbs/ub0060.pp b/tests/tbs/ub0060.pp new file mode 100644 index 0000000000..4d0886d53a --- /dev/null +++ b/tests/tbs/ub0060.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0067.pp } +{ Shows incorrect symbol resolution when using uses in implementation More info can be found in file tbs0067b.pp. } + +unit ub0060; + +interface + +type + tlong=record + a : longint; + end; + +procedure p(var t:tlong); + +implementation + +procedure p(var t:tlong); +begin +end; + +end. diff --git a/tests/tbs/ub0069.pp b/tests/tbs/ub0069.pp new file mode 100644 index 0000000000..44a5192eb4 --- /dev/null +++ b/tests/tbs/ub0069.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0077b.pp } +{ used by unit tbs0077.pp } + +unit ub0069; + + interface + + var + a : longint; + b : longint absolute a; + + implementation + +end. diff --git a/tests/tbs/ub0119.pp b/tests/tbs/ub0119.pp new file mode 100644 index 0000000000..96169f2e0b --- /dev/null +++ b/tests/tbs/ub0119.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0139a.pp } +{ } + + unit ub0119; + +{$mode objfpc} + + interface + + type + SomeClass=class(TObject) + protected + procedure doSomething; virtual; + end ; + + implementation + + + procedure SomeClass.doSomething; + begin + Writeln ('Hello from SomeClass.DoSomething'); + end ; + +end. diff --git a/tests/tbs/ub0120.pp b/tests/tbs/ub0120.pp new file mode 100644 index 0000000000..9f1951d96a --- /dev/null +++ b/tests/tbs/ub0120.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0140a.pp } +{ } + + +unit ub0120; + +interface + +uses tb0120; + +procedure Message(var O:TObject); + +implementation + +procedure Message(var O:TObject); + begin writeln('Message') end; +end. diff --git a/tests/tbs/ub0129.pp b/tests/tbs/ub0129.pp new file mode 100644 index 0000000000..a89ad18528 --- /dev/null +++ b/tests/tbs/ub0129.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0149a.pp } +{ } + +unit ub0129; + +interface + +Const tset = [1,2,3,4,5]; + c = 1; + +implementation + +end. diff --git a/tests/tbs/ub0133.pp b/tests/tbs/ub0133.pp new file mode 100644 index 0000000000..33c29ce04a --- /dev/null +++ b/tests/tbs/ub0133.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0156b.pp } +{ } + +unit ub0133; +interface + +type + _win_st = record + _parent : ^WINDOW; + end; + WINDOW = _win_st; + +implementation + +end. diff --git a/tests/tbs/ub0150.pp b/tests/tbs/ub0150.pp new file mode 100644 index 0000000000..424d9f327a --- /dev/null +++ b/tests/tbs/ub0150.pp @@ -0,0 +1,16 @@ +{ %OPT=-Un } + +{ Old file: tbs0180a.pp } + +{ this name should be accepted with -Un option !! } +UNIT Unit_with_strange_name; +INTERFACE + procedure dummy; +IMPLEMENTATION + procedure dummy; + begin + end; + +begin + Unit_with_strange_name.dummy; +END. diff --git a/tests/tbs/ub0155.pp b/tests/tbs/ub0155.pp new file mode 100644 index 0000000000..dc3d7921fd --- /dev/null +++ b/tests/tbs/ub0155.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0181a.pp } +{ } + +{ shows a problem of name mangling } +Unit ub0155; + +Interface + + type mylongint = longint; + mylongint2 = mylongint; + + procedure dummy(var l : mylongint); + +Implementation + + var l : longint; + + procedure use_before_implemented; + begin + dummy(l); + end; + + procedure dummy(var l : mylongint2); + begin + l:=78; + end; + +begin + use_before_implemented; +end. diff --git a/tests/tbs/ub0170.pp b/tests/tbs/ub0170.pp new file mode 100644 index 0000000000..0dc1533131 --- /dev/null +++ b/tests/tbs/ub0170.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0203a.pp } +{ } + +unit ub0170; + +interface + + procedure a;external name '_assembler_a'; + procedure c; + + const is_called : boolean = false; + +implementation + + procedure c; + begin + a; + end; + + procedure b;[public, alias : '_assembler_a']; + begin + Writeln('b called'); + Is_called:=true; + end; + +end. + diff --git a/tests/tbs/ub0179.pp b/tests/tbs/ub0179.pp new file mode 100644 index 0000000000..b99a265d76 --- /dev/null +++ b/tests/tbs/ub0179.pp @@ -0,0 +1,99 @@ +{ Old file: tbs0213a.pp } +{ } + +{ different tests for the problem of local + functions having the same name } + +unit ub0179; + +interface + +PROCEDURE Testsomething(VAR A:LONGINT); + +PROCEDURE Testsomething(VAR A:WORD); + +implementation + + +PROCEDURE Testsomething(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething2(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething2(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething3(VAR A:WORD);forward; + +PROCEDURE Testsomething3(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething3(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +VAR O : LONGINT; + O2 : WORD; + +BEGIN + TestSomething(O); + TestSomething(O2); +END. + diff --git a/tests/tbs/ub0222.pp b/tests/tbs/ub0222.pp new file mode 100644 index 0000000000..f8ddc6f24b --- /dev/null +++ b/tests/tbs/ub0222.pp @@ -0,0 +1,57 @@ +{ Old file: tbs0261a.pp } +{ } + +unit ub0222; + +{ test for operator overloading } +{ Copyright (c) 1999 Lourens Veen } +{ why doesn't this work? } + +interface + +type mythingy = record + x, y : longint; + c : byte; + end; + + myotherthingy = record + x, y : longint; + d : byte; + end; + + mythirdthingy = record + x, y : longint; + e : byte; + end; + + mynewthingy = record + x, y : longint; + e,f : byte; + end; + +operator := (a : mythingy) r : myotherthingy; +operator := (a : mythingy) r : mythirdthingy; +operator = (b : myotherthingy;c : mythirdthingy) res : boolean; + +implementation + +operator := (a : mythingy) r : myotherthingy; +begin + r.x := a.x; + r.y := a.y; + r.d := a.c; +end; + +operator := (a : mythingy) r : mythirdthingy; +begin + r.x := a.x; + r.y := a.y; + r.e := a.c; +end; + +operator = (b : myotherthingy;c : mythirdthingy) res : boolean; +begin + res:=(b.x=c.x) and (b.y=c.y) and (b.d=c.e); +end; + +end. diff --git a/tests/tbs/ub0265.pp b/tests/tbs/ub0265.pp new file mode 100644 index 0000000000..ccb0bcfd68 --- /dev/null +++ b/tests/tbs/ub0265.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0308a.pp } +{ problem with objects that don't have VMT nor variable fields OK 0.99.13 (FK) } + +unit ub0265; + +interface + +type + tcourses = object + function index(cName: string): integer; + function name(cIndex: integer): string; + end; + +var coursedb: tcourses; + l: longint; + +implementation + +function tcourses.index(cName: string): integer; +begin + index := byte(cName[0]); +end; + +function tcourses.name(cIndex: integer): string; +begin + name := char(byte(cIndex)); +end; + +end. diff --git a/tests/tbs/ub0292.pp b/tests/tbs/ub0292.pp new file mode 100644 index 0000000000..8179bf29a3 --- /dev/null +++ b/tests/tbs/ub0292.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0346a.pp } +{ } + +unit ub0292; +interface + +type + word = system.word; + +implementation + +end. diff --git a/tests/tbs/ub0308.pp b/tests/tbs/ub0308.pp new file mode 100644 index 0000000000..b60984bee7 --- /dev/null +++ b/tests/tbs/ub0308.pp @@ -0,0 +1,13 @@ +unit ub0308; + + interface + + type + tr = record + case a : (x,y,z) of + x : (l : longint); + end; + + implementation + +end. diff --git a/tests/tbs/ub0313.pp b/tests/tbs/ub0313.pp new file mode 100644 index 0000000000..59bb7d6b75 --- /dev/null +++ b/tests/tbs/ub0313.pp @@ -0,0 +1,14 @@ +unit ub0313; + +interface +type + rec=object + i : longint; + nrs : (one,two,three); + end; +var + brec : rec; + +implementation + +end. diff --git a/tests/tbs/ub0339.pp b/tests/tbs/ub0339.pp new file mode 100644 index 0000000000..2c30fcd22c --- /dev/null +++ b/tests/tbs/ub0339.pp @@ -0,0 +1,18 @@ +{$mode FPC} +unit ub0339; +interface +type + r2 = packed record + Foo : Boolean; + Bar : (No, Yes); + Baz : 0 .. 3; + Qux : -1 .. 0; + Fred : 1 .. 7 + end; + procedure PrintSize; +implementation + procedure PrintSize; + begin + Writeln ('BBB: Size of packed record r2 = ', SizeOf (r2), ' bytes.') + end; +begin end. diff --git a/tests/tbs/ub0342a.pp b/tests/tbs/ub0342a.pp new file mode 100644 index 0000000000..cd3a326d30 --- /dev/null +++ b/tests/tbs/ub0342a.pp @@ -0,0 +1,10 @@ +unit ub0342a; +interface +procedure p(d:longword); +implementation +uses + ub0342b; +procedure p(d:longword); +begin +end; +end. diff --git a/tests/tbs/ub0342b.pp b/tests/tbs/ub0342b.pp new file mode 100644 index 0000000000..01215fd082 --- /dev/null +++ b/tests/tbs/ub0342b.pp @@ -0,0 +1,6 @@ +unit ub0342b; +interface +type + longWord=Cardinal; +implementation +end. diff --git a/tests/tbs/ub0366.pp b/tests/tbs/ub0366.pp new file mode 100644 index 0000000000..1afcbaac8d --- /dev/null +++ b/tests/tbs/ub0366.pp @@ -0,0 +1,21 @@ +{$ifdef fpc}{$mode objfpc}{$endif} +unit ub0366; +interface + +type + tc1=class + private + FHeight : integer; + public + constructor Create; + property Height : integer read FHeight write FHeight; + end; + +implementation + +constructor tc1.Create; +begin + FHeight:=0; +end; + +end. diff --git a/tests/tbs/ub0380.pp b/tests/tbs/ub0380.pp new file mode 100644 index 0000000000..470e5d1bf4 --- /dev/null +++ b/tests/tbs/ub0380.pp @@ -0,0 +1,8 @@ +unit ub0380; +interface +procedure p1(i:integer);overload; +implementation +procedure p1(i:integer);overload; +begin +end; +end. diff --git a/tests/tbs/ub0386.pp b/tests/tbs/ub0386.pp new file mode 100644 index 0000000000..1dc9f04d82 --- /dev/null +++ b/tests/tbs/ub0386.pp @@ -0,0 +1,26 @@ +{$ifdef fpc}{$mode objfpc}{$endif} +unit ub0386; +interface + +type + tobj = class + procedure proc1 (a: integer);overload; virtual; + end; + + tobj1 = class(tobj) + { this proc1 definition should not been seen by tobj2 } + private + procedure proc1 (a: char); + end; + +implementation + +procedure tobj.proc1 (a: integer); +begin +end; + +procedure tobj1.proc1 (a: char); +begin +end; + +end. diff --git a/tests/tbs/ub0391.pp b/tests/tbs/ub0391.pp new file mode 100644 index 0000000000..2c81c972bf --- /dev/null +++ b/tests/tbs/ub0391.pp @@ -0,0 +1,19 @@ +{$ifdef fpc}{$mode objfpc}{$endif} +unit ub0391; +interface +type + tc2 = class + protected + procedure p1(s:string); + end; + + +implementation + +procedure tc2.p1(s:string); +begin + writeln('string: ',s); +end; + + +end. diff --git a/tests/tbs/ub0406.pp b/tests/tbs/ub0406.pp new file mode 100644 index 0000000000..329136844b --- /dev/null +++ b/tests/tbs/ub0406.pp @@ -0,0 +1,7 @@ +unit ub0406; +interface + +implementation +uses tb0406; + +end. diff --git a/tests/tbs/ub0421a.pp b/tests/tbs/ub0421a.pp new file mode 100644 index 0000000000..126e50c5d5 --- /dev/null +++ b/tests/tbs/ub0421a.pp @@ -0,0 +1,14 @@ +unit ub0421a; +interface +{$mode objfpc} + + uses ub0421b; + +type + cl3=class(cl2) + property f:longint read f1; + end; + + implementation + end. + diff --git a/tests/tbs/ub0421b.pp b/tests/tbs/ub0421b.pp new file mode 100644 index 0000000000..3a8b9397f0 --- /dev/null +++ b/tests/tbs/ub0421b.pp @@ -0,0 +1,12 @@ +unit ub0421b ; +interface +{$mode objfpc} + + uses ub0421c; +type + cl2=class(cl1) + end; + + implementation + end. + diff --git a/tests/tbs/ub0421c.pp b/tests/tbs/ub0421c.pp new file mode 100644 index 0000000000..81db3f5500 --- /dev/null +++ b/tests/tbs/ub0421c.pp @@ -0,0 +1,20 @@ +unit ub0421c; +interface + +{$mode objfpc} + +type + cl1=class + f1:longint; + constructor create; + end; + +implementation + + constructor cl1.create; + begin + f1 := 10; + end; + +end. + diff --git a/tests/tbs/ub0426.pp b/tests/tbs/ub0426.pp new file mode 100644 index 0000000000..07668f6544 --- /dev/null +++ b/tests/tbs/ub0426.pp @@ -0,0 +1,39 @@ +{ %VERSION=1.1 } +{$MODE OBJFPC} +Unit ub0426; + +interface + +var + z: integer platform; + + +procedure myroutine; platform; + +procedure myroutine2; deprecated; + +procedure myroutine3; unimplemented; + + +implementation + +procedure myroutine; platform; +begin +end; + +procedure myroutine2; deprecated; +begin +end; + +procedure myroutine3;{$ifdef fpc}unimplemented;{$endif} +begin +end; + +Begin + myroutine; + myroutine2; + myroutine3; + z:=0; +end. + + diff --git a/tests/tbs/ub0437a.pp b/tests/tbs/ub0437a.pp new file mode 100644 index 0000000000..a77d7f8231 --- /dev/null +++ b/tests/tbs/ub0437a.pp @@ -0,0 +1,13 @@ +{ %version=1.1} +unit ub0437a; + + interface + + type + prec = ^trec; + trec = record + end; + + implementation + +end. diff --git a/tests/tbs/ub0437b.pp b/tests/tbs/ub0437b.pp new file mode 100644 index 0000000000..3140df0c3e --- /dev/null +++ b/tests/tbs/ub0437b.pp @@ -0,0 +1,14 @@ +{ %version=1.1} +unit ub0437b; + + interface + + uses + ub0437a; + + type + prec = ub0437a.prec; + + implementation + +end. diff --git a/tests/tbs/ub0437c.pp b/tests/tbs/ub0437c.pp new file mode 100644 index 0000000000..352fe464dd --- /dev/null +++ b/tests/tbs/ub0437c.pp @@ -0,0 +1,20 @@ +{ %version=1.1} +unit ub0437c; + + interface + + uses + ub0437b; + + type + prec = ub0437b.prec; + + function f : prec; + + implementation + + function f : prec; + begin + end; + +end. diff --git a/tests/tbs/ub0440.pp b/tests/tbs/ub0440.pp new file mode 100644 index 0000000000..c94e527624 --- /dev/null +++ b/tests/tbs/ub0440.pp @@ -0,0 +1,7 @@ +unit ub0440; +interface +const + a = 'test'; + +implementation +end. diff --git a/tests/tbs/ub0461.pp b/tests/tbs/ub0461.pp new file mode 100644 index 0000000000..e331115bf4 --- /dev/null +++ b/tests/tbs/ub0461.pp @@ -0,0 +1,23 @@ +unit ub0461; +{$inline on} +interface +procedure p1;inline; +implementation + +procedure p1;inline; +var + i,k : longint; + + procedure f; + begin + i:=20; + k:=i*10; + writeln('hello ',k); + end; + +begin + f; +end; + +end. + diff --git a/tests/tbs/ub0489.pp b/tests/tbs/ub0489.pp new file mode 100644 index 0000000000..b52a257a95 --- /dev/null +++ b/tests/tbs/ub0489.pp @@ -0,0 +1,20 @@ +{$mode delphi} +{$inline on} + +unit ub0489; + +interface + +function test(b:integer;const x;c:integer):integer inline; + +implementation + +uses + ub0489b; + +function test(b:integer;const x;c:integer):integer inline; +begin + result:=fpwrite(b,x,c); +end; + +end. diff --git a/tests/tbs/ub0489b.pp b/tests/tbs/ub0489b.pp new file mode 100644 index 0000000000..6ee59b3e25 --- /dev/null +++ b/tests/tbs/ub0489b.pp @@ -0,0 +1,16 @@ +{$mode delphi} + +unit ub0489b; + +interface + +function fpwrite(b:integer;const x;c:integer):integer; + +implementation + +function fpwrite(b:integer;const x;c:integer):integer; +begin + writeln('fpwrite'); +end; + +end. |