paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-23 06:49:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r39785 into '.':

Browse Source 
U    packages/fcl-stl/src/gset.pp
--- Recording mergeinfo for merge of r39785 into '.':
 U   .
--- Merging r39786 into '.':
A    tests/tbs/tb0651.pp
U    compiler/symdef.pas
--- Recording mergeinfo for merge of r39786 into '.':
 G   .
--- Merging r39787 into '.':
U    compiler/pexpr.pas
A    tests/webtbs/uw34287a.pp
A    tests/webtbs/tw34287.pp
A    tests/webtbs/uw34287b.pp
--- Recording mergeinfo for merge of r39787 into '.':
 G   .
--- Merging r39788 into '.':
U    compiler/nbas.pas
--- Recording mergeinfo for merge of r39788 into '.':
 G   .
--- Merging r39812 into '.':
G    compiler/pexpr.pas
--- Recording mergeinfo for merge of r39812 into '.':
 G   .

# revisions: 39785,39786,39787,39788,39812

git-svn-id: branches/fixes_3_2@39835 -
This commit is contained in:
marco 2018-09-27 13:01:08 +00:00
parent 2b01261f36
commit 338873d7a7
9 changed files with 290 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -11597,6 +11597,7 @@ tests/tbs/tb0646b.pp svneol=native#text/pascal
tests/tbs/tb0648.pp svneol=native#text/pascal
tests/tbs/tb0649.pp -text svneol=native#text/pascal
tests/tbs/tb0650.pp svneol=native#text/pascal
tests/tbs/tb0651.pp svneol=native#text/pascal
tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/tb610.pp svneol=native#text/pascal
tests/tbs/tb613.pp svneol=native#text/plain
@ -16248,6 +16249,7 @@ tests/webtbs/tw34124.pp svneol=native#text/pascal
tests/webtbs/tw3418.pp svneol=native#text/plain
tests/webtbs/tw3423.pp svneol=native#text/plain
tests/webtbs/tw34239.pp svneol=native#text/pascal
tests/webtbs/tw34287.pp svneol=native#text/pascal
tests/webtbs/tw3429.pp svneol=native#text/plain
tests/webtbs/tw3433.pp svneol=native#text/plain
tests/webtbs/tw3435.pp svneol=native#text/plain
@ -16858,6 +16860,8 @@ tests/webtbs/uw3340.pp svneol=native#text/plain
tests/webtbs/uw3353.pp svneol=native#text/plain
tests/webtbs/uw3356.pp svneol=native#text/plain
tests/webtbs/uw33839.pp -text svneol=native#text/pascal
tests/webtbs/uw34287a.pp svneol=native#text/pascal
tests/webtbs/uw34287b.pp svneol=native#text/pascal
tests/webtbs/uw3429.pp svneol=native#text/plain
tests/webtbs/uw3474a.pp svneol=native#text/plain
tests/webtbs/uw3474b.pp svneol=native#text/plain

8
compiler/nbas.pas
View File

@ -51,7 +51,9 @@ interface
tspecializenode = class(tunarynode)
sym:tsym;
getaddr:boolean;
inheriteddef:tdef;
constructor create(l:tnode;g:boolean;s:tsym);virtual;
constructor create_inherited(l:tnode;g:boolean;s:tsym;i:tdef);virtual;
function pass_1:tnode;override;
function pass_typecheck:tnode;override;
end;
@ -430,6 +432,12 @@ implementation
getaddr:=g;
end;
constructor tspecializenode.create_inherited(l:tnode;g:boolean;s:tsym;i:tdef);
begin
create(l,g,s);
inheriteddef:=i;
end;
function tspecializenode.pass_typecheck:tnode;
begin

71
compiler/pexpr.pas
View File

