Merge of revisions 40277

40307
40309
40314
40319
40322
40324
40326
40377
40378 from trunk to fixes_3_2
------------------------------------------------------------------------
r40277 | pierre | 2018-11-08 20:18:30 +0000 (Thu, 08 Nov 2018) | 1 line

 Implement mark_write override for tinilinenode
------------------------------------------------------------------------
--- Merging r40277 into '.':
U    compiler/ninl.pas
--- Recording mergeinfo for merge of r40277 into '.':
 U   .
------------------------------------------------------------------------
r40307 | pierre | 2018-11-13 15:10:21 +0000 (Tue, 13 Nov 2018) | 6 lines

  + Introduce PPC_SUFFIXES, new make variable that lists all ppc suffixes
    for all different CPUs supported.
  * Use PPC_SUFFIXES in execlean and CPU_clean targets.
  * Also delete CPU/bin subbirectory.


------------------------------------------------------------------------
--- Merging r40307 into '.':
U    compiler/Makefile
U    compiler/Makefile.fpc
--- Recording mergeinfo for merge of r40307 into '.':
 G   .
------------------------------------------------------------------------
r40309 | pierre | 2018-11-13 15:51:32 +0000 (Tue, 13 Nov 2018) | 1 line

 Try to avoid expectloc not set after first pass error for call node
------------------------------------------------------------------------
--- Merging r40309 into '.':
U    compiler/ncal.pas
--- Recording mergeinfo for merge of r40309 into '.':
 G   .
------------------------------------------------------------------------
r40314 | pierre | 2018-11-14 13:13:19 +0000 (Wed, 14 Nov 2018) | 4 lines

  * Change first parameter type of function is_continuous_maks to aword type.
    Add typecasts where needed to allow for successful compilation of arm-linux target
    with -CriotR options when building the compiler.

------------------------------------------------------------------------
--- Merging r40314 into '.':
U    compiler/arm/cpubase.pas
U    compiler/arm/cgcpu.pas
--- Recording mergeinfo for merge of r40314 into '.':
 G   .
------------------------------------------------------------------------
r40319 | pierre | 2018-11-15 16:58:40 +0000 (Thu, 15 Nov 2018) | 1 line

 Disable range check in m68k:tiscv32 and riscv64 cgcpu units
------------------------------------------------------------------------
--- Merging r40319 into '.':
   C compiler/riscv64
U    compiler/m68k/cgcpu.pas
   C compiler/riscv32
--- Recording mergeinfo for merge of r40319 into '.':
 G   .
Summary of conflicts:
  Tree conflicts: 2
------------------------------------------------------------------------
r40322 | pierre | 2018-11-15 22:01:25 +0000 (Thu, 15 Nov 2018) | 1 line

 Also disable range checking in arm/aoptcpu unit
------------------------------------------------------------------------
--- Merging r40322 into '.':
U    compiler/arm/aoptcpu.pas
--- Recording mergeinfo for merge of r40322 into '.':
 G   .
------------------------------------------------------------------------
r40324 | pierre | 2018-11-16 10:27:42 +0000 (Fri, 16 Nov 2018) | 4 lines

  * Disable range check for m68k/aoptcpu unit
  * Add missing change of var parameter p to next instruction
    in TryToOptimizeMove method after instruction removal.

------------------------------------------------------------------------
--- Merging r40324 into '.':
U    compiler/m68k/aoptcpu.pas
--- Recording mergeinfo for merge of r40324 into '.':
 G   .
------------------------------------------------------------------------
r40326 | pierre | 2018-11-16 13:28:26 +0000 (Fri, 16 Nov 2018) | 1 line

 Change local variables offsetdec and extraoffset type to ASizeInt
------------------------------------------------------------------------
--- Merging r40326 into '.':
U    compiler/ncgmem.pas
--- Recording mergeinfo for merge of r40326 into '.':
 G   .
------------------------------------------------------------------------
r40377 | pierre | 2018-11-27 10:19:36 +0000 (Tue, 27 Nov 2018) | 1 line

 Fix bug report 34605 and add corresponding test
