* always call tobject.create/free in MacPas mode for new/dispose constructs

(since macpas methods may accidentally be called like that as well,
     as it doesn't have any constructors/destructors)
  + some tests for MacPas objects from the GNU Pascal testsuite

git-svn-id: trunk@5421 -

.gitattributes

@@ -6158,6 +6158,10 @@ tests/tbs/tb0507.pp svneol=native#text/plain
 tests/tbs/tb0508.pp svneol=native#text/plain
 tests/tbs/tb0509.pp svneol=native#text/plain
 tests/tbs/tb0510.pp svneol=native#text/plain
+tests/tbs/tb0511.pp svneol=native#text/plain
+tests/tbs/tb0512.pp svneol=native#text/plain
+tests/tbs/tb0513.pp svneol=native#text/plain
+tests/tbs/tb0514.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
 tests/tbs/ub0119.pp svneol=native#text/plain

compiler/pinline.pas

@@ -87,6 +87,12 @@ implementation
           begin
             classh:=tobjectdef(p.resultdef);
 
+            { make sure we call ObjPas.TObject.Create/Free and not a random }
+            { create/free method in a macpas descendent object (since those }
+            { are not supposed to be called automatically when you call     }
+            { new/dispose)                                                  }
+            while assigned(classh.childof) do
+              classh := classh.childof;
             if is_new then
               begin
                 sym:=search_class_member(classh,'CREATE');

tests/tbs/tb0511.pp

@@ -0,0 +1,96 @@
+{ original: peter5a.pas from the GNU Pascal testsuite }
+
+{ Mac Pascal objects }
+
+{$mode macpas}
+
+program peter5a;
+
+        type
+                Str = String[100];
+                BaseObject = object
+                        v1: Str;
+                        function m1: Str;
+                        function m2: Str;
+                end;
+                SuperObject = object(BaseObject)
+                        v2: Str;
+                        v3: Str;
+                        function m1: Str; override;
+                        function m2: Str; override;
+                        function m3: Str;
+                end;
+
+        var
+                good: Boolean;
+
+        function BaseObject.m1: Str;
+        begin
+                return 'BaseObject.' + v1;
+        end;
+
+        function BaseObject.m2: Str;
+        begin
+                return 'BaseObject.nov2';
+        end;
+
+        function SuperObject.m1: Str;
+        begin
+                return 'SuperObject.' + (inherited m1) + '.' + v1;
+        end;
+
+        function SuperObject.m2: Str;
+        begin
+                return 'SuperObject.' + (inherited m2) + '.' + v2;
+        end;
+
+        function SuperObject.m3: Str;
+        begin
+                return 'SuperObject.' + v3;
+        end;
+
+        procedure CheckEqual( const param, s1, s2: Str );
+        begin
+                if s1 <> s2 then begin
+                        good := false;
+                        WriteLn( 'Failed: ', param, ' = ', s1, ' is not equal to ', s2 );
+                end;
+        end;
+
+        var
+                base: BaseObject;
+                super: SuperObject;
+                reallysuper: BaseObject;
+begin
+        New(base);
+        base.v1 := 'basev1';
+
+        New(super);
+        super.v1 := 'superv1';
+        super.v2 := 'superv2';
+        super.v3 := 'superv3';
+
+        reallysuper := super; { reference copy only! }
+
+        good := true;
+
+        CheckEqual( 'base.m1', base.m1, 'BaseObject.basev1' );
+        CheckEqual( 'base.m2', base.m2, 'BaseObject.nov2' );
+
+        CheckEqual( 'super.m1', super.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'super.m2', super.m2, 'SuperObject.BaseObject.nov2.superv2' );
+        CheckEqual( 'super.m3', super.m3, 'SuperObject.superv3' );
+
+        CheckEqual( 'reallysuper.m1', reallysuper.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'reallysuper.m2', reallysuper.m2, 'SuperObject.BaseObject.nov2.superv2' );
+
+        if good then begin
+                WriteLn( 'OK' );
+        end
+        else begin
+                halt(1);
+        end;
+
+        Dispose( base );
+        Dispose( super );
+end.

tests/tbs/tb0512.pp

@@ -0,0 +1,98 @@
+{ original: peter5b.pas from the GNU Pascal testsuite }
+
+{ Mac Pascal objects }
+
+{$mode macpas}
+
+program peter5b;
+
+        type
+                Str = String[100];
+                BaseObject = object
+                        v1: Str;
+                        function m1: Str;
+                        function m2: Str;
+                end;
+                SuperObject = object(BaseObject)
+                        v2: Str;
+                        v3: Str;
+                        function m1: Str; override;
+                        function m2: Str; override;
+                        function m3: Str;
+                end;
+
+        var
+                good: Boolean;
+
+        function BaseObject.m1: Str;
+        begin
+                return 'BaseObject.' + v1;
+        end;
+
+        function BaseObject.m2: Str;
+        begin
+                return 'BaseObject.nov2';
+        end;
+
+        function SuperObject.m1: Str;
+        begin
+                return 'SuperObject.' + (inherited m1) + '.' + v1;
+        end;
+
+        function SuperObject.m2: Str;
+        begin
+                return 'SuperObject.' + (inherited m2) + '.' + v2;
+        end;
+
+        function SuperObject.m3: Str;
+        begin
+                return 'SuperObject.' + v3;
+        end;
+
+        procedure CheckEqual( const param, s1, s2: Str );
+        begin
+                if s1 <> s2 then begin
+                        good := false;
+                        WriteLn( 'Failed: ', param, ' = ', s1, ' is not equal to ', s2 );
+                end;
+        end;
+
+        var
+                base: BaseObject;
+                super: SuperObject;
+                reallysuper: BaseObject;
+begin
+        New(base);
+        base.v1 := 'basev1';
+
+        New(super);
+        with super do begin
+          v1 := 'superv1';
+          v2 := 'superv2';
+          v3 := 'superv3';
+        end;
+
+        reallysuper := super; { reference copy only! }
+
+        good := true;
+
+        with base do begin
+        CheckEqual( 'base.m1', m1, 'BaseObject.basev1' );
+        CheckEqual( 'base.m2', m2, 'BaseObject.nov2' );
+        end;
+        CheckEqual( 'super.m1', super.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'super.m2', super.m2, 'SuperObject.BaseObject.nov2.superv2' );
+        CheckEqual( 'super.m3', super.m3, 'SuperObject.superv3' );
+
+        CheckEqual( 'reallysuper.m1', reallysuper.m1, 'SuperObject.BaseObject.superv1.superv1' );
+        CheckEqual( 'reallysuper.m2', reallysuper.m2, 'SuperObject.BaseObject.nov2.superv2' );
+
+        if good then begin
+                WriteLn( 'OK' );
+        end else begin
+                halt(1)
+        end;
+
+        Dispose( base );
+        Dispose( super );
+end.

tests/tbs/tb0513.pp

@@ -0,0 +1,41 @@
+{ original: peter5c.pas from the GNU Pascal testsuite }
+
+{$mode macpas}
+
+program peter5c(output);
+
+   type
+     ObjectA = object
+       procedure Doit;
+     end;
+     ObjectB = object
+       obj: ObjectA;
+       function GetA: ObjectA;
+     end;
+
+var
+   ok: boolean;
+
+   procedure ObjectA.Doit;
+   begin
+     WriteLn( 'OK' );
+     ok := true;
+   end;
+
+   function ObjectB.GetA: ObjectA;
+   begin
+     return obj;
+   end;
+
+var
+   a: ObjectA;
+   b: ObjectB;
+begin
+   New(a);
+   New(b);
+   b.obj := a;
+   b.GetA.Doit;
+   if not ok then
+     halt(1);
+end.
+

tests/tbs/tb0514.pp

@@ -0,0 +1,29 @@
+{ original: peter5d.pas from the GNU Pascal testsuite }
+
+{$mode macpas}
+program peter5d(output);
+
+        type
+                obj = object
+                        procedure Destroy;
+                        procedure Free;
+                end;
+
+        procedure obj.Destroy;
+        begin
+                dispose( self );
+        end;
+
+        procedure obj.Free;
+        begin
+           writeln('must not be called');
+           halt(1);
+        end;
+
+        var
+                o: obj;
+begin
+        new(o);
+        o.Destroy;
+        WriteLn( 'OK' );
+end.