@ -3362,6 +3362,9 @@ implementation
filepos : tfileposinfo;
callflags : tcallnodeflags;
idstr : tidstring;
spezcontext : tspecializationcontext;
isspecialize,
mightbegeneric,
useself,
dopostfix,
again,
@ -3376,6 +3379,7 @@ implementation
filepos:=current_tokenpos;
again:=false;
pd:=nil;
isspecialize:=false;
if token=_ID then
begin
again:=true;
@ -3483,6 +3487,7 @@ implementation
hclassdef:=java_fpcbaserecordtype
else
internalerror(2012012401);
spezcontext:=nil;
{ if inherited; only then we need the method with
the same name }
if token <> _ID then
@ -3508,6 +3513,18 @@ implementation
end
else
begin
if not (m_delphi in current_settings.modeswitches) and
(block_type in inline_specialization_block_types) and
(token=_ID) and
(idtoken=_SPECIALIZE) then
begin
consume(_ID);
if token<>_ID then
message(parser_e_methode_id_expected);
isspecialize:=true;
end
else
isspecialize:=false;
hs:=pattern;
hsorg:=orgpattern;
consume(_ID);
@ -3517,14 +3534,31 @@ implementation
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,[ssf_has_inherited])
else
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
if isspecialize and assigned(srsym) then
begin
if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
srsym:=nil;
end;
end;
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
mightbegeneric:=(m_delphi in current_settings.modeswitches) and
(token in [_LT,_LSHARPBRACKET]) and
(sp_generic_dummy in srsym.symoptions);
{ load the procdef from the inherited class and
not from self }
case srsym.typ of
typesym,
procsym:
begin
{ typesym is only a valid choice if we're dealing
with a potential generic }
if (srsym.typ=typesym) and not mightbegeneric then
begin
Message(parser_e_methode_id_expected);
p1:=cerrornode.create;
end
else
begin
useself:=false;
if is_objectpascal_helper(current_structdef) then
@ -3566,6 +3600,7 @@ implementation
ttypenode(p1).helperallowed:=true;
end;
end;
end;
propertysym:
;
else
@ -3574,11 +3609,22 @@ implementation
p1:=cerrornode.create;
end;
end;
if mightbegeneric then
begin
p1:=cspecializenode.create_inherited(p1,getaddr,srsym,hclassdef);
end
else
begin
if not isspecialize then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
callflags:=[cnf_inherited];
include(current_procinfo.flags,pi_has_inherited);
if anon_inherited then
include(callflags,cnf_anon_inherited);
do_member_read(hclassdef,getaddr,srsym,p1,again,callflags,nil);
do_member_read(hclassdef,getaddr,srsym,p1,again,callflags,spezcontext);
end;
if p1.nodetype=errorn then
spezcontext.free;
end
else
begin
@ -3622,6 +3668,7 @@ implementation
again:=false;
p1:=cerrornode.create;
end;
if p1.nodetype<>specializen then
postfixoperators(p1,again,getaddr);
end;
@ -4045,18 +4092,22 @@ implementation
getaddr : boolean;
pload : tnode;
spezcontext : tspecializationcontext;
structdef : tabstractrecorddef;
structdef,
inheriteddef : tabstractrecorddef;
callflags : tcallnodeflags;
begin
if n.nodetype=specializen then
begin
getaddr:=tspecializenode(n).getaddr;
pload:=tspecializenode(n).left;
inheriteddef:=tabstractrecorddef(tspecializenode(n).inheriteddef);
tspecializenode(n).left:=nil;
end
else
begin
getaddr:=false;
pload:=nil;
inheriteddef:=nil;
end;
if assigned(parseddef) and assigned(gensym) and assigned(p2) then
@ -4104,7 +4155,8 @@ implementation
begin
result:=pload;
typecheckpass(result);
structdef:=nil;
structdef:=inheriteddef;
if not assigned(structdef) then
case result.resultdef.typ of
objectdef,
recorddef:
@ -4118,7 +4170,16 @@ implementation
else
internalerror(2015092703);
end;
do_member_read(structdef,getaddr,gensym,result,again,[],spezcontext);
if not (structdef.typ in [recorddef,objectdef]) then
internalerror(2018092101);
if assigned(inheriteddef) then
begin
callflags:=[cnf_inherited];
include(current_procinfo.flags,pi_has_inherited);
end
else
callflags:=[];
do_member_read(structdef,getaddr,gensym,result,again,callflags,spezcontext);
spezcontext:=nil;
end
else

8
compiler/symdef.pas
View File

@ -2913,8 +2913,12 @@ implementation
(high > (system.high(int64) div 2)))) then
{$endif cpu64bitalu}
result := 64
else if (low >= 0) and
(high <= 1) then
else if (
(low >= 0) and
(high <= 1)
) or (
ordtype in [pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]
) then
result := 1
else
begin

4
packages/fcl-stl/src/gset.pp
View File

@ -53,7 +53,7 @@ type
function RotateLeft(nod:PNode):PNode;inline;
procedure FlipColors(nod:PNode);inline;
function IsRed(nod:PNode):boolean;inline;
function Insert(value:T; nod:PNode; var position:PNode):PNode;
function Insert(value:T; nod:PNode; out position:PNode):PNode;
function FixUp(nod:PNode):PNode;inline;
function MoveRedLeft(nod:PNode):PNode;inline;
function MoveRedRight(nod:PNode):PNode;inline;
@ -413,7 +413,7 @@ begin
InsertAndGetIterator := ret;
end;
function TSet.Insert(value:T; nod:PNode; var position:PNode):PNode;
function TSet.Insert(value:T; nod:PNode; out position:PNode):PNode;
begin
if(nod=nil) then begin
nod:=CreateNode(value);

