paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 07:28:26 +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

177
compiler/pexpr.pas
View File

@ -1005,7 +1005,7 @@ implementation
end;
{ only need to get the address of the procedure? Check token because
in the case of opening parenthesis is possible to get pointer to
in the case of opening parenthesis is possible to get pointer to
function result (lack of checking for token was the reason of
tw10933.pp test failure) }
if getaddr and (token<>_LKLAMMER) then
@ -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,53 +3534,71 @@ 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
useself:=false;
if is_objectpascal_helper(current_structdef) then
{ typesym is only a valid choice if we're dealing
with a potential generic }
if (srsym.typ=typesym) and not mightbegeneric then
begin
{ for a helper load the procdef either from the
extended type, from the parent helper or from
the extended type of the parent helper
depending on the def the found symbol belongs
to }
if (srsym.Owner.defowner.typ=objectdef) and
is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then
if def_is_related(current_structdef,tdef(srsym.Owner.defowner)) and
assigned(tobjectdef(current_structdef).childof) then
hdef:=tobjectdef(current_structdef).childof
else
begin
hdef:=tobjectdef(srsym.Owner.defowner).extendeddef;
useself:=true;
end
Message(parser_e_methode_id_expected);
p1:=cerrornode.create;
end
else
begin
useself:=false;
if is_objectpascal_helper(current_structdef) then
begin
{ for a helper load the procdef either from the
extended type, from the parent helper or from
the extended type of the parent helper
depending on the def the found symbol belongs
to }
if (srsym.Owner.defowner.typ=objectdef) and
is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then
if def_is_related(current_structdef,tdef(srsym.Owner.defowner)) and
assigned(tobjectdef(current_structdef).childof) then
hdef:=tobjectdef(current_structdef).childof
else
begin
hdef:=tobjectdef(srsym.Owner.defowner).extendeddef;
useself:=true;
end
else
begin
hdef:=tdef(srsym.Owner.defowner);
useself:=true;
end;
end
else
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=cclassrefdef.create(hdef);
if useself then
begin
p1:=ctypeconvnode.create_internal(load_self_node,hdef);
end
else
begin
hdef:=tdef(srsym.Owner.defowner);
useself:=true;
p1:=ctypenode.create(hdef);
{ we need to allow helpers here }
ttypenode(p1).helperallowed:=true;
end;
end
else
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=cclassrefdef.create(hdef);
if useself then
begin
p1:=ctypeconvnode.create_internal(load_self_node,hdef);
end
else
begin
p1:=ctypenode.create(hdef);
{ we need to allow helpers here }
ttypenode(p1).helperallowed:=true;
end;
end;
propertysym:
@ -3574,11 +3609,22 @@ implementation
p1:=cerrornode.create;
end;
end;
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);
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,spezcontext);
end;
if p1.nodetype=errorn then
spezcontext.free;
end
else
begin
@ -3622,7 +3668,8 @@ implementation
again:=false;
p1:=cerrornode.create;
end;
postfixoperators(p1,again,getaddr);
if p1.nodetype<>specializen then
postfixoperators(p1,again,getaddr);
end;
_INTCONST :
@ -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,21 +4155,31 @@ implementation
begin
result:=pload;
typecheckpass(result);
structdef:=nil;
case result.resultdef.typ of
objectdef,
recorddef:
begin
structdef:=tabstractrecorddef(result.resultdef);
end;
classrefdef:
begin
structdef:=tabstractrecorddef(tclassrefdef(result.resultdef).pointeddef);
end;
else
internalerror(2015092703);
end;
do_member_read(structdef,getaddr,gensym,result,again,[],spezcontext);
structdef:=inheriteddef;
if not assigned(structdef) then
case result.resultdef.typ of
objectdef,
recorddef:
begin
structdef:=tabstractrecorddef(result.resultdef);
end;
classrefdef:
begin
structdef:=tabstractrecorddef(tclassrefdef(result.resultdef).pointeddef);
end;
else
internalerror(2015092703);
end;
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.