+ tbs0261 to 270 added

tests/tbs0261.pp

@@ -0,0 +1,32 @@
+program bug0261;
+
+{ test for operator overloading }
+{ Copyright (c) 1999 Lourens Veen }
+{ why doesn't this work? }
+uses
+  erroru,
+  tbs0261a;
+
+
+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.

tests/tbs0261a.pp

@@ -0,0 +1,54 @@
+unit tbs0261a;
+
+{ 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.

tests/tbs0262.pp

@@ -0,0 +1,114 @@
+program test;
+
+  type
+      obj1 = object
+        st2 : string;
+        constructor init;
+        procedure writeit;
+        procedure writeit(st : string);virtual;
+      end;
+
+      obj2 = object(obj1)
+        procedure writeit;virtual;
+      end;
+
+      obj3 = object(obj2)
+        l2 : longint;
+        procedure writeit(l : longint);virtual;
+        procedure writeit(st : string);virtual;
+      end;
+      
+      obj4 = object(obj3)
+        procedure writeit;virtual;
+        procedure writeit(st : string);virtual;
+      end;
+      
+      obj5 = object(obj4)
+        procedure writeit;virtual;
+        procedure writeit(st : string);
+        procedure writeit(l : longint);virtual;
+      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.

tests/tbs0263.pp

@@ -0,0 +1,15 @@
+{ $OPT=-Twin32 }
+library tbs0263;
+
+{
+  The export directive is not necessary anymore in delphi, it's a leftover
+  from the 16bit model, just like near and far.
+}
+
+procedure p;
+begin
+end;
+
+exports
+  p name 'p';
+end.

tests/tbs0264.pp

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

tests/tbs0265.pp

@@ -0,0 +1,21 @@
+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/tbs0266.pp

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

tests/tbs0267.pp

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

tests/tbs0268.pp

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

tests/tbs0269.pp

@@ -0,0 +1,8 @@
+{ 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/tbs0270.pp

@@ -0,0 +1,21 @@
+unit tbs0270;
+
+{$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.