From 338873d7a7835e0db2ee4ae6813bd1c03cb3c114 Mon Sep 17 00:00:00 2001 From: marco Date: Thu, 27 Sep 2018 13:01:08 +0000 Subject: [PATCH] --- Merging r39785 into '.': 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 - --- .gitattributes | 4 + compiler/nbas.pas | 8 ++ compiler/pexpr.pas | 177 +++++++++++++++++++++++------------ compiler/symdef.pas | 8 +- packages/fcl-stl/src/gset.pp | 4 +- tests/tbs/tb0651.pp | 55 +++++++++++ tests/webtbs/tw34287.pp | 22 +++++ tests/webtbs/uw34287a.pp | 37 ++++++++ tests/webtbs/uw34287b.pp | 37 ++++++++ 9 files changed, 290 insertions(+), 62 deletions(-) create mode 100644 tests/tbs/tb0651.pp create mode 100644 tests/webtbs/tw34287.pp create mode 100644 tests/webtbs/uw34287a.pp create mode 100644 tests/webtbs/uw34287b.pp diff --git a/.gitattributes b/.gitattributes index c50acd19f0..54cb48c4fd 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/compiler/nbas.pas b/compiler/nbas.pas index 3aec54cb72..1e9ab45043 100644 --- a/compiler/nbas.pas +++ b/compiler/nbas.pas @@ -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 diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 9594141762..56374d89ef 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -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 diff --git a/compiler/symdef.pas b/compiler/symdef.pas index c146f3336f..cdc8568ce1 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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 diff --git a/packages/fcl-stl/src/gset.pp b/packages/fcl-stl/src/gset.pp index a4f49acdb8..34124013b8 100644 --- a/packages/fcl-stl/src/gset.pp +++ b/packages/fcl-stl/src/gset.pp @@ -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); diff --git a/tests/tbs/tb0651.pp b/tests/tbs/tb0651.pp new file mode 100644 index 0000000000..62cb493770 --- /dev/null +++ b/tests/tbs/tb0651.pp @@ -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(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(pb8, exp, 0); + specialize CheckValue(pb16, exp, 1); + specialize CheckValue(pb32, exp, 2); +{$ifdef CPU64} + specialize CheckValue(pb64, exp, 3); +{$endif} + specialize CheckValue(bb8, exp, 4); + specialize CheckValue(bb16, exp, 5); + specialize CheckValue(bb32, exp, 6); +{$ifdef CPU64} + specialize CheckValue(bb64, exp, 7); +{$endif} + Writeln('ok'); +end. diff --git a/tests/webtbs/tw34287.pp b/tests/webtbs/tw34287.pp new file mode 100644 index 0000000000..7b7387a9c5 --- /dev/null +++ b/tests/webtbs/tw34287.pp @@ -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. diff --git a/tests/webtbs/uw34287a.pp b/tests/webtbs/uw34287a.pp new file mode 100644 index 0000000000..a90f5ef612 --- /dev/null +++ b/tests/webtbs/uw34287a.pp @@ -0,0 +1,37 @@ +unit uw34287a; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +interface + +uses + Classes; + +type + TBase = class(TComponent) + public + function Bar(const P1: string; out P2: T): Boolean; + end; + + TFoo = class(TBase) + public + function Bar(const P1: string): Boolean; + end; + +implementation + +function TBase.Bar(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(P1, C); +end; + +end. diff --git a/tests/webtbs/uw34287b.pp b/tests/webtbs/uw34287b.pp new file mode 100644 index 0000000000..78c86c19ac --- /dev/null +++ b/tests/webtbs/uw34287b.pp @@ -0,0 +1,37 @@ +unit uw34287b; + +{$IFDEF FPC} + {$MODE OBJFPC}{$H+} +{$ENDIF} + +interface + +uses + Classes; + +type + TBase = class(TComponent) + public + generic function Bar(const P1: string; out P2: T): Boolean; + end; + + TFoo = class(TBase) + public + function Bar(const P1: string): Boolean; + end; + +implementation + +generic function TBase.Bar(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(P1, C); +end; + +end.