From 3482121831a899c3acf0a8f2d0e2d8e401a2eda5 Mon Sep 17 00:00:00 2001 From: florian Date: Thu, 31 Dec 2020 15:33:39 +0000 Subject: [PATCH 1/6] * patch by Christo Crause: Fix missed optimization opportunities, resolves #38285 git-svn-id: trunk@47925 - --- compiler/avr/aoptcpu.pas | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/avr/aoptcpu.pas b/compiler/avr/aoptcpu.pas index b64a27df71..031633d92f 100644 --- a/compiler/avr/aoptcpu.pas +++ b/compiler/avr/aoptcpu.pas @@ -423,7 +423,7 @@ Implementation DebugMsg('Peephole LdiOp2Opi performed', p); - RemoveCurrentP(p); + result:=RemoveCurrentP(p); end; end; end; @@ -447,6 +447,7 @@ Implementation taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset) else taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset-32); + result:=true; end; A_LDS: if (taicpu(p).oper[1]^.ref^.symbol=nil) and @@ -468,6 +469,8 @@ Implementation taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset) else taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset-32); + + result:=true; end; A_IN: if GetNextInstruction(p,hp1) then From b4a6c22234aeb9982a3d27ca0c37e0f2b7963958 Mon Sep 17 00:00:00 2001 From: florian Date: Thu, 31 Dec 2020 15:52:02 +0000 Subject: [PATCH 2/6] * do not check inlined exit nodes for unset results, resolves #38259 git-svn-id: trunk@47926 - --- compiler/optdfa.pas | 7 +++++-- tests/webtbs/tw38259.pp | 21 +++++++++++++-------- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/compiler/optdfa.pas b/compiler/optdfa.pas index bf772b423c..3c49440775 100644 --- a/compiler/optdfa.pas +++ b/compiler/optdfa.pas @@ -940,8 +940,11 @@ unit optdfa; MaybeSearchIn(texitnode(node).left); { exit uses the resultnode implicitly, so searching for a matching node is useless, if we reach the exit node and found the living node not in left, then - it can be only the resultnode } - if not(Result) and not(is_void(current_procinfo.procdef.returndef)) and + it can be only the resultnode + + successor might be assigned in case of an inlined exit node, in this case we do not warn about an unassigned + result as this had happened already when the routine has been compiled } + if not(assigned(node.successor)) and not(Result) and not(is_void(current_procinfo.procdef.returndef)) and not(assigned(texitnode(node).resultexpr)) and { don't warn about constructors } not(current_procinfo.procdef.proctypeoption in [potype_class_constructor,potype_constructor]) then diff --git a/tests/webtbs/tw38259.pp b/tests/webtbs/tw38259.pp index 33b88d6051..4f15995467 100644 --- a/tests/webtbs/tw38259.pp +++ b/tests/webtbs/tw38259.pp @@ -1,16 +1,21 @@ -{ %OPT=-O3 -Sew -vw } {$mode objfpc} {$inline on} -procedure test; inline; -begin - exit; -end; +procedure mymove(var src,dst; len: ptrint); inline; + begin + if len<=0 then + exit; + end; -function f: longint; + +function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar; +var + p : pchar; begin - test; // tt.pp(11,3) Warning: Function result variable does not seem to be initialized - result:=4; + getmem(p,length1+length2+1); + mymove(p1[0],p[0],length1); + mymove(p2[0],p[length1],length2+1); + concatansistrings:=p; end; begin From 8311837468145b3247d78d2bde23df668e5a3e60 Mon Sep 17 00:00:00 2001 From: marco Date: Fri, 1 Jan 2021 13:45:28 +0000 Subject: [PATCH 3/6] --no-offset option for chmls, makes it easier to compare listings. git-svn-id: trunk@47932 - --- packages/chm/src/chmls.lpi | 288 +++++++++++++++++++++++++++++++++---- packages/chm/src/chmls.lpr | 26 +++- 2 files changed, 282 insertions(+), 32 deletions(-) diff --git a/packages/chm/src/chmls.lpi b/packages/chm/src/chmls.lpi index 38e98fde2b..f57b2d0ee5 100644 --- a/packages/chm/src/chmls.lpi +++ b/packages/chm/src/chmls.lpi @@ -1,57 +1,289 @@ - + - - + - - - - + + + + + + + - + + + - - - - - + + + + + + + + + + + + + - + - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + - - - - - - + + + + + diff --git a/packages/chm/src/chmls.lpr b/packages/chm/src/chmls.lpr index c1ac4f5a88..b3d789eb48 100644 --- a/packages/chm/src/chmls.lpr +++ b/packages/chm/src/chmls.lpr @@ -61,7 +61,7 @@ Const CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','PRINTIDXHDR','PRINTSYSTEM','PRINTWINDOWS','PRINTTOPICS',''); var - theopts : array[1..4] of TOption; + theopts : array[1..5] of TOption; Procedure Usage; @@ -72,6 +72,7 @@ begin writeln(stderr,'Switches : '); writeln(stderr,' -h, --help : this screen'); writeln(stderr,' -p, --no-page : do not page list output'); + writeln(stderr,' --no-offset : do not show "offset" column in list output'); writeln(stderr,' -n,--name-only : only show "name" column in list output'); writeln(stderr); writeln(stderr,'Where command is one of the following or if omitted, equal to LIST.'); @@ -136,6 +137,12 @@ begin flag:=nil; end; with theopts[4] do + begin + name:='no-offset'; + has_arg:=0; + flag:=nil; + end; + with theopts[5] do begin name:=''; has_arg:=0; @@ -183,20 +190,30 @@ begin end; +var donotshowoffset : boolean=false; + procedure TListObject.OnFileEntry(Name: String; Offset, UncompressedSize, ASection: Integer); begin Inc(Count); if (Section > -1) and (ASection <> Section) then Exit; if (Count = 1) or ((Count mod 40 = 0) and not donotpage) then - WriteLn(StdErr, '
'); + begin + Write(StdErr, '
'); + if not donotshowoffset then + Write(StdErr, ' '); + Writeln(StdErr, ' '); + end; if not nameonly then begin Write(' '); Write(ASection); Write(' '); - WriteStrAdj(IntToStr(Offset), 10); - Write(' '); + if not donotshowoffset then + begin + WriteStrAdj(IntToStr(Offset), 10); + Write(' '); + end; WriteStrAdj(IntToStr(UncompressedSize), 11); Write(' '); end; @@ -1003,6 +1020,7 @@ begin end; 1 : name_only:=true; 2 : donotpage:=true; + 3 : donotshowoffset:=true; end; end; From 97abf6b49557961c9fdd525b4b4db4e4763d6e37 Mon Sep 17 00:00:00 2001 From: florian Date: Fri, 1 Jan 2021 15:26:13 +0000 Subject: [PATCH 4/6] * first part of fixing #38267: do not bail out early during constant folding if the constant is 1 or -1 git-svn-id: trunk@47933 - --- .gitattributes | 1 + compiler/nadd.pas | 29 +++++++++------------------ tests/webtbs/tw38267a.pp | 43 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 20 deletions(-) create mode 100644 tests/webtbs/tw38267a.pp diff --git a/.gitattributes b/.gitattributes index 2e66040084..6f73a9e242 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18620,6 +18620,7 @@ tests/webtbs/tw38225.pp svneol=native#text/pascal tests/webtbs/tw38238.pp svneol=native#text/pascal tests/webtbs/tw38249.pp svneol=native#text/pascal tests/webtbs/tw38259.pp svneol=native#text/pascal +tests/webtbs/tw38267a.pp svneol=native#text/pascal tests/webtbs/tw3827.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain tests/webtbs/tw3833.pp svneol=native#text/plain diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 83b82fde05..07dabeb40f 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -708,9 +708,9 @@ implementation end; { Add,Sub,Mul,Or,Xor,Andn with constant 0, 1 or -1? } - if is_constintnode(right) and (is_integer(left.resultdef) or is_pointer(left.resultdef)) then + if is_constintnode(right) and (is_integer(left.resultdef) or is_pointer(left.resultdef)) then begin - if tordconstnode(right).value = 0 then + if (tordconstnode(right).value = 0) and (nodetype in [addn,subn,orn,xorn,andn,muln]) then begin case nodetype of addn,subn,orn,xorn: @@ -725,24 +725,13 @@ implementation ; end; end - else if tordconstnode(right).value = 1 then - begin - case nodetype of - muln: - result := left.getcopy; - else - ; - end; - end - else if tordconstnode(right).value = -1 then - begin - case nodetype of - muln: - result := ctypeconvnode.create_internal(cunaryminusnode.create(left.getcopy),left.resultdef); - else - ; - end; - end + + else if (tordconstnode(right).value = 1) and (nodetype=muln) then + result := left.getcopy + + else if (tordconstnode(right).value = -1) and (nodetype=muln) then + result := ctypeconvnode.create_internal(cunaryminusnode.create(left.getcopy),left.resultdef) + { try to fold op op / \ / \ diff --git a/tests/webtbs/tw38267a.pp b/tests/webtbs/tw38267a.pp new file mode 100644 index 0000000000..a3077fae4e --- /dev/null +++ b/tests/webtbs/tw38267a.pp @@ -0,0 +1,43 @@ +{ %OPT=-O3 } +{$goto on} +label start0, end0, start1, end1; + +var + x: int16; + +begin + x := random(2); + writeln('x := ', x); + writeln; + +start0: + x := + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+x; +end0: + writeln('x := 1 + 1 + ...100 times ... + x, x = ', x, ': '); + writeln(SizeUint(CodePointer(@end0) - CodePointer(@start0)), ' b of code'); + { hundred is actually arbitrarily chosen but should be sufficient for all targets + to show that constant folding works } + if SizeUint(CodePointer(@end0) - CodePointer(@start0))>100 then + halt(1); + writeln; + +start1: + x := x+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+ + 1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1+1; +end1: + writeln('x := x + 1 + 1 + ...100 times ..., x = ', x, ': '); + { hundred is actually arbitrarily chosen but should be sufficient for all targets + to show that constant folding works } + writeln(SizeUint(CodePointer(@end1) - CodePointer(@start1)), ' b of code'); + if SizeUint(CodePointer(@end1) - CodePointer(@start1))>100 then + halt(2); + writeln('ok'); +end. + From e6037961e3be89a55dcb273dd8327fdb85d5338c Mon Sep 17 00:00:00 2001 From: florian Date: Fri, 1 Jan 2021 21:58:12 +0000 Subject: [PATCH 5/6] * refactored constant folding code git-svn-id: trunk@47935 - --- compiler/nadd.pas | 147 +++++++++++++++++++++++++--------------------- 1 file changed, 80 insertions(+), 67 deletions(-) diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 07dabeb40f..b484c2449f 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -489,6 +489,74 @@ implementation end; + function SwapRightWithLeftRight : tnode; + var + hp : tnode; + begin + hp:=right; + right:=taddnode(left).right; + taddnode(left).right:=hp; + left:=left.simplify(forinline); + if resultdef.typ<>pointerdef then + begin + { ensure that the constant is not expanded to a larger type due to overflow, + but this is only useful if no pointer operation is done } + left:=ctypeconvnode.create_internal(left,resultdef); + do_typecheckpass(left); + end; + result:=GetCopyAndTypeCheck; + end; + + + function SwapRightWithLeftLeft : tnode; + var + hp,hp2 : tnode; + begin + { keep the order of val+const else pointer operations might cause an error } + hp:=taddnode(left).left; + taddnode(left).left:=right; + left.resultdef:=nil; + do_typecheckpass(left); + hp2:=left.simplify(forinline); + if assigned(hp2) then + left:=hp2; + if resultdef.typ<>pointerdef then + begin + { ensure that the constant is not expanded to a larger type due to overflow, + but this is only useful if no pointer operation is done } + left:=ctypeconvnode.create_internal(left,resultdef); + do_typecheckpass(left); + end; + right:=left; + left:=hp; + result:=GetCopyAndTypeCheck; + end; + + + function SwapLeftWithRightRight : tnode; + var + hp: tnode; + begin + hp:=left; + left:=taddnode(right).right; + taddnode(right).right:=hp; + right:=right.simplify(false); + result:=GetCopyAndTypeCheck; + end; + + + function SwapLeftWithRightLeft : tnode; + var + hp: tnode; + begin + hp:=left; + left:=taddnode(right).left; + taddnode(right).left:=hp; + right:=right.simplify(false); + result:=GetCopyAndTypeCheck; + end; + + var t,vl,hp,lefttarget,righttarget, hp2: tnode; lt,rt : tnodetype; @@ -752,20 +820,7 @@ implementation andn, orn, muln: - begin - hp:=right; - right:=taddnode(left).right; - taddnode(left).right:=hp; - left:=left.simplify(forinline); - if resultdef.typ<>pointerdef then - begin - { ensure that the constant is not expanded to a larger type due to overflow, - but this is only useful if no pointer operation is done } - left:=ctypeconvnode.create_internal(left,resultdef); - do_typecheckpass(left); - end; - result:=GetCopyAndTypeCheck; - end; + Result:=SwapRightWithLeftRight; else ; end; @@ -778,26 +833,7 @@ implementation andn, orn, muln: - begin - { keep the order of val+const else pointer operations might cause an error } - hp:=taddnode(left).left; - taddnode(left).left:=right; - left.resultdef:=nil; - do_typecheckpass(left); - hp2:=left.simplify(forinline); - if assigned(hp2) then - left:=hp2; - if resultdef.typ<>pointerdef then - begin - { ensure that the constant is not expanded to a larger type due to overflow, - but this is only useful if no pointer operation is done } - left:=ctypeconvnode.create_internal(left,resultdef); - do_typecheckpass(left); - end; - right:=left; - left:=hp; - result:=GetCopyAndTypeCheck; - end; + Result:=SwapRightWithLeftLeft; else ; end; @@ -808,7 +844,7 @@ implementation end; if is_constintnode(left) and (is_integer(right.resultdef) or is_pointer(right.resultdef)) then begin - if tordconstnode(left).value = 0 then + if (tordconstnode(left).value = 0) and (nodetype in [addn,orn,xorn,subn,andn,muln]) then begin case nodetype of addn,orn,xorn: @@ -825,24 +861,13 @@ implementation ; end; end - else if tordconstnode(left).value = 1 then - begin - case nodetype of - muln: - result := right.getcopy; - else - ; - end; - end - else if tordconstnode(left).value = -1 then - begin - case nodetype of - muln: - result := ctypeconvnode.create_internal(cunaryminusnode.create(right.getcopy),right.resultdef); - else - ; - end; - end + + else if (tordconstnode(left).value = 1) and (nodetype=muln) then + result := right.getcopy + + else if (tordconstnode(left).value = -1) and (nodetype=muln) then + result := ctypeconvnode.create_internal(cunaryminusnode.create(right.getcopy),right.resultdef) + { try to fold op / \ @@ -863,13 +888,7 @@ implementation andn, orn, muln: - begin - hp:=left; - left:=taddnode(right).right; - taddnode(right).right:=hp; - right:=right.simplify(false); - result:=GetCopyAndTypeCheck; - end; + Result:=SwapLeftWithRightRight; else ; end; @@ -882,13 +901,7 @@ implementation andn, orn, muln: - begin - hp:=left; - left:=taddnode(right).left; - taddnode(right).left:=hp; - right:=right.simplify(false); - result:=GetCopyAndTypeCheck; - end; + Result:=SwapLeftWithRightLeft; else ; end; From f0122bd4a0d3c4897a53355d607138136b5c00a1 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Fri, 1 Jan 2021 22:29:58 +0000 Subject: [PATCH 6/6] fcl-passrc: resolver: parse library git-svn-id: trunk@47936 - --- packages/fcl-passrc/src/pasresolveeval.pas | 109 ++++++++++++++ packages/fcl-passrc/src/pasresolver.pp | 30 ++++ packages/fcl-passrc/src/pastree.pp | 1 + packages/fcl-passrc/src/pparser.pp | 1 + packages/fcl-passrc/tests/tcresolver.pas | 167 ++++++++++++++++----- 5 files changed, 272 insertions(+), 36 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 9c2faf8b4f..a2d654cb21 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -435,6 +435,7 @@ type revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3] revkExternal // TResEvalExternal: an external const ); + TREVKinds = set of TREVKind; const revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString]; type @@ -447,6 +448,7 @@ type function Clone: TResEvalValue; virtual; function AsDebugString: string; virtual; function AsString: string; virtual; + function TypeAsString: string; virtual; end; TResEvalValueClass = class of TResEvalValue; @@ -459,6 +461,7 @@ type constructor CreateValue(const aValue: boolean); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; TResEvalTypedInt = ( @@ -520,6 +523,7 @@ type function Clone: TResEvalValue; override; function AsString: string; override; function AsDebugString: string; override; + function TypeAsString: string; override; end; { TResEvalUInt } @@ -531,6 +535,7 @@ type constructor CreateValue(const aValue: TMaxPrecUInt); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalFloat } @@ -543,6 +548,7 @@ type function Clone: TResEvalValue; override; function AsString: string; override; function IsInt(out Int: TMaxPrecInt): boolean; + function TypeAsString: string; override; end; { TResEvalCurrency } @@ -556,6 +562,7 @@ type function AsString: string; override; function IsInt(out Int: TMaxPrecInt): boolean; function AsInt: TMaxPrecInt; // value * 10.000 + function TypeAsString: string; override; end; {$ifdef FPC_HAS_CPSTRING} @@ -569,6 +576,7 @@ type constructor CreateValue(const aValue: RawByteString); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; {$endif} @@ -581,6 +589,7 @@ type constructor CreateValue(const aValue: UnicodeString); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalEnum - Kind=revkEnum, Value.Int } @@ -596,6 +605,7 @@ type function Clone: TResEvalValue; override; function AsDebugString: string; override; function AsString: string; override; + function TypeAsString: string; override; end; TRESetElKind = ( @@ -620,6 +630,7 @@ type function AsString: string; override; function AsDebugString: string; override; function ElementAsString(El: TMaxPrecInt): string; virtual; + function TypeAsString: string; override; end; { TResEvalRangeUInt } @@ -631,6 +642,7 @@ type constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalSet - Kind=revkSetOfInt } @@ -652,6 +664,7 @@ type const aRangeStart, aRangeEnd: TMaxPrecInt); override; function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer; function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range @@ -665,6 +678,7 @@ type constructor Create; override; function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; TResEvalFlag = ( @@ -1188,6 +1202,11 @@ begin Result:=inherited AsString; end; +function TResEvalExternal.TypeAsString: string; +begin + Result:='external value'; +end; + { TResEvalCurrency } constructor TResEvalCurrency.Create; @@ -1231,6 +1250,11 @@ begin {$endif}; end; +function TResEvalCurrency.TypeAsString: string; +begin + Result:='currency'; +end; + { TResEvalBool } constructor TResEvalBool.Create; @@ -1259,6 +1283,11 @@ begin Result:='false'; end; +function TResEvalBool.TypeAsString: string; +begin + Result:='boolean'; +end; + { TResEvalRangeUInt } constructor TResEvalRangeUInt.Create; @@ -1287,6 +1316,11 @@ begin Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd); end; +function TResEvalRangeUInt.TypeAsString: string; +begin + Result:='unsigned integer range'; +end; + { TResExprEvaluator } procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; @@ -5615,6 +5649,15 @@ begin end; end; +function TResEvalValue.TypeAsString: string; +begin + case Kind of + revkNil: Result:='nil'; + else + Result:=''; + end; +end; + { TResEvalUInt } constructor TResEvalUInt.Create; @@ -5640,6 +5683,11 @@ begin Result:=IntToStr(UInt); end; +function TResEvalUInt.TypeAsString: string; +begin + Result:='unsigned int'; +end; + { TResEvalInt } constructor TResEvalInt.Create; @@ -5697,6 +5745,24 @@ begin end; end; +function TResEvalInt.TypeAsString: string; +begin + case Typed of + reitByte: Result:='byte'; + reitShortInt: Result:='shortint'; + reitWord: Result:='word'; + reitSmallInt: Result:='smallint'; + reitUIntSingle: Result:='unsinged int single'; + reitIntSingle: Result:='int single'; + reitLongWord: Result:='longword'; + reitLongInt: Result:='longint'; + reitUIntDouble: Result:='unsigned int double'; + reitIntDouble: Result:='int double'; + else + Result:='int'; + end; +end; + { TResEvalFloat } constructor TResEvalFloat.Create; @@ -5732,6 +5798,11 @@ begin Result:=true; end; +function TResEvalFloat.TypeAsString: string; +begin + Result:='float'; +end; + {$ifdef FPC_HAS_CPSTRING} { TResEvalString } @@ -5759,6 +5830,15 @@ function TResEvalString.AsString: string; begin Result:=RawStrToCaption(S,60); end; + +function TResEvalString.TypeAsString: string; +begin + if OnlyASCII then + Result:='string' + else + Result:='ansistring'; +end; + {$endif} { TResEvalUTF16 } @@ -5786,6 +5866,11 @@ begin Result:=String(UnicodeStrToCaption(S,60)); end; +function TResEvalUTF16.TypeAsString: string; +begin + Result:='unicodestring'; +end; + { TResEvalEnum } constructor TResEvalEnum.Create; @@ -5849,6 +5934,13 @@ begin Result:=ElType.Name+'('+IntToStr(Index)+')'; end; +function TResEvalEnum.TypeAsString: string; +begin + Result:=ElType.Name; + if Result='' then + Result:='enum'; +end; + { TResEvalRangeInt } constructor TResEvalRangeInt.Create; @@ -5920,6 +6012,18 @@ begin end; end; +function TResEvalRangeInt.TypeAsString: string; +begin + case ElKind of + revskEnum: Result:='enum range'; + revskInt: Result:='integer range'; + revskChar: Result:='char range'; + revskBool: Result:='boolean range'; + else + Result:='integer range'; + end; +end; + { TResEvalSet } constructor TResEvalSet.Create; @@ -5980,6 +6084,11 @@ begin Result:=Result+']'; end; +function TResEvalSet.TypeAsString: string; +begin + Result:='set'; +end; + function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; {$IF FPC_FULLVERSION<30101} diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 5a3de61d52..77630339f3 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -1698,6 +1698,7 @@ type procedure FinishAncestors(aClass: TPasClassType); virtual; procedure FinishMethodResolution(El: TPasMethodResolution); virtual; procedure FinishAttributes(El: TPasAttributes); virtual; + procedure FinishExportSymbol(El: TPasExportSymbol); virtual; procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual; procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty); virtual; @@ -5826,6 +5827,7 @@ begin FinishSection(TPasLibrary(CurModule).LibrarySection); // resolve begin..end block ResolveImplBlock(CurModule.InitializationSection); + ResolveImplBlock(CurModule.FinalizationSection); end else if (CurModuleClass=TPasModule) then begin @@ -7776,6 +7778,8 @@ begin FinishMethodResolution(TPasMethodResolution(El)) else if C=TPasAttributes then FinishAttributes(TPasAttributes(El)) + else if C=TPasExportSymbol then + FinishExportSymbol(TPasExportSymbol(El)) else begin {$IFDEF VerbosePasResolver} @@ -9133,6 +9137,31 @@ begin end; end; +procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol); + + procedure CheckExpExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string); + var + Value: TResEvalValue; + ResolvedEl: TPasResolverResult; + begin + if Expr=nil then exit; + ResolveExpr(Expr,rraRead); + Value:=Eval(Expr,[refConst]); + if (Value<>nil) and (Value.Kind in Kinds) then + begin + ReleaseEvalValue(Value); + exit; + end; + ReleaseEvalValue(Value); + ComputeElement(Expr,ResolvedEl,[rcConstant]); + RaiseXExpectedButYFound(20210101194628,Expected,GetTypeDescription(ResolvedEl),Expr); + end; + +begin + CheckExpExpr(El.ExportIndex,[revkInt,revkUInt],'integer'); + CheckExpExpr(El.ExportName,[revkString,revkUnicodeString],'string'); +end; + procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); var @@ -20836,6 +20865,7 @@ begin else if AClass.InheritsFrom(TPasImplBlock) then // resolved when finished else if AClass=TPasAttributes then + else if AClass=TPasExportSymbol then else if AClass=TPasUnresolvedUnitRef then RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El) else diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 8d28221d96..819fe25907 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -447,6 +447,7 @@ type PackageName: string; Filename : String; // the IN filename, only written when not empty. end; + TPasModuleClass = class of TPasModule; { TPasUnitModule } diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index c1a115cf46..467a7fa721 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -4360,6 +4360,7 @@ begin end; if not (CurToken in [tkComma,tkSemicolon]) then ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); + Engine.FinishScope(stDeclaration,E); until (CurToken=tkSemicolon); end; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 24b48e365d..c1000b6150 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -142,7 +142,9 @@ type Procedure TearDown; override; procedure CreateEngine(var TheEngine: TPasTreeContainer); override; procedure ParseModule; override; + procedure ParseMain(ExpectedModuleClass: TPasModuleClass); virtual; procedure ParseProgram; virtual; + procedure ParseLibrary; virtual; procedure ParseUnit; virtual; procedure CheckReferenceDirectives; virtual; procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer; @@ -172,6 +174,7 @@ type ImplementationSrc: string): TTestEnginePasResolver; procedure AddSystemUnit(Parts: TSystemUnitParts = []); procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); + procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); procedure StartUnit(NeedSystemUnit: boolean); property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property ModuleCount: integer read GetModuleCount; @@ -975,6 +978,15 @@ type Procedure TestAttributes_NonConstParam_Fail; Procedure TestAttributes_UnknownAttrWarning; Procedure TestAttributes_Members; + + // library + Procedure TestLibrary_Empty; + Procedure TestLibrary_ExportFunc; + Procedure TestLibrary_ExportFunc_NameIntFail; + Procedure TestLibrary_ExportFunc_IndexStringFail; + Procedure TestLibrary_ExportVar; // ToDo + Procedure TestLibrary_Initialization_Finalization; + // ToDo Procedure TestLibrary_UnitExports; end; function LinesToStr(Args: array of const): string; @@ -1193,7 +1205,7 @@ begin end; end; -procedure TCustomTestResolver.ParseProgram; +procedure TCustomTestResolver.ParseMain(ExpectedModuleClass: TPasModuleClass); var aFilename: String; aRow, aCol: Integer; @@ -1208,7 +1220,7 @@ begin aRow:=E.Row; aCol:=E.Column; WriteSources(aFilename,aRow,aCol); - writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message, + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Parser: '+E.ClassName+':'+E.Message, ' Scanner at' +' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')' +' Line="'+Scanner.CurLine+'"'); @@ -1225,17 +1237,22 @@ begin ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol); end; WriteSources(aFilename,aRow,aCol); - writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' PasResolver: '+E.ClassName+':'+E.Message +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'); Fail(E.Message); end; on E: Exception do begin - writeln('ERROR: TTestResolver.ParseProgram Exception: '+E.ClassName+':'+E.Message); + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Exception: '+E.ClassName+':'+E.Message); Fail(E.Message); end; end; TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine); +end; + +procedure TCustomTestResolver.ParseProgram; +begin + ParseMain(TPasProgram); AssertEquals('Has program',TPasProgram,Module.ClassType); AssertNotNull('Has program section',PasProgram.ProgramSection); AssertNotNull('Has initialization section',PasProgram.InitializationSection); @@ -1245,39 +1262,18 @@ begin CheckReferenceDirectives; end; +procedure TCustomTestResolver.ParseLibrary; +begin + ParseMain(TPasLibrary); + AssertEquals('Has library',TPasLibrary,Module.ClassType); + AssertNotNull('Has library section',PasLibrary.LibrarySection); + AssertNotNull('Has initialization section',PasLibrary.InitializationSection); + CheckReferenceDirectives; +end; + procedure TCustomTestResolver.ParseUnit; begin - FFirstStatement:=nil; - try - ParseModule; - except - on E: EParserError do - begin - writeln('ERROR: TTestResolver.ParseUnit Parser: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); - Fail(E.Message); - end; - on E: EPasResolve do - begin - writeln('ERROR: TTestResolver.ParseUnit PasResolver: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); - Fail(E.Message); - end; - on E: Exception do - begin - writeln('ERROR: TTestResolver.ParseUnit Exception: '+E.ClassName+':'+E.Message); - Fail(E.Message); - end; - end; - TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine); + ParseMain(TPasModule); AssertEquals('Has unit',TPasModule,Module.ClassType); AssertNotNull('Has interface section',Module.InterfaceSection); AssertNotNull('Has implementation section',Module.ImplementationSection); @@ -2333,6 +2329,16 @@ begin Add('program '+ExtractFileUnitName(MainFilename)+';'); end; +procedure TCustomTestResolver.StartLibrary(NeedSystemUnit: boolean; + SystemUnitParts: TSystemUnitParts); +begin + if NeedSystemUnit then + AddSystemUnit(SystemUnitParts) + else + Parser.ImplicitUses.Clear; + Add('library '+ExtractFileUnitName(MainFilename)+';'); +end; + procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean); begin if NeedSystemUnit then @@ -3623,7 +3629,7 @@ begin ' m=low(char)+high(char);', ' n = string(''A'');', ' o = UnicodeString(''A'');', - //' p = ^C''bird'';', + ' p = ^C''bird'';', 'begin']); ParseProgram; CheckResolverUnexpectedHints; @@ -18738,6 +18744,95 @@ begin CheckAttributeMarkers; end; +procedure TTestResolver.TestLibrary_Empty; +begin + StartLibrary(false); + Add(['begin']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_ExportFunc; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'procedure Fly;', + 'begin', + 'end;', + 'exports', + ' Run,', + ' Fly name ''FlyHi'';', + 'exports', + ' Run index 3+4;', + 'begin', + '']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_ExportFunc_NameIntFail; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'exports', + ' Run name 4;', + 'begin', + '']); + CheckResolverException('string expected, but Longint found',nXExpectedButYFound); +end; + +procedure TTestResolver.TestLibrary_ExportFunc_IndexStringFail; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'exports', + ' Run index ''abc'';', + 'begin', + '']); + CheckResolverException('integer expected, but String found',nXExpectedButYFound); +end; + +procedure TTestResolver.TestLibrary_ExportVar; +begin + exit; + + StartLibrary(false); + Add([ + 'var', + ' Size: word; export name ''size'';', + 'exports', + ' Size,', + ' Fly as ''FlyHi'',', + ' Run index 3+4;', + 'begin', + '']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_Initialization_Finalization; +begin + StartLibrary(false); + Add([ + 'procedure Run(w: word);', + 'begin', + 'end;', + 'exports', + ' Run;', + 'initialization', + ' Run(3);', + 'finalization', + ' Run(4);', + '']); + ParseLibrary; +end; + initialization RegisterTests([TTestResolver]);