mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 04:29:42 +02:00
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 -
This commit is contained in:
pierre
parent
4873692ce5
commit
92cd9502ef
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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:=
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -862,7 +862,7 @@ implementation
|
||||
|
||||
var
|
||||
offsetdec,
|
||||
extraoffset : aint;
|
||||
extraoffset : ASizeInt;
|
||||
rightp : pnode;
|
||||
newsize : tcgsize;
|
||||
mulsize,
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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^);
|
||||
|
||||
@ -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
|
||||
|
||||
136
tests/webtbs/tw34605.pp
Normal file
136
tests/webtbs/tw34605.pp
Normal file
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user