------------------------------------------------------------------------
--- Merging r40377 into '.':
A    tests/webtbs/tw34605.pp
U    compiler/nutils.pas
--- Recording mergeinfo for merge of r40377 into '.':
 G   .
------------------------------------------------------------------------
r40378 | pierre | 2018-11-27 10:21:37 +0000 (Tue, 27 Nov 2018) | 1 line

 Avoid range errors or overflows on for AVR cpu, when computing address offsets
------------------------------------------------------------------------
--- Merging r40378 into '.':
U    compiler/ncgset.pas
U    compiler/ngtcon.pas
--- Recording mergeinfo for merge of r40378 into '.':
 G   .

git-svn-id: branches/fixes_3_2@40716 -

.gitattributes

@@ -16269,6 +16269,7 @@ tests/webtbs/tw3444.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/Makefile

@@ -4106,6 +4106,7 @@ else
 INSTALLEXEFILE=$(EXENAME)
 endif
 PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 mips mipsel avr jvm i8086 aarch64 sparc64
+PPC_SUFFIXES=386 68k ppc sparc arm armeb x64 ppc64 mips mipsel avr jvm 8086 a64 sparc64
 INSTALL_TARGETS=$(addsuffix _exe_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 SYMLINKINSTALL_TARGETS=$(addsuffix _symlink_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 .PHONY: $(PPC_TARGETS) $(INSTALL_TARGETS)$(SYMLINKINSTALL_TARGETS)
@@ -4143,16 +4144,14 @@ ppuclean:
 tempclean:
 	-$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) pp1.wpo pp2.wpo
 execlean :
-	-$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcsparc64$(EXEEXT)
-	-$(DEL) ppcarm$(EXEEXT) ppcavr$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) ppc8086$(EXEEXT) ppca64$(EXEEXT)
-	-$(DEL) ppcross386$(EXEEXT) ppcross68k$(EXEEXT) ppcrossx64$(EXEEXT) ppcrossppc$(EXEEXT) ppcrosssparc$(EXEEXT) ppcrossppc64$(EXEEXT) ppcrosssparc64$(EXEEXT)
-	-$(DEL) ppcrossarm$(EXEEXT) ppcrossavr$(EXEEXT) ppcrossmips$(EXEEXT) ppcrossmipsel$(EXEEXT) ppcrossjvm$(EXEEXT) ppcross8086$(EXEEXT) ppcrossa64$(EXEEXT)
+	-$(DEL) $(addsuffix $(EXEEXT), $(addprefix ppc, $(PPC_SUFFIXES)))
+	-$(DEL) $(addsuffix $(EXEEXT), $(addprefix ppcross, $(PPC_SUFFIXES)))
 	-$(DEL) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
 $(addsuffix _clean,$(ALLTARGETS)):
 	-$(DELTREE) $(addprefix $(subst _clean,,$@),/units)
+	-$(DELTREE) $(addprefix $(subst _clean,,$@),/bin)
 	-$(DEL) $(addprefix $(subst _clean,,$@)/,*$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT))
-	-$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcarv$(EXEEXT) ppcsparc64$(EXEEXT))
-	-$(DEL) $(addprefix $(subst _clean,,$@)/,ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) ppc8086$(EXEEXT) ppca64$(EXEEXT) $(EXENAME))
+	-$(DEL) $(addprefix $(subst _clean,,$@)/ppc,$(addsuffix $(EXEEXT), $(PPC_SUFFIXES)))
 cycleclean: cleanall $(addsuffix _clean,$(CPC_TARGET))
 	-$(DEL) $(EXENAME)
 clean: tempclean execlean cleanall $(addsuffix _clean,$(CPC_TARGET)) $(addsuffix _clean,$(TARGET_DIRS))

compiler/Makefile.fpc

@@ -433,6 +433,7 @@ endif
 #####################################################################
 
 PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 mips mipsel avr jvm i8086 aarch64 sparc64
