* renamed test suite

tests/Makefile.fpc

@@ -0,0 +1,108 @@
+#
+# Makefile.fpc for Free Pascal Tests directory
+#
+
+[defaults]
+defaultrule=alltests
+
+[rules]
+.PHONY: all units tests cont_tests
+
+# Unix like OS ?
+ifeq ($(OS_TARGET),linux)
+INUNIX=1
+endif
+ifeq ($(OS_TARGET),freebsd)
+INUNIX=1
+endif
+
+# For linux by default no graph tests
+ifdef INUNIX
+NOGRAPH=1
+endif
+
+
+#
+# Tools
+#
+
+ifndef FAILLIST
+export FAILLIST:=faillist
+endif
+
+ifndef LONGLOG
+export LONGLOG:=longlog
+endif
+
+ifndef LOG
+export LOG:=log
+endif
+
+units : units/$(FPCMADE)
+units/$(FPCMADE):
+	$(MAKE) -C units
+
+DOTEST=dotest$(EXEEXT)
+$(DOTEST) : utils/dotest.pp utils/redir.pp
+	$(FPC) -Fu../units -FE. utils/dotest
+
+testcheck: units $(DOTEST)
+
+#
+# Test run targets
+#
+
+DIRS=webtbs webtbf tbs tbf test testopt
+
+all : alltests
+
+tests : clean all_compilations
+
+cont_tests : all_compilations
+
+%.log : %.pp
+	$(DOTEST) $<
+
+%.elg : %.pp
+	$(DOTEST) -e $<
+
+alltbs : testcheck $(patsubst %.pp,%.log,$(wildcard tbs/*.pp))
+alltbf : testcheck $(patsubst %.pp,%.log,$(wildcard tbf/*.pp))
+
+allwebtbs : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp))
+allwebtbf : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp))
+
+alltest : testcheck $(patsubst %.pp,%.log,$(wildcard test/*.pp))
+alltestopt : testcheck $(patsubst %.pp,%.log,$(wildcard testopt/*.pp))
+
+alltests: alltest alltbs alltbf allwebtbs allwebtbf
+
+clean:
+	-rm -f $(addsuffix /*$(PPUEXT),$(DIRS))
+	-rm -f $(addsuffix /*$(OEXT),$(DIRS))
+	-rm -f $(addsuffix /*.rst,$(DIRS))
+	-rm -f $(addsuffix /*$(SHAREDLIBEXT),$(DIRS))
+	-rm -f $(addsuffix /*.log,$(DIRS))
+	-rm -f $(addsuffix /*.elg,$(DIRS))
+ifdef INUNIX
+	-rm -f $(wildcard $(patsubst %.pp,%$(EXEEXT),$(wildcard $(addsuffix /t*.pp,$(DIRS)))))
+else
+	-rm -f $(addsuffix /*$(EXEEXT),$(DIRS))
+endif
+	-rm -f *.tmp
+	-rm -f $(LOG) $(LONGLOG) $(FAILLIST)
+	-rm -f ppas.sh ppas.bat gmon.out
+
+full : clean all_compilations allexec
+
+info :
+	@echo This Makefile allows to test the compiler
+	@echo compilation of 'ts*.pp' should succeed
+	@echo compilation of 'tf*.pp' should fail
+	@echo compilation of 'test*.pp' should succeed
+	@echo 'to*.pp' files should also compile
+	@echo simply run \'make tests\' to test all compilation
+	@echo run \'make allexec\' to test also if the executables
+	@echo created behave like the should
+	@echo run \'make tesiexec\' to test executables
+	@echo that require interactive mode

tests/tbf/tb0001.pp

@@ -0,0 +1,9 @@
+{ Old file: tbf0010.pp }
+{  tests string constants exceeding lines              OK 0.9.2 }
+
+program hello;
+
+  begin
+     writeln('Hello);
+  end.
+

tests/tbf/tb0002.pp

@@ -0,0 +1,15 @@
+{ Old file: tbf0029.pp }
+{  tests typeof(object type)                         OK 0.99.1 (FK) }
+
+type
+  TA = object
+  end;
+
+var
+   P: Pointer;
+
+begin
+   { must fail on compilation because
+     TA has no VMT }
+   P := pointer(TypeOf(TA));
+end.

tests/tbf/tb0003.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0036.pp }
+{  assigning a single character to array of char      ?OK 0.9.9 }
+
+program bug0036;
+
+{Discovered by Daniel Mantione.}
+
+var     a:array[0..31] of char;
+
+begin
+   a:=' ';      {Incorrect Pascal statement, but why a protection error?}
+end.

tests/tbf/tb0004.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0049.pp }
+{  shows an error while defining subrange types         OK 0.99.7 (PFV) }
+
+type
+   days = (Mon,Tue,Wed,Thu,Fri,Sat,Sun);
+   weekend = Sat..Sun;
+
+var
+   w : weekend;
+
+begin
+   w:=5;
+   {$message the line before should produce an error }
+end.

tests/tbf/tb0005.pp

@@ -0,0 +1,24 @@
+{ Old file: tbf0060.pp }
+{  shows missing type checking for case statements      OK 0.99.1 (CEC) }
+
+Program Test;
+
+{ No errors -- problems is due to the fact that the rules for type
+compatibility (p.47 language guide) -- are not respected, in other words
+in case statements there is no type checking whatsoever in fpc!!
+ I think that these are separate cases:
+   1st case) s32bit,u32bit,u8bit,s8bit,s16bit,u16bit
+   2nd case) uchar
+   3rd case) bool8bit
+These are not /should not be compatible with each other in a case
+statement imho - CEC
+}
+
+var
+ myvar:char;
+Begin
+ case myvar of
+ 1: ;
+ #2: ;
+ end;
+end.

tests/tbf/tb0006.pp

@@ -0,0 +1,6 @@
+{ Old file: tbf0061.pp }
+{  shows wrong errors when compiling (NOT A bugs)        OK 0.99.1 }
+
+Begin
+ 55ms;
+end.

tests/tbf/tb0007.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0071.pp }
+{  shows that an unterminated constant string in a writeln() statement crashes the compiler. }
+
+program tbf0071;
+
+begin
+  writeln ('
+end.

tests/tbf/tb0008.pp

@@ -0,0 +1,34 @@
+{ Old file: tbf0075.pp }
+{  shows invalid pchar output to console                 OK 0.99.1 }
+
+Unit tbs0075;
+
+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;Forward;
+
+
+Procedure MySecondTest;Far;
+Begin
+end;
+
+
+
+
+
+end.

tests/tbf/tb0009.pp

@@ -0,0 +1,6 @@
+{ Old file: tbf0085.pp }
+{  shows runerror 216                                    OK 0.99.1 (CEC) }
+
+Begin
+ writeln(l);
+end.

tests/tbf/tb0010.pp

@@ -0,0 +1,18 @@
+{ Old file: tbf0086.pp }
+{  shows runerror 216                                    OK 0.99.1 (CEC) }
+
+
+var
+ v: word;
+ w: shortint;
+ z: byte;
+ y: integer;
+
+type
+ zz: shortint = 255;
+Begin
+ y:=64000;
+ z:=32767;
+ w:=64000;
+ v:=-1;
+end.

tests/tbf/tb0011.pp

@@ -0,0 +1,18 @@
+{ Old file: tbf0087.pp }
+{  shows internal error 12 - no more SegFaults           OK 0.99.1 (FK) }
+
+{
+  BP Error message is 'Pointer variable Expected'
+}
+type
+  tobj=object
+    l : longint;
+    constructor init;
+  end;
+var
+  o : tobj;
+begin
+  new(o);            {This will create a internal error 9999}
+  new(o,init);       {This will create a Segfault and Core Dump under linux}
+end.
+    

tests/tbf/tb0012.pp

@@ -0,0 +1,6 @@
+{ Old file: tbf0088.pp }
+{  internal error 12 or Runerror 216                     OK 0.99.1 (FK) }
+
+Begin
+ typeof(x1);    { Gives out an internal error -- better then 9999 though }
+end.

tests/tbf/tb0013.pp

@@ -0,0 +1,6 @@
+{ Old file: tbf0089.pp }
+{  internal error 12 or Runerror 216                     OK 0.99.1 (FK) }
+
+Begin
+ sizeof(x);
+end.

tests/tbf/tb0014.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0094.pp }
+{ internal error when recordtype not found with case    OK 0.99.1 }
+
+begin
+  case textrec(l).mode of
+   1 ;
+  end;
+end.

tests/tbf/tb0015.pp

@@ -0,0 +1,42 @@
+{ Old file: tbf0097.pp }
+{ two errors in bp7 but not in FPC                      OK 0.99.6 (FK) }
+
+{
+  This compiles fine with FPC, but not with Bp7 see 2 comments
+}
+
+type
+  t=object
+    s : string;      { No ; needed ? }
+    procedure p;
+  end;
+
+  t2=object(t)
+    procedure p1(p : string);
+  end;
+
+procedure t2.p1(p : string);
+
+  begin
+  end;
+
+procedure t.p;
+
+var
+  s : longint;      { Not allowed with BP7 }
+  x : longint;
+
+procedure nested;
+
+  var
+     s : longint;
+
+  begin
+  end;
+
+begin
+end;
+
+
+begin
+end.

tests/tbf/tb0016.pp

@@ -0,0 +1,10 @@
+{ Old file: tbf0100.pp }
+{ a unit may only occure once in uses                   OK 0.99.6 (PM) }
+
+unit tbs0100;
+interface
+uses dos;
+implementation
+uses dos;             { Not Allowed in BP7}
+end.
+

tests/tbf/tb0017.pp

@@ -0,0 +1,21 @@
+{ Old file: tbf0101.pp }
+{ no type checking for routines in interfance and       OK 0.99.1 (CEC) }
+
+Unit tbs0101;
+
+Interface
+
+ Procedure MyProc(V: Integer);
+
+
+Implementation
+
+ Procedure MyProc(Y: Integer);
+ Begin
+ end;
+
+
+end.
+
+
+

tests/tbf/tb0018.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0108.pp }
+{ gives wrong error message                             OK 0.99.1 (PFV) }
+
+uses
+  dos,
+  ;
+begin
+end.

tests/tbf/tb0019.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0109.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.

tests/tbf/tb0020.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0110.pp }
+{ SigSegv when using undeclared var in Case             OK 0.99.6 (PFV) }
+
+Begin
+  Case Pai(hp1)^.typ Of
+    ait_instruction:
+  End
+End.

tests/tbf/tb0021.pp

@@ -0,0 +1,24 @@
+{ Old file: tbf0117.pp }
+{ internalerror 17 (and why is there an automatic float OK 0.99.6 (FK) }
+
+var
+ i: word;
+ j: integer;
+Begin
+ i:=65530;
+ i:=i+1;     { CF check  }
+ i:=i-1;
+ i:=i*5;
+ i:=i/5;
+ i:=i shl 5;
+ i:=i shr 5;
+ Inc(i);     { no check  }
+ j:=32765;   { OV check  }
+ j:=j+1;
+ inc(j);
+ j:=j-1;
+ j:=j*5;
+ j:=j div 5;
+ j:=j shl 5;
+ j:=j shr 5;
+end.

tests/tbf/tb0022.pp

@@ -0,0 +1,20 @@
+{ Old file: tbf0127.pp }
+{ problem with cdecl in implementation part             OK 0.99.7 (PFV) }
+
+unit tbf0127;
+
+  interface
+
+    procedure x(l : longint);
+
+  implementation
+
+    procedure crash;
+
+      begin
+         x(1234); { called with pascal calling conventions }
+      end;
+
+   procedure x(l : longint);external;cdecl;
+
+end.

tests/tbf/tb0023.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0136.pp }
+{ No types necessary in the procedure header            OK 0.99.6 (PFV) }
+
+{
+  No type declaration necessary ????
+}
+procedure p(handle1,handle2);
+begin
+end;
+
+begin
+end.

tests/tbf/tb0024.pp

@@ -0,0 +1,23 @@
+{ Old file: tbf0148.pp }
+{ crash when setting function result of a declared but not yet implemented function in another function }
+
+unit test;
+
+interface
+
+Function t(a: Byte): byte;
+Function DoT(b: byte): Byte;
+
+implementation
+
+Function t(a: Byte): Byte;
+var f: byte;
+Begin
+  DoT := f;
+End;
+
+Function DoT(b: byte): Byte;
+Begin
+End;
+
+end.

tests/tbf/tb0025.pp

@@ -0,0 +1,13 @@
+{ Old file: tbf0151.pp }
+{ crash when using undeclared variable in withstatement OK 0.99.7 (PFV) }
+
+type tr = record
+            l1, l2: longint
+          end;
+
+var r: tr;
+
+begin
+  with r do
+    inc(l)
+end.

tests/tbf/tb0026.pp

@@ -0,0 +1,20 @@
+{ Old file: tbf0153.pp }
+{ Asm, indexing a local/para var should produce an error like tp7 OK 0.99.9 (PFV) }
+
+{$asmmode att}
+
+procedure asmfunc(p:pointer);assembler;
+asm
+{
+  this is changed into movl %eax,(%ebx+8) which is not correct, and tp7
+  also doesn't allow 'mov p[bx],ax' or 'mov p+bx,ax'
+
+  Solution: for parameters and locals the index must be turned off
+
+  Don't forget to check the intel assembler also
+}
+        movl    %eax,p(%ebx)
+end;
+
+begin
+end.

tests/tbf/tb0027.pp

@@ -0,0 +1,20 @@
+{ Old file: tbf0155.pp }
+{ Asm, Missing string return for asm functions }
+
+{ this is not a real bug but rather a feature :
+  assembler function are only accepted for
+  simple return values
+  i.e. either in register or FPU  (PM) }
+
+{ so for the moment this is rejected code ! }
+
+function asmstr:string;assembler;
+asm
+        movl    __RESULT,%edi
+        movl    $0x4101,%al
+        stosw
+end;
+
+begin
+  writeln(asmstr);
+end;

tests/tbf/tb0028.pp

@@ -0,0 +1,20 @@
+{ Old file: tbf0157.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;
+    i : longint;
+    s : string;
+begin
+x:=5.6;
+y:=45.789;
+write(y:2:3,' ',x:3:4);
+write(i:5);
+s:='short';
+write(s:11);
+write(i:5:2);
+write(s:25:3);
+write(x:5.2);
+end.

tests/tbf/tb0029.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0158.pp }
+{ Invalid boolean typecast                              OK 0.99.7 (PFV) }
+
+program tmp;
+
+var
+   Molo  :Boolean;
+
+begin
+   Molo := 1;     { This should give out a Type mismatch error ! }
+end.

tests/tbf/tb0030.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0161.pp }
+{ internal error when trying to create a set with another OK 0.99.9 (PFV) }
+
+Program tbs0161;
+
+{the following program should give a syntax error, but causes an internal error}
+
+const s = [1,2,3,4,5];
+
+var b: Byte;
+
+Begin
+  If b in [s] then;
+End.

tests/tbf/tb0031.pp

@@ -0,0 +1,17 @@
+{ Old file: tbf0164.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;
+
+begin
+  with r.l1[counter] Do
+    Inc(a)
+end.

tests/tbf/tb0032.pp

@@ -0,0 +1,13 @@
+{ Old file: tbf0166.pp }
+{ forward type used in declaration crashes instead of error OK 0.99.9 (PFV) }
+
+type
+  punknown=^unknown;
+
+  t=object
+    procedure p(i:unknown);
+  end;
+
+begin
+end.
+  

tests/tbf/tb0033.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0167.pp }
+{ crash when declaring a procedure with same name as object OK 0.99.9 (PFV) }
+
+type ObjTest = Object
+     End;
+
+Procedure ObjTest;
+Begin
+end;
+
+Begin
+end.

tests/tbf/tb0034.pp

@@ -0,0 +1,9 @@
+{ Old file: tbf0168.pp }
+{ set:=set+element is allowed (should be: set:=set+[element]) OK 0.99.9 (PFV) }
+
+var bset: set of 0..31;
+    b: byte;
+
+Begin
+  bset := bset + b;
+End.

tests/tbf/tb0035.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0172.pp }
+{ with with absolute seg:ofs should not be possible OK 0.99.9 (PM) }
+
+type
+  rec=record
+    a : longint;
+  end;
+
+var
+  r1 : rec absolute $40:$49;
+begin
+  with r1 do
+   a:=1;
+end.

tests/tbf/tb0036.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0173.pp }
+{ secondbugs is parsed as asm, but should be normal pascalcode OK 0.99.9 (PFV) }
+
+var
+  secondbug : word;
+procedure p;assembler;
+begin
+  if secondbug=0 then;
+end;
+
+begin
+end.

tests/tbf/tb0037.pp

@@ -0,0 +1,13 @@
+{ Old file: tbf0175.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 an error }
+{$asmmode att}
+{$R+}
+var
+  w : word;
+begin
+  asm
+        movl w,%ecx
+  end;
+end.

tests/tbf/tb0038.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0186.pp }
+{ Erroneous array syntax is accepted.                   OK 0.99.9 (PFV) }
+
+  program bug0186;
+   var
+    endline:^integer;
+    line:array [1..endline^] of ^char;
+   begin
+    new (endline);
+    endline^:=5;
+    endline^:=10;
+   end.

tests/tbf/tb0039.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0196.pp }
+{ "function a;" is accepted (should require result type) OK 0.99.1 (PM) }
+
+Program bug0195;
+
+function a;
+begin
+end;
+
+begin
+  a
+end.

tests/tbf/tb0040.pp

@@ -0,0 +1,16 @@
+{ Old file: tbf0197.pp }
+{ should produce an error: problem with c1:=c2<c3 where c? is OK 0.99.11 (PM) a comp type }
+
+
+var i : DWord;
+    c1, c2 : comp;
+
+begin
+     c1 := 20000; c2 := 100;
+     i := 0;
+     repeat
+           inc(i);
+           c1 := (abs(3*c1)-c2) < c2;   { notice this !!! :) :) }
+     until (i > 1000);
+     Writeln(c1);
+end.

tests/tbf/tb0041.pp

@@ -0,0 +1,34 @@
+{ Old file: tbf0205.pp }
+{ and parsing bugs, generates wrong code (tp7 gives parser error) OK 0.99.11 (PM) }
+
+program bug_show;
+{ By PAV (pavsoft@usa.net) }
+
+function bad_uppercase(s:string):string;
+var i:integer;
+begin
+  for i:=1 to length(s) do
+    if (ord(s[i])>=97 and ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65);
+  bad_uppercase:=s;
+end;
+
+function good_uppercase(s:string):string;
+var i:integer;
+begin
+  for i:=1 to length(s) do
+    if (ord(s[i])>=97) and (ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65);
+  good_uppercase:=s;
+end;
+
+const cadena='Free Paskal Compiler 0.99.8  !!! (bug)';
+begin
+  writeln('This is the original string before convert it');
+  writeln(cadena);
+  writeln();
+  writeln('This is a bad result, using "if (  and  )"');
+  writeln(bad_uppercase(cadena));
+  writeln();
+  writeln('This is a good result, using "if () and ()"');
+  writeln(good_uppercase(cadena));
+  writeln();
+end.

tests/tbf/tb0042.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0208.pp }
+{ implicit conversion from boolean to longint should not be allowed }
+
+program tbf0208;
+
+{ implicit boolean to integer conversion should not be
+  allowed }
+var
+  b : boolean;
+  i : longint;
+begin
+  b:=true;
+  i:=b;
+end.

tests/tbf/tb0043.pp

@@ -0,0 +1,16 @@
+{ Old file: tbf0219.pp }
+{ wrong error message                                  OK 0.99.11 (PFV) }
+
+{ Should give '(' expected in line 6 }
+
+   const
+     replaces=4;
+     replacetab : array[1..replaces,1..2] of string[32]=(
+       ':',' or colon',
+       'mem8','mem or bits8',
+       'mem16','mem or bits16',
+       'mem32','mem or bits32'
+     )
+begin
+end.
+

tests/tbf/tb0044.pp

@@ -0,0 +1,17 @@
+{ Old file: tbf0230.pp }
+{ several strange happen on the ln function: ln(0): no FPE and writeln can't write non numeric values Gives out an exception on compiling because of zero div OK 0.99.11 (PM) }
+
+{$ifdef go32v2}
+uses
+   dpmiexcp;
+{$endif}
+
+var
+   e : extended;
+
+begin
+ e:=-1.0;
+ writeln(ln(0));
+ writeln(power(0,1.0));
+ writeln(ln(e));
+end .

tests/tbf/tb0045.pp

@@ -0,0 +1,20 @@
+{ Old file: tbf0231.pp }
+{ Problem with comments                                OK 0.99.11 (PFV) }
+
+
+{$undef dummy}
+
+{$ifdef DUMMY}
+   (* <= this should not be considered as a
+   higher comment level !!
+
+  test
+{$endif dummy}
+
+var
+   e : extended;
+
+begin
+ e:=1.0;
+ writeln(ln(e));
+end.

tests/tbf/tb0046.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0234.pp }
+{ New with void pointer                                OK 0.99.11 (PM) }
+
+program bug0232;
+
+var p:pointer;
+
+begin
+     new(p);
+     dispose(p);
+end.

tests/tbf/tb0047.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0242.pp }
+{ Crash when passing a procedure to formal parameter   OK 0.99.11 (PM) }
+
+procedure p;
+begin
+end;
+
+procedure p1(var x);
+begin
+end;
+
+begin
+  p1(p);
+end.

tests/tbf/tb0048.pp

@@ -0,0 +1,29 @@
+{ Old file: tbf0245.pp }
+{ assigning pointers to address of consts is allowed (refused by BP !) OK 0.99.13 (PFV) }
+
+const
+ r = 3.5;
+ s = 'test idiot';
+type
+  preal = ^real;
+  pstring = ^string;
+
+  procedure ss;
+   begin
+   end;
+
+var
+  p : pointer;
+  pr : preal;
+  ps : pstring;
+
+  begin
+   p:=@ss;
+   p:=@s;
+   pr:=@r;
+   ps:=@s;
+   pr^:=7.8;
+   ps^:='test3';
+   Writeln('r=',r,' s=',s);
+  end.
+

tests/tbf/tb0049.pp

@@ -0,0 +1,16 @@
+{ Old file: tbf0246.pp }
+{ const para can be changed without error              OK 0.99.13 (PFV) }
+
+type
+  tref=record
+    ofs : longint;
+  end;
+
+procedure p(const ref:tref);
+begin
+  with ref do
+   ofs:=ofs+1;   { This should issue an error, because ref is const ! }
+end;
+
+begin
+end.

tests/tbf/tb0050.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0248.pp }
+{ Asm, Wrong assembler code accepted by new assembler reader OK 0.99.11 (PFV) }
+
+{$asmmode att}
+
+begin
+  asm
+     call *%eax // this is correct
+     movl %esi,*%eax
+  end;
+end.

tests/tbf/tb0051.pp

@@ -0,0 +1,24 @@
+{ Old file: tbf0265.pp }
+{ nested proc with for-counter in other lex level      OK 0.99.13 (PFV) }
+
+PROGRAM t9;
+
+PROCEDURE Eeep;
+VAR
+   X: BYTE;
+   NewNG: STRING;
+PROCEDURE SubProc;
+   BEGIN
+      newng := 'alt';
+      FOR X := 1 TO LENGTH(NewNG) DO BEGIN
+         WRITELN(X);
+   END;
+END;
+BEGIN
+   SubProc;
+END;
+
+BEGIN
+        Eeep;
+END.
+

tests/tbf/tb0052.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0269.pp }
+{ wrong linenumber for repeat until when type mismatch OK 0.99.12b (PM) }
+
+{ No idea how I could test this !! PM }
+{ we should parse the compiler output !! }
+{ Wrong line number for error message }
+begin
+  repeat
+   writeln('test');
+  until sptr;
+end.

tests/tbf/tb0053.pp

@@ -0,0 +1,39 @@
+{ Old file: tbf0272.pp }
+{ No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) }
+
+program test_const_string;
+
+const
+   conststring = 'Constant 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';
+
+begin
+  testvalue(astring('e'));
+  testconst(astring(s));
+  testconst(conststring);
+  testvar(conststring);{ refused a compile time }
+end.
+

tests/tbf/tb0054.pp

@@ -0,0 +1,22 @@
+{ Old file: tbf0281.pp }
+{ dup id checking with property is wrong }
+
+{$mode objfpc}
+
+type
+  test_one = class
+     protected
+       fTest : String;
+     public
+       property Test: String READ fTest WRITE fTest;
+       procedure Testen(Test: BOolean);
+                        { ^ duplicate identifier? }
+  end;
+
+
+procedure test_one.testen(test: boolean);
+begin
+end;
+
+begin
+end.

tests/tbf/tb0055.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0284.pp }
+{ wrong file position with dup id in other unit        OK 0.99.13 (PFV) }
+
+uses tbs0284b;
+{$HINTS ON}
+type
+  o2=object(o1)
+    p : longint;
+  end;
+
+begin
+end.

tests/tbf/tb0056.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0298.pp }
+{ l1+l2:=l1+l2 gives no error                          OK 0.99.13 (PFV) }
+
+program test_loc_mem;
+
+{$ifdef go32v2}
+  uses
+    dpmiexcp;
+{$endif go32v2}
+
+var l1,l2 : longint;
+begin
+  l1+l2:=l1+l2;
+end.

tests/tbf/tb0057.pp

@@ -0,0 +1,7 @@
+{ Old file: tbf0300.pp }
+{ crash if method on non existing object is parsed (form bugs 651) OK 0.99.13 (PFV) }
+
+ procedure nonexistent_class_or_object.method; begin end;
+begin
+end.
+

tests/tbf/tb0058.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0301.pp }
+{ crash if destructor without object name is parsed    OK 0.99.13 (PFV) }
+
+Program bug0301;
+
+destructor done;
+begin
+end;
+
+begin
+end.

tests/tbf/tb0059.pp

@@ -0,0 +1,13 @@
+{ Old file: tbf0310.pp }
+{ local and para dup are not detected                    OK 0.99.15 (FK) }
+
+procedure p(s:string);
+var
+  s : string;
+begin
+  writeln(s);
+end;
+
+begin
+  p('test');
+end.

tests/tbf/tb0060.pp

@@ -0,0 +1,14 @@
+{ Old file: tbf0311.pp }
+{ No dup id checking in variant records                  OK 0.99.15 (FK) }
+
+type
+  tsplitextended = record
+    case byte of
+      0: (a: array[0..9] of byte);
+      { the following "a" should give a duplicate identifier error }
+      1: (a: array[0..4] of word);
+      2: (a: array[0..1] of cardinal; w: word);
+    end;
+
+begin
+end.

tests/tbf/tb0061.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0314.pp }
+{  }
+
+procedure p(var b);
+begin
+end;
+
+var
+  s : string;
+begin
+  p(@s[1]);
+end.

tests/tbf/tb0062.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0315.pp }
+{  }
+
+begin
+asm
+    movl $%1000, %eax
+end;
+end.

tests/tbf/tb0063.pp

@@ -0,0 +1,30 @@
+{ Old file: tbf0320.pp }
+{  }
+
+{$ifdef fpc}{$mode delphi}{$endif}
+
+{ These should give an error, as also done in tp,delphi.
+  See tbs0319.pp for a test with class which should compile in
+  delphi mode }
+
+type
+  cl=object
+    k : longint;
+    procedure p1;
+    procedure p2;
+  end;
+
+procedure cl.p1;
+var
+  k : longint;
+begin
+end;
+
+procedure cl.p2;
+var
+  p1 : longint;
+begin
+end;
+
+begin
+end.

tests/tbf/tb0064.pp

@@ -0,0 +1,9 @@
+{ Old file: tbf0323.pp }
+{  }
+
+{$ifdef fpc}{$mode delphi}{$endif}
+type
+    TA = (aOne := 1, aTwo, aThree, aFour, aSix);
+
+begin
+end.

tests/tbf/tb0065.pp

@@ -0,0 +1,13 @@
+{ Old file: tbf0324.pp }
+{  }
+
+{$ifdef fpc}{$mode delphi}{$endif}
+
+function k2:longint;
+var
+  result : word;
+begin
+end;
+
+begin
+end.

tests/tbf/tb0066.pp

@@ -0,0 +1,17 @@
+{ Old file: tbf0325.pp }
+{  }
+
+{$ifdef fpc}{$mode delphi}{$endif}
+
+function k2(result:word):longint;
+begin
+end;
+
+function k3(l:word):longint;
+var
+  result : word;
+begin
+end;
+
+begin
+end.

tests/tbf/tb0067.pp

@@ -0,0 +1,9 @@
+{ Old file: tbf0326.pp }
+{  }
+
+{$mode delphi}
+const
+    anyconst = %11111;
+
+begin
+end.

tests/tbf/tb0068.pp

@@ -0,0 +1,24 @@
+{ Old file: tbf0328.pp }
+{  }
+
+{$ifdef fpc}{$mode delphi}{$endif}
+
+procedure k1(l:longint);
+begin
+end;
+
+procedure k1(l:string);overload;
+begin
+end;
+
+procedure k2(l:longint);overload;
+begin
+end;
+
+procedure k2(l:string);
+begin
+end;
+
+
+begin
+end.

tests/tbf/tb0069.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0342.pp }
+{  }
+
+type
+  WORD=word;
+
+begin
+end.

tests/tbf/tb0070.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0343.pp }
+{  }
+
+{$mode delphi}
+type
+  TListEntry = record
+    Next: ^TListEntry;                      (*<-- Error message here*)
+    Data: Integer;
+  end;
+
+begin
+end.

tests/tbf/tb0071.pp

@@ -0,0 +1,8 @@
+{ Old file: tbf0345.pp }
+{  }
+
+var
+  WORD : array[1..2] of word;
+
+begin
+end.

tests/tbf/tb0072.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0347.pp }
+{  }
+
+{$mode delphi}
+
+type x = ^longint;
+
+var y:x;
+
+begin
+ y [5]:=5;
+end.

tests/tbf/tb0073.pp

@@ -0,0 +1,17 @@
+{ Old file: tbf0349.pp }
+{  }
+
+{$mode delphi}
+
+type
+  TCl=class;
+
+const
+  b=1;
+
+type
+  TCL=class
+  end;
+
+begin
+end.

tests/tbf/tb0074.pp

@@ -0,0 +1,12 @@
+{ %OPT=-Sew }
+
+{ Old file: tbf0351.pp }
+
+{$MACRO OFF}
+
+{ The next line should give a Warning that macro support not has
+  been turned on }
+{$define mac1 := writeln('test')}
+
+begin
+end.

tests/tbf/tb0075.pp

@@ -0,0 +1,18 @@
+{ Old file: tbf0352.pp }
+{  }
+
+{$ifdef fpc}{$MODE OBJFPC}{$endif}
+
+Procedure Proc1(args:array of const);
+begin
+end;
+
+Procedure Proc2(args:array of longint);
+Begin
+  { this should give an error }
+  Proc1(args);
+End;
+
+Begin
+  Proc1([0,1]);
+End.

tests/tbf/tb0076.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0353.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+     private
+       procedure p;
+   end;
+
+begin
+end.

tests/tbf/tb0077.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0354.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+     constructor create; 
+   end;
+
+begin
+end.

tests/tbf/tb0078.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0355.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+      destructor destroy; 
+   end;
+
+begin
+end.

tests/tbf/tb0079.pp

@@ -0,0 +1,11 @@
+{ Old file: tbf0356.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+      l : longint;
+   end;
+
+begin
+end.

tests/tbf/tb0080.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0357.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+     protected
+       procedure p;
+   end;
+
+begin
+end.

tests/tbf/tb0081.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0358.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+     public
+       procedure p;
+   end;
+
+begin
+end.

tests/tbf/tb0082.pp

@@ -0,0 +1,12 @@
+{ Old file: tbf0359.pp }
+{  }
+
+{ $version >= 1.1}
+type
+   ti = interface
+     published
+       procedure p;
+   end;
+
+begin
+end.

tests/tbf/tb0083.pp

@@ -0,0 +1,18 @@
+{ Old file: tbf0360.pp }
+{  }
+
+procedure myproc;
+var
+  a: word;
+  a: word;
+  a: word;
+  a: word;
+  a: word;
+begin
+  a := 1;
+  writeln (a);
+end;
+
+begin
+  myproc;
+end.

tests/tbf/tb0084.pp

@@ -0,0 +1,34 @@
+{ Old file: tbf0361.pp }
+{  }
+
+type
+
+  ExecProc = Procedure;
+  
+type
+  MenuItem = record
+               Caption: String[32];
+               Exec: ExecProc;
+             end;
+             
+Procedure AddItem(ACaption: String; AExec: ExecProc; var Item: MenuItem);
+begin
+  Item.Caption:=ACaption;
+  Item.Exec:=AExec;
+end;
+
+Procedure ExecFirstItem;
+begin
+  Writeln('Result of "Item 1"');
+end;
+
+var M1,M2,M3: MenuItem;
+    Ep: ExecProc;
+
+begin
+  AddItem('Item 1',Nil,M1);
+  Ep:=ExecFirstItem;        // should give error in fpc mode
+  AddItem('Item 2',Ep,M2);
+  AddItem('Item 3',@ExecFirstItem,M3);
+end.
+

tests/tbf/tb0085.pp

@@ -0,0 +1,11 @@
+
+type
+  r=record
+    a :longint;
+  end;
+var
+  w : ^r;
+begin
+  if w^<>$1111 then
+   writeln;
+end.

tests/tbf/tb0086.pp

@@ -0,0 +1,8 @@
+
+var
+  i,j : longint;
+begin
+  i:=longint;
+  j:=i*word+j*shortint;
+  j:= 15 +5*i +(i*i)+sqr(word);
+end.

tests/tbf/tb0087.pp

@@ -0,0 +1,10 @@
+{$mode objfpc}
+label l;
+
+begin
+   try
+      goto l;
+   finally     
+   end;
+   l:
+end.

tests/tbf/tb0088.pp

@@ -0,0 +1,10 @@
+{$mode objfpc}
+label l;
+
+begin
+   try
+   finally     
+   l:
+   end;
+   goto l;
+end.

tests/tbf/tb0089.pp

@@ -0,0 +1,10 @@
+{$mode objfpc}
+label l;
+
+begin
+   try
+   except
+      goto l;
+   end;
+   l:
+end.

tests/tbf/tb0090.pp

@@ -0,0 +1,14 @@
+{$mode objfpc}
+uses
+   sysutils;
+
+label l;
+
+begin
+   try
+   except
+      on e : exception do
+        goto l;
+   end;
+   l:
+end.

tests/tbf/tb0091.pp

@@ -0,0 +1,20 @@
+{$mode objfpc}
+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.

tests/tbf/tb0092.pp

@@ -0,0 +1,20 @@
+
+
+type
+   obj = object
+     procedure method1;
+     procedure method2;
+     end;
+
+  procedure obj.method1;
+
+    procedure obj.method2;
+
+      begin
+      end;
+
+    begin
+    end;
+
+  begin
+  end.

tests/tbf/tb0093.pp

@@ -0,0 +1,23 @@
+{$mode objfpc}
+type
+   to1 = class
+      procedure p;virtual;
+   end;
+
+   to2 = class(to1)
+     function p : longint;override;
+   end;
+
+  procedure to1.p;
+
+    begin
+    end;
+
+  function to2.p : longint;
+
+    begin
+    end;
+
+begin
+end.
+

tests/tbf/tb0094.pp

@@ -0,0 +1,9 @@
+{ Old file: tbf0008.pp }
+{  tests the crash when decrementing constants         OK 0.9.2 }
+
+const
+   compilerconst=1;
+
+begin
+   dec(compilerconst);
+end.

tests/tbf/tb0095.pp

@@ -0,0 +1,14 @@
+{ Old file: tbs0356.pp }
+{  }
+
+unit tb0297;
+interface
+uses sysutils;
+type
+
+   Foo =
+        packed record
+                Dates : array[1..11] of Date;
+        end;
+implementation	
+end.

tests/tbs/tb0001.pp

@@ -0,0 +1,86 @@
+{ 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.

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.

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.
+