diff --git a/.gitattributes b/.gitattributes index 32568a2d30..fa90ab925f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -15833,6 +15833,7 @@ tests/test/tthlp26b.pp -text svneol=native#text/pascal tests/test/tthlp26c.pp -text svneol=native#text/pascal tests/test/tthlp27.pp svneol=native#text/pascal tests/test/tthlp28.pp svneol=native#text/pascal +tests/test/tthlp29.pp svneol=native#text/pascal tests/test/tthlp3.pp svneol=native#text/pascal tests/test/tthlp4.pp svneol=native#text/pascal tests/test/tthlp5.pp svneol=native#text/pascal @@ -18589,6 +18590,7 @@ tests/webtbs/tw38058.pp svneol=native#text/pascal tests/webtbs/tw38069.pp svneol=native#text/pascal tests/webtbs/tw38074.pp svneol=native#text/pascal tests/webtbs/tw38083.pp svneol=native#text/pascal +tests/webtbs/tw38122.pp svneol=native#text/pascal tests/webtbs/tw3814.pp svneol=native#text/plain tests/webtbs/tw3827.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain diff --git a/compiler/ncal.pas b/compiler/ncal.pas index cc22ac8e70..55bf423f57 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -3578,7 +3578,7 @@ implementation var candidates : tcallcandidates; oldcallnode : tcallnode; - hpt : tnode; + hpt,tmp : tnode; pt : tcallparanode; lastpara : longint; paraidx, @@ -4004,6 +4004,19 @@ implementation e.g. class reference types account } hpt:=actualtargetnode(@hpt)^; + { if the value a type helper works on is a derefentiation we need to + pass the original pointer as Self as the Self value might be + changed by the helper } + if is_objectpascal_helper(tdef(procdefinition.owner.defowner)) and + not is_implicit_pointer_object_type(tobjectdef(procdefinition.owner.defowner).extendeddef) and + (hpt.nodetype=derefn) then + begin + tmp:=tderefnode(hpt).left; + tderefnode(hpt).left:=nil; + methodpointer.free; + methodpointer:=tmp; + end; + { R.Init then R will be initialized by the constructor, Also allow it for simple loads } if (procdefinition.proctypeoption=potype_constructor) or diff --git a/tests/test/tthlp29.pp b/tests/test/tthlp29.pp new file mode 100644 index 0000000000..0572573d8f --- /dev/null +++ b/tests/test/tthlp29.pp @@ -0,0 +1,76 @@ +program tthlp29; + +{$mode objfpc} +{$modeswitch typehelpers} +{$APPTYPE CONSOLE} + +type + TLongIntHelper = type helper for LongInt + procedure Test; + end; + +procedure TLongIntHelper.Test; +begin + Self := Self + 10; +end; + +var + l: LongInt; + pl: PLongInt; + pul: PLongWord; + pb: PByte; + +function GetPL: PLongInt; +begin + Result := @l; +end; + +function GetPUL: PLongWord; +begin + Result := @l; +end; + +function GetPB: PByte; +begin + Result := @l; +end; + +begin + l := 0; + pl := @l; + pul := @l; + pb := @l; + Writeln(l); + l.Test; + Writeln(l); + if l <> 10 then + Halt(1); + pl^.Test; + Writeln(l); + if l <> 20 then + Halt(2); + GetPL^.Test; + Writeln(l); + if l <> 30 then + Halt(3); + { type conversions with the same size are ignored } + LongInt(pul^).Test; + Writeln(l); + if l <> 40 then + Halt(4); + LongInt(GetPUL^).Test; + Writeln(l); + if l <> 50 then + Halt(5); + { type conversions with different sizes operate on a tmp } + LongInt(pb^).Test; + Writeln(l); + if l <> 50 then + Halt(6); + LongInt(GetPB^).Test; + Writeln(l); + if l <> 50 then + Halt(7); + Writeln('ok'); +end. + diff --git a/tests/webtbs/tw38122.pp b/tests/webtbs/tw38122.pp new file mode 100644 index 0000000000..edfbd154b6 --- /dev/null +++ b/tests/webtbs/tw38122.pp @@ -0,0 +1,81 @@ +program tw38122; + +{$mode objfpc} +{$modeswitch advancedrecords} +{$modeswitch typehelpers} + +uses + Math; + +type float = double; + pfloat = ^float; + +type TFloatHelper = type helper for float + procedure sub (const a: float); + end; + +type TMatrix = record + sx,sy: sizeint; + procedure Init (x,y: sizeint; content: array of float); + function GetAdr (x,y: sizeint): pfloat; + procedure print; + private + data: array of float; + end; + +procedure TFloatHelper.sub (const a: float); +begin + self := self-a; +end; + +function TMatrix.GetAdr (x,y: sizeint): pfloat; +begin + result := @data[x*sy+y]; +end; + +procedure TMatrix.Init (x,y: sizeint; content: array of float); +var i: sizeint; +begin + sx :=x; + sy :=y; + Data := nil; + SetLength (data, sx*sy); + for i := 0 to sx*sy-1 do data[i] := content[i]; +end; + +procedure TMatrix.print; +var x,y: sizeint; +begin + for y := 0 to sy-1 do begin + writeln; + for x := 0 to sx-1 do begin + write (GetAdr(x,y)^:2:2,' '); + end; + end; + writeln; +end; + +var A: TMatrix; + px: pfloat; +begin + A.Init (2,2,[1,2,3,4]); + A.print; + if not SameValue(A.data[3],4,1e-1) then + Halt(1); + + A.GetAdr(1,1)^ := 0; //I can set an element like this... + A.Print; + if not SameValue(A.data[3],0,1e-1) then + Halt(2); + + px := A.GetAdr(1,1); + px^.sub(100); //and this works as well. + A.Print; + if not SameValue(A.data[3],-100,1e-1) then + Halt(3); + + A.GetAdr(1,1)^.sub(1000); //but that does not change the Matrix !?! + A.print; + if not SameValue(A.data[3],-1100,1e-1) then + Halt(4); +end.