+PPC_SUFFIXES=386 68k ppc sparc arm armeb x64 ppc64 mips mipsel avr jvm 8086 a64 sparc64
 INSTALL_TARGETS=$(addsuffix _exe_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 SYMLINKINSTALL_TARGETS=$(addsuffix _symlink_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 
@@ -491,17 +492,15 @@ tempclean:
 	-$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) pp1.wpo pp2.wpo
 
 execlean :
-	-$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcsparc64$(EXEEXT)
-	-$(DEL) ppcarm$(EXEEXT) ppcavr$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) ppc8086$(EXEEXT) ppca64$(EXEEXT)
-	-$(DEL) ppcross386$(EXEEXT) ppcross68k$(EXEEXT) ppcrossx64$(EXEEXT) ppcrossppc$(EXEEXT) ppcrosssparc$(EXEEXT) ppcrossppc64$(EXEEXT) ppcrosssparc64$(EXEEXT)
-	-$(DEL) ppcrossarm$(EXEEXT) ppcrossavr$(EXEEXT) ppcrossmips$(EXEEXT) ppcrossmipsel$(EXEEXT) ppcrossjvm$(EXEEXT) ppcross8086$(EXEEXT) ppcrossa64$(EXEEXT)
+	-$(DEL) $(addsuffix $(EXEEXT), $(addprefix ppc, $(PPC_SUFFIXES)))
+	-$(DEL) $(addsuffix $(EXEEXT), $(addprefix ppcross, $(PPC_SUFFIXES)))
 	-$(DEL) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
 
 $(addsuffix _clean,$(ALLTARGETS)):
         -$(DELTREE) $(addprefix $(subst _clean,,$@),/units)
+        -$(DELTREE) $(addprefix $(subst _clean,,$@),/bin)
         -$(DEL) $(addprefix $(subst _clean,,$@)/,*$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT))
-        -$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcarv$(EXEEXT) ppcsparc64$(EXEEXT))
-        -$(DEL) $(addprefix $(subst _clean,,$@)/,ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) ppc8086$(EXEEXT) ppca64$(EXEEXT) $(EXENAME))
+        -$(DEL) $(addprefix $(subst _clean,,$@)/ppc,$(addsuffix $(EXEEXT), $(PPC_SUFFIXES)))
 
 cycleclean: cleanall $(addsuffix _clean,$(CPC_TARGET))
         -$(DEL) $(EXENAME)

compiler/arm/aoptcpu.pas

@@ -83,6 +83,10 @@ Implementation
     cgobj,procinfo,
     aasmbase,aasmdata;
 
+{ Range check must be disabled explicitly as conversions between signed and unsigned
+  32-bit values are done without explicit typecasts }
+{$R-}
+
   function CanBeCond(p : tai) : boolean;
     begin
       result:=

compiler/arm/cgcpu.pas

@@ -1035,7 +1035,7 @@ unit cgcpu;
             { Doing two shifts instead of two bics might allow the peephole optimizer to fold the second shift
               into the following instruction}
             else if (op = OP_AND) and
-                    is_continuous_mask(a, lsb, width) and
+                    is_continuous_mask(aword(a), lsb, width) and
                     ((lsb = 0) or ((lsb + width) = 32)) then
               begin
                 shifterop_reset(so);
@@ -4620,7 +4620,7 @@ unit cgcpu;
               list.concat(taicpu.op_reg_reg(A_UXTH,dst,src))
             else if (op = OP_AND) and is_thumb32_imm(not(dword(a))) then
               list.concat(taicpu.op_reg_reg_const(A_BIC,dst,src,not(dword(a))))
-            else if (op = OP_AND) and is_continuous_mask(not(a), shift, width) then
+            else if (op = OP_AND) and is_continuous_mask(aword(not(a)), shift, width) then
               begin
                 a_load_reg_reg(list,size,size,src,dst);
                 list.concat(taicpu.op_reg_const_const(A_BFC,dst,shift,width))

compiler/arm/cpubase.pas

@@ -377,7 +377,7 @@ unit cpubase;
       doesn't handle ROR_C detection }
     function is_thumb32_imm(d : aint) : boolean;
     function split_into_shifter_const(value : aint;var imm1: dword; var imm2: dword):boolean;
-    function is_continuous_mask(d : aint;var lsb, width: byte) : boolean;
+    function is_continuous_mask(d : aword;var lsb, width: byte) : boolean;
     function dwarf_reg(r:tregister):shortint;
     function dwarf_reg_no_error(r:tregister):shortint;
 
