From 044fae62eae19e567f5317bf90b01f2d75fc517e Mon Sep 17 00:00:00 2001 From: pierre Date: Tue, 27 Nov 2018 10:19:36 +0000 Subject: [PATCH] Fix bug report 34605 and add corresponding test git-svn-id: trunk@40377 - --- .gitattributes | 1 + compiler/nutils.pas | 27 +++++--- tests/webtbs/tw34605.pp | 136 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 156 insertions(+), 8 deletions(-) create mode 100644 tests/webtbs/tw34605.pp diff --git a/.gitattributes b/.gitattributes index a156737ab3..4c90e7485e 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/nutils.pas b/compiler/nutils.pas index 8c643259be..fff2bdf17c 100644 --- a/compiler/nutils.pas +++ b/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 diff --git a/tests/webtbs/tw34605.pp b/tests/webtbs/tw34605.pp new file mode 100644 index 0000000000..d8775fb52d --- /dev/null +++ b/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. +