55
tests/tbs/tb0651.pp Normal file
View File

@ -0,0 +1,55 @@
program tb0651;
{$mode objfpc}{$H+}
type
TBooleanArray = array[0..7] of Boolean;
TBooleanByte = bitpacked array[0..7] of Boolean;
TBoolean16Byte = bitpacked array[0..7] of Boolean16;
TBoolean32Byte = bitpacked array[0..7] of Boolean32;
TBoolean64Byte = bitpacked array[0..7] of Boolean64;
TByteBoolByte = bitpacked array[0..7] of ByteBool;
TWordBoolByte = bitpacked array[0..7] of WordBool;
TLongBoolByte = bitpacked array[0..7] of LongBool;
TQWordBoolByte = bitpacked array[0..7] of QWordBool;
generic procedure CheckValue<T>(aArr: T; const aExpected: TBooleanArray; aCode: LongInt);
var
i: LongInt;
begin
if SizeOf(T) <> 1 then
Halt(aCode * 10 + 1);
if BitSizeOf(T) <> 8 then
Halt(aCode * 10 + 2);
for i := 0 to High(aArr) do
if aArr[i] <> aExpected[i] then
Halt(aCode * 10 + 3 + i);
end;
var
exp: TBooleanArray = (True, False, True, False, False, True, False, True);
b: Byte = $A5;
pb8: TBooleanByte absolute b;
pb16: TBoolean16Byte absolute b;
pb32: TBoolean32Byte absolute b;
pb64: TBoolean64Byte absolute b;
bb8: TByteBoolByte absolute b;
bb16: TWordBoolByte absolute b;
bb32: TLongBoolByte absolute b;
bb64: TQWordBoolByte absolute b;
begin
specialize CheckValue<TBooleanByte>(pb8, exp, 0);
specialize CheckValue<TBoolean16Byte>(pb16, exp, 1);
specialize CheckValue<TBoolean32Byte>(pb32, exp, 2);
{$ifdef CPU64}
specialize CheckValue<TBoolean64Byte>(pb64, exp, 3);
{$endif}
specialize CheckValue<TByteBoolByte>(bb8, exp, 4);
specialize CheckValue<TWordBoolByte>(bb16, exp, 5);
specialize CheckValue<TLongBoolByte>(bb32, exp, 6);
{$ifdef CPU64}
specialize CheckValue<TQWordBoolByte>(bb64, exp, 7);
{$endif}
Writeln('ok');
end.

22
tests/webtbs/tw34287.pp Normal file
View File

@ -0,0 +1,22 @@
{ %NORUN }
program tw34287;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
uses
Classes,
uw34287a,
uw34287b;
var
fooa: uw34287a.TFoo;
foob: uw34287b.TFoo;
begin
fooa := uw34287a.TFoo.Create(nil);
fooa.Bar('');
foob := uw34287b.TFoo.Create(nil);
foob.Bar('');
end.

37
tests/webtbs/uw34287a.pp Normal file
View File

@ -0,0 +1,37 @@
unit uw34287a;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface
uses
Classes;
type
TBase = class(TComponent)
public
function Bar<T: TComponent>(const P1: string; out P2: T): Boolean;
end;
TFoo = class(TBase)
public
function Bar(const P1: string): Boolean;
end;
implementation
function TBase.Bar<T>(const P1: string; out P2: T): Boolean;
begin
Result := False;
end;
function TFoo.Bar(const P1: string): Boolean;
var
C: TComponent;
begin
Result := inherited Bar<TComponent>(P1, C);
end;
end.

37
tests/webtbs/uw34287b.pp Normal file
View File

@ -0,0 +1,37 @@
unit uw34287b;
{$IFDEF FPC}
{$MODE OBJFPC}{$H+}
{$ENDIF}
interface
uses
Classes;
type
TBase = class(TComponent)
public
generic function Bar<T: TComponent>(const P1: string; out P2: T): Boolean;
end;
TFoo = class(TBase)
public
function Bar(const P1: string): Boolean;
end;
implementation
generic function TBase.Bar<T>(const P1: string; out P2: T): Boolean;
begin
Result := False;
end;
function TFoo.Bar(const P1: string): Boolean;
var
C: TComponent;
begin
Result := inherited specialize Bar<TComponent>(P1, C);
end;
end.