@@ -610,7 +610,7 @@ unit cpubase;
           end;
       end;
     
-    function is_continuous_mask(d : aint;var lsb, width: byte) : boolean;
+    function is_continuous_mask(d : aword;var lsb, width: byte) : boolean;
       var
         msb : byte;
       begin
@@ -619,7 +619,7 @@ unit cpubase;
         
         width:=msb-lsb+1;
         
-        result:=(lsb<>255) and (msb<>255) and ((((1 shl (msb-lsb+1))-1) shl lsb) = d);
+        result:=(lsb<>255) and (msb<>255) and (aword(((1 shl (msb-lsb+1))-1) shl lsb) = d);
       end;
 
 

compiler/m68k/aoptcpu.pas

@@ -49,6 +49,9 @@ unit aoptcpu;
     uses
       cutils, aasmcpu, cgutils, globals, verbose, cpuinfo, itcpugas;
 
+{ Range check must be disabled explicitly as conversions between signed and unsigned
+  32-bit values are done without explicit typecasts }
+{$R-}
 
     function opname(var p: tai): string;
       begin
@@ -163,8 +166,10 @@ unit aoptcpu;
                     if MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^) then
                       begin
                         DebugMsg('Optimizer: '+opstr+' + '+opstr+' removed',p);
+			GetNextInstruction(p,next);
                         asml.remove(p);
                         p.free;
+			p:=next;
                       end
                     else
                       DebugMsg('Optimizer: '+opstr+' + '+opstr+' to '+opstr+' #1',p)
@@ -266,8 +271,10 @@ unit aoptcpu;
                    (taicpu(p).oper[0]^.ref^.offset = 0) then
                   begin
                     DebugMsg('Optimizer: LEA 0(Ax),Ax removed',p);
+		    GetNextInstruction(p,next);
                     asml.remove(p);
                     p.free;
