+ latest bugs converted

tests/Makefile

@@ -162,9 +162,14 @@ alltbs : $(patsubst %.pp,%.res,$(wildcard tbs*.pp))
 tbs0to99 : $(patsubst %.pp,%.res,$(wildcard tbs00*.pp))
 tbs100to199 : $(patsubst %.pp,%.res,$(wildcard tbs01*.pp))
 tbs200to299 : $(patsubst %.pp,%.res,$(wildcard tbs02*.pp))
+tbs300to399 : $(patsubst %.pp,%.res,$(wildcard tbs03*.pp))
 
 alltest : $(patsubst %.pp,%.res,$(wildcard test*.pp))
 
+alltbug : $(patsubst %.pp,%.res,$(wildcard tbug*.pp))
+
+alltbuf : $(patsubst %.pp,%.ref,$(wildcard tbuf*.pp))
+
 alltesi : $(patsubst %.pp,%.res,$(wildcard tesi*.pp))
 
 alltis : $(patsubst %.pp,%.res,$(wildcard tis*.pp))
@@ -197,10 +202,10 @@ clean_fail :
 again : clean_fail $(addsuffix .res,$(TS_FAIL_LIST)) $(addsuffix .ref,$(TF_FAIL_LIST)) 
 	grep fails log
 
-all_compilations : allts alltbs alltf alltbf allto alltest alltesi alltis
+all_compilations : allts alltbs alltf alltbf alltbug alltbuf allto alltest alltesi alltis
 	grep fails log
 
-allexec : alltsexec alltbsexec alltestexec
+allexec : alltsexec alltbsexec alltbugexec alltestexec
 	grep "fails exec" log
 
 alltestexec: $(patsubst %.pp,%.elg,$(wildcard test*.pp)) 
@@ -211,11 +216,14 @@ alltesiexec: $(patsubst %.pp,%.eli,$(wildcard test*.pp))
 
 alltsexec: $(patsubst %.pp,%.elg,$(wildcard ts*.pp)) 
 
+alltbugexec : $(patsubst %.pp,%.elg,$(wilcard tbug*.pp))
+
 alltbsexec: $(patsubst %.pp,%.elg,$(wildcard tbs*.pp)) 
 
 tbsexec0to99 : $(patsubst %.pp,%.elg,$(wildcard tbs00*.pp)) 
 tbsexec100to199 : $(patsubst %.pp,%.elg,$(wildcard tbs01*.pp)) 
 tbsexec200to299 : $(patsubst %.pp,%.elg,$(wildcard tbs02*.pp)) 
+tbsexec300to399 : $(patsubst %.pp,%.elg,$(wildcard tbs03*.pp)) 
 
 alltisexec: $(patsubst %.pp,%.eli,$(wildcard tis*.pp)) 
 
@@ -231,6 +239,10 @@ info :
 	@echo compilation of 'ts*.pp' should succeed
 	@echo compilation of 'tf*.pp' should fail
 	@echo compilation of 'test*.pp' should succeed
+	@echo 'tbs*.pp' are files from bugs directory that should compile and run
+	@echo 'tbf*.pp' are files from bugs directory that should not compile
+	@echo 'tbug*.pp' are files from web bug repository that should compile and run
+	@echo 'tbuf*.pp' are files from web bug repository that should not compile 
 	@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
@@ -240,7 +252,10 @@ info :
 
 #
 # $Log$
-# Revision 1.7  1999-12-02 00:12:31  pierre
+# Revision 1.8  1999-12-02 13:37:37  pierre
+#  + latest bugs converted
+#
+# Revision 1.7  1999/12/02 00:12:31  pierre
 #  + splitted targets for Win95 selector bug
 #
 # Revision 1.6  1999/10/13 12:42:09  pierre

tests/tbf0297.pp

@@ -0,0 +1,14 @@
+program test_int;
+
+{$ifdef go32v2}
+  uses
+    dpmiexcp;
+{$endif go32v2}
+
+procedure int;interrupt;
+begin
+end;
+
+begin
+  int;
+end.

tests/tbf0298.pp

@@ -0,0 +1,11 @@
+program test_loc_mem;
+
+{$ifdef go32v2}
+  uses
+    dpmiexcp;
+{$endif go32v2}
+
+var l1,l2 : longint;
+begin
+  l1+l2:=l1+l2;
+end.

tests/tbf0301.pp

@@ -0,0 +1,8 @@
+Program bug0301;
+
+destructor done;
+begin
+end;
+
+begin
+end.

tests/tbs0291.pp

@@ -0,0 +1,25 @@
+{$mode tp}
+
+function ReturnString: string;
+begin
+  ReturnString := 'A string';
+end;
+
+procedure AcceptString(S: string);
+begin
+  WriteLn('Got: ', S);
+end;
+
+type
+  TStringFunc = function: string;
+
+const
+  SF: TStringFunc = ReturnString;
+var
+  S2: TStringFunc;
+begin
+  @S2:=@ReturnString;
+  AcceptString(ReturnString);
+  AcceptString(SF);
+  AcceptString(S2);
+end.

tests/tbs0292.pp

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

tests/tbs0293.pp

@@ -0,0 +1,28 @@
+program bug0293;
+
+{$ifdef fpc}{$mode objfpc}{$endif}
+
+TYPE  Ttype = class
+              field :LONGINT;
+              CONSTRUCTOR DOSOMETHING;
+              END;
+
+CONSTRUCTOR TTYPE.DOSOMETHING;
+BEGIN
+END;
+
+var
+  longint : longint;
+
+procedure p;
+VAR
+  TTYPE : TTYPE;
+BEGIn
+  ttype:=ttype.dosomething;
+END;
+
+begin
+  p;
+end.
+
+

tests/tbs0294.pp

@@ -0,0 +1,19 @@
+{ 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;
+begin
+  test:=1;
+end;
+
+var t : longint;
+
+begin
+  t:=2;
+  { here you get garbage value with BP ! }
+  Writeln('test(t=2) = ',test(t));
+  Writeln('t after test = ',t);
+end.

tests/tbs0295.pp

@@ -0,0 +1,18 @@
+type
+  t1=longint;
+
+procedure p;
+type
+  pt1=^t1;
+  t1=string;
+var
+  t : t1;
+  p : pt1;
+begin
+  p:=@t;
+  p^:='test';
+end;
+
+begin
+  p;
+end.

tests/tbs0296.pp

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

tests/tbs0299.pp

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

tests/tbs0300.pp

@@ -0,0 +1,4 @@
+ procedure nonexistent_class_or_object.method; begin end;
+begin
+end.
+

tests/tbs0302.pp

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