Fix bug report 34605 and add corresponding test

git-svn-id: trunk@40377 -

.gitattributes

@@ -16424,6 +16424,7 @@ tests/webtbs/tw34442.pp svneol=native#text/plain
 tests/webtbs/tw3456.pp svneol=native#text/plain
 tests/webtbs/tw3457.pp svneol=native#text/plain
 tests/webtbs/tw3460.pp svneol=native#text/plain
+tests/webtbs/tw34605.pp svneol=native#text/plain
 tests/webtbs/tw3467.pp svneol=native#text/plain
 tests/webtbs/tw3470.pp svneol=native#text/plain
 tests/webtbs/tw3474.pp svneol=native#text/plain

compiler/nutils.pas

@@ -582,21 +582,32 @@ implementation
         obj_def: tobjectdef;
         self_temp,
         vmt_temp: ttempcreatenode;
-        check_self: tnode;
+        check_self,n: tnode;
         stat: tstatementnode;
         block: tblocknode;
         paras: tcallparanode;
-        docheck: boolean;
+        docheck,is_typecasted_classref: boolean;
       begin
         self_resultdef:=self_node.resultdef;
         case self_resultdef.typ of
           classrefdef:
-            obj_def:=tobjectdef(tclassrefdef(self_resultdef).pointeddef);
+            begin
+              obj_def:=tobjectdef(tclassrefdef(self_resultdef).pointeddef);
+            end;
           objectdef:
             obj_def:=tobjectdef(self_resultdef);
           else
             internalerror(2015052701);
         end;
+        n:=self_node;
+        is_typecasted_classref:=false;
+	if (n.nodetype=typeconvn) then
+          begin
+            while assigned(n) and (n.nodetype=typeconvn) and (nf_explicit in ttypeconvnode(n).flags) do
+              n:=ttypeconvnode(n).left;
+            if assigned(n) and (n.resultdef.typ=classrefdef) then
+              is_typecasted_classref:=true;
+	  end;
         if is_classhelper(obj_def) then
           obj_def:=tobjectdef(tobjectdef(obj_def).extendeddef);
         docheck:=
@@ -639,14 +650,14 @@ implementation
             addstatement(stat,ctempdeletenode.create_normal_temp(self_temp));
             self_node:=ctemprefnode.create(self_temp);
           end;
-        { get the VMT field in case of a class/object }
-        if (self_resultdef.typ=objectdef) and
-           assigned(tobjectdef(self_resultdef).vmt_field) then
-          result:=csubscriptnode.create(tobjectdef(self_resultdef).vmt_field,self_node)
         { in case of a classref, the "instance" is a pointer
           to pointer to a VMT and there is no vmt field }
-        else if self_resultdef.typ=classrefdef then
+        if is_typecasted_classref or (self_resultdef.typ=classrefdef) then
           result:=self_node
+        { get the VMT field in case of a class/object }
+        else if (self_resultdef.typ=objectdef) and
+           assigned(tobjectdef(self_resultdef).vmt_field) then
+          result:=csubscriptnode.create(tobjectdef(self_resultdef).vmt_field,self_node)
         { in case of an interface, the "instance" is a pointer to a pointer
           to a VMT -> dereference once already }
         else

tests/webtbs/tw34605.pp

@@ -0,0 +1,136 @@
+{%OPT=-CR}
+
+{ This test checks that correct code is generated
+  when typecasting a class reference type variable with a descendent class }
+
+{$mode objfpc}
+
+uses
+  sysutils;
+
+type
+
+  TBaseClass = class
+   constructor Create;
+   class var  x : longint;
+   var loc : longint;
+   class procedure check; virtual;
+  end;
+
+  TDerClass = class(TBaseClass)
+   var der : longint;
+  end;
+
+  TDer1Class = class(TDerClass)
+   constructor Create;
+   class var y : longint;
+   var loc1 : longint;
+   class procedure check; override;
+  end;
+
+  TDer2Class = class(TDerClass)
+   constructor Create;
+   class var z : longint;
+   var loc2 : longint;
+   class procedure check; override;
+  end;
+
+constructor TBaseClass.Create;
+  begin
+    Inherited Create;
+    x:=1;
+  end;
+
+constructor TDer1Class.Create;
+  begin
+    Inherited Create;
+    y:=1;
+  end;
+
+constructor TDer2Class.Create;
+  begin
+    Inherited Create;
+    z:=1;
+  end;
+
+class procedure TBaseClass.check;
+begin
+  writeln('TBaseClass.check called');
+end;
+
+class procedure TDer1Class.check;
+begin
+  writeln('TDer1Class.check called');
+end;
+
+class procedure TDer2Class.check;
+begin
+  writeln('TDer2Class.check called');
+end;
+
+type
+  TBaseClassRef = class of TBaseClass;
+  TDerClassRef = class of TDerClass;
+
+var
+  c : TBaseClass;
+  cc : TBaseClassRef;
+  dcc : TDerClassRef;
+  exception_generated : boolean;
+
+begin
+  exception_generated:=false;
+  c:=TBaseClass.Create;
+
+  inc(c.x);
+  c.check;
+  c.free;
+
+  c:=TDer1Class.Create;
+
+  inc(c.x);
+  inc(TDer1Class(c).y);
+  c.check;
+  c.free;
+
+  c:=TDer2Class.Create;
+  inc(c.x);
+  inc(TDer2Class(c).z);
+  c.check;
+  c.free;
+
+  cc:=TbaseClass;
+  inc(cc.x);
+  cc.check;
+
+  cc:=TDer1Class;
+  inc(cc.x);
+  cc.check;
+
+
+  cc:=TDer2Class;
+  inc(cc.x);
+  cc.check;
+  TDerClassRef(cc).check;
+  TDerClass(cc).check;
+
+  dcc:=TDerClass;
+  dcc.check;
+
+  try
+    //inc (TDer1Class(cc).y);
+    TDer1Class(cc).check;
+  except
+    writeln('Exception generated');
+    exception_generated:=true;
+  end;
+  writeln('TBaseClass: x=',TBaseClass.x);
+  writeln('TDer1Class: x=',TDer1Class.x,', y=',TDer1Class.y);
+  writeln('TDer2Class: x=',TDer2Class.x,', z=',TDer2Class.z);
+  if not exception_generated then
+    begin
+      writeln('No exception generated on wrong typecast of class reference variable');
+      halt(1);
+    end;
+end.
+