+		    p:=next;
                     result:=true;
                   end;
               { Address register sub/add can be replaced with ADDQ/SUBQ or LEA if the value is in the

compiler/m68k/cgcpu.pas

@@ -138,6 +138,9 @@ unit cgcpu;
        symsym,symtable,defutil,paramgr,procinfo,
        rgobj,tgobj,rgcpu,fmodule;
 
+{ Range check must be disabled explicitly as conversions between signed and unsigned
+  32-bit values are done without explicit typecasts }
+{$R-}
 
     const
       { opcode table lookup }

compiler/ncal.pas

@@ -1902,18 +1902,27 @@ implementation
       var
         lastinitstatement : tstatementnode;
       begin
+        if not assigned(n) then
+          exit;
         if not assigned(callinitblock) then
-          callinitblock:=internalstatements(lastinitstatement)
-        else
-          lastinitstatement:=laststatement(callinitblock);
+          begin
+            callinitblock:=internalstatements(lastinitstatement);
+            lastinitstatement.left.free;
+            lastinitstatement.left:=n;
+            firstpass(tnode(callinitblock));
+            exit;
+          end;
+        lastinitstatement:=laststatement(callinitblock);
         { all these nodes must be immediately typechecked, because this routine }
         { can be called from pass_1 (i.e., after typecheck has already run) and }
         { moreover, the entire blocks themselves are also only typechecked in   }
         { pass_1, while the the typeinfo is already required after the          }
         { typecheck pass for simplify purposes (not yet perfect, because the    }
         { statementnodes themselves are not typechecked this way)               }
-        firstpass(n);
         addstatement(lastinitstatement,n);
+        firstpass(tnode(lastinitstatement));
+        { Update expectloc for callinitblock }
+        callinitblock.expectloc:=lastinitstatement.expectloc;
       end;
 
 
@@ -1921,13 +1930,22 @@ implementation
       var
         lastdonestatement : tstatementnode;
       begin
+        if not assigned(n) then
+          exit;
         if not assigned(callcleanupblock) then
-          callcleanupblock:=internalstatements(lastdonestatement)
-        else
-          lastdonestatement:=laststatement(callcleanupblock);
+          begin
+            callcleanupblock:=internalstatements(lastdonestatement);
+            lastdonestatement.left.free;
+            lastdonestatement.left:=n;
+            firstpass(tnode(callcleanupblock));
+            exit;
+          end;
+        lastdonestatement:=laststatement(callcleanupblock);
         { see comments in add_init_statement }
-        firstpass(n);
         addstatement(lastdonestatement,n);
+        firstpass(tnode(lastdonestatement));
+        { Update expectloc for callcleanupblock }
+        callcleanupblock.expectloc:=lastdonestatement.expectloc;
       end;
 
 

compiler/ncgmem.pas

@@ -862,7 +862,7 @@ implementation
 
       var
          offsetdec,
-         extraoffset : aint;
+         extraoffset : ASizeInt;
          rightp      : pnode;
          newsize  : tcgsize;
          mulsize,

compiler/ncgset.pas

@@ -234,7 +234,7 @@ implementation
     procedure tcginnode.pass_generate_code;
        var
          adjustment,
-         setbase    : aint;
+         setbase    : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
          l, l2      : tasmlabel;
          hr,
          pleftreg   : tregister;

compiler/ngtcon.pas

@@ -361,7 +361,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
     procedure tasmlisttypedconstbuilder.flush_packed_value(var bp: tbitpackedval);
       var
         bitstowrite: longint;
-        writeval : AInt;
+        writeval : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
       begin
         if (bp.curbitoffset < AIntBits) then
           begin
@@ -403,7 +403,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
     { parses a packed array constant }
     procedure tasmlisttypedconstbuilder.parse_packed_array_def(def: tarraydef);
       var
-        i  : aint;
+        i  : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         bp : tbitpackedval;
       begin
         if not(def.elementdef.typ in [orddef,enumdef]) then
@@ -455,7 +455,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
 
     procedure tasmlisttypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
       var
-        strlength : aint;
+        strlength : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         strval    : pchar;
         ll        : tasmlabofs;
         ca        : pchar;
@@ -1515,11 +1515,11 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
         sorg,s  : TIDString;
         tmpguid : tguid;
         recoffset,
-        fillbytes  : aint;
+        fillbytes  : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         bp   : tbitpackedval;
         error,
         is_packed: boolean;
-        startoffset: aword;
+        startoffset: {$ifdef CPU8BITALU}word{$else}aword{$endif};
 
       procedure handle_stringconstn;
         begin
@@ -1730,10 +1730,10 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
         obj    : tobjectdef;
         srsym  : tsym;
         st     : tsymtable;
-        objoffset : aint;
+        objoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         s,sorg : TIDString;
         vmtwritten : boolean;
-        startoffset:aint;
+        startoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
       begin
         { no support for packed object }
         if is_packed_record_or_object(def) then
@@ -1923,7 +1923,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
         recsym,
         srsym   : tsym;
         sorg,s  : TIDString;
-        recoffset : aint;
+        recoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         error,
         is_packed: boolean;
 
@@ -2092,7 +2092,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
         obj    : tobjectdef;
         srsym  : tsym;
         st     : tsymtable;
-        objoffset : aint;
+        objoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
         s,sorg : TIDString;
       begin
         { no support for packed object }

compiler/ninl.pas

@@ -41,6 +41,7 @@ interface
           function pass_typecheck_cpu:tnode;virtual;
           function simplify(forinline : boolean): tnode;override;
           function docompare(p: tnode): boolean; override;
+          procedure mark_write;override;
 
           { returns a node tree where the inc/dec are replaced by add/sub }
           function getaddsub_for_incdec : tnode;
@@ -4018,6 +4019,16 @@ implementation
       end;
 
 
+    procedure tinlinenode.mark_write;
+      begin
+        case inlinenumber of
+	  in_aligned_x, in_unaligned_x:
+           tcallparanode(left).left.mark_write;
+        else
+          inherited mark_write;
+        end;
+      end;
+
     function tinlinenode.first_pi : tnode;
       begin
         result:=crealconstnode.create(getpi,pbestrealtype^);

compiler/nutils.pas

@@ -570,21 +570,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:=
@@ -627,14 +638,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.
+