* synchronized with trunk

git-svn-id: branches/wasm@47937 -
This commit is contained in:
nickysn 2021-01-02 04:55:50 +00:00
commit f87f9969a7
13 changed files with 709 additions and 166 deletions

1
.gitattributes vendored
View File

@ -18659,6 +18659,7 @@ tests/webtbs/tw38225.pp svneol=native#text/pascal
tests/webtbs/tw38238.pp svneol=native#text/pascal tests/webtbs/tw38238.pp svneol=native#text/pascal
tests/webtbs/tw38249.pp svneol=native#text/pascal tests/webtbs/tw38249.pp svneol=native#text/pascal
tests/webtbs/tw38259.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/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain
tests/webtbs/tw3833.pp svneol=native#text/plain tests/webtbs/tw3833.pp svneol=native#text/plain

View File

@ -423,7 +423,7 @@ Implementation
DebugMsg('Peephole LdiOp2Opi performed', p); DebugMsg('Peephole LdiOp2Opi performed', p);
RemoveCurrentP(p); result:=RemoveCurrentP(p);
end; end;
end; end;
end; end;
@ -447,6 +447,7 @@ Implementation
taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset) taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset)
else else
taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset-32); taicpu(p).loadconst(0,taicpu(p).oper[0]^.ref^.offset-32);
result:=true;
end; end;
A_LDS: A_LDS:
if (taicpu(p).oper[1]^.ref^.symbol=nil) and if (taicpu(p).oper[1]^.ref^.symbol=nil) and
@ -468,6 +469,8 @@ Implementation
taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset) taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset)
else else
taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset-32); taicpu(p).loadconst(1,taicpu(p).oper[1]^.ref^.offset-32);
result:=true;
end; end;
A_IN: A_IN:
if GetNextInstruction(p,hp1) then if GetNextInstruction(p,hp1) then

View File

@ -489,6 +489,74 @@ implementation
end; 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 var
t,vl,hp,lefttarget,righttarget, hp2: tnode; t,vl,hp,lefttarget,righttarget, hp2: tnode;
lt,rt : tnodetype; lt,rt : tnodetype;
@ -710,7 +778,7 @@ implementation
{ Add,Sub,Mul,Or,Xor,Andn with constant 0, 1 or -1? } { 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 begin
if tordconstnode(right).value = 0 then if (tordconstnode(right).value = 0) and (nodetype in [addn,subn,orn,xorn,andn,muln]) then
begin begin
case nodetype of case nodetype of
addn,subn,orn,xorn: addn,subn,orn,xorn:
@ -725,24 +793,13 @@ implementation
; ;
end; end;
end end
else if tordconstnode(right).value = 1 then
begin else if (tordconstnode(right).value = 1) and (nodetype=muln) then
case nodetype of result := left.getcopy
muln:
result := left.getcopy; else if (tordconstnode(right).value = -1) and (nodetype=muln) then
else result := ctypeconvnode.create_internal(cunaryminusnode.create(left.getcopy),left.resultdef)
;
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
{ try to fold { try to fold
op op op op
/ \ / \ / \ / \
@ -763,20 +820,7 @@ implementation
andn, andn,
orn, orn,
muln: muln:
begin Result:=SwapRightWithLeftRight;
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;
else else
; ;
end; end;
@ -789,26 +833,7 @@ implementation
andn, andn,
orn, orn,
muln: muln:
begin Result:=SwapRightWithLeftLeft;
{ 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;
else else
; ;
end; end;
@ -819,7 +844,7 @@ implementation
end; end;
if is_constintnode(left) and (is_integer(right.resultdef) or is_pointer(right.resultdef)) then if is_constintnode(left) and (is_integer(right.resultdef) or is_pointer(right.resultdef)) then
begin begin
if tordconstnode(left).value = 0 then if (tordconstnode(left).value = 0) and (nodetype in [addn,orn,xorn,subn,andn,muln]) then
begin begin
case nodetype of case nodetype of
addn,orn,xorn: addn,orn,xorn:
@ -836,24 +861,13 @@ implementation
; ;
end; end;
end end
else if tordconstnode(left).value = 1 then
begin else if (tordconstnode(left).value = 1) and (nodetype=muln) then
case nodetype of result := right.getcopy
muln:
result := right.getcopy; else if (tordconstnode(left).value = -1) and (nodetype=muln) then
else result := ctypeconvnode.create_internal(cunaryminusnode.create(right.getcopy),right.resultdef)
;
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
{ try to fold { try to fold
op op
/ \ / \
@ -874,13 +888,7 @@ implementation
andn, andn,
orn, orn,
muln: muln:
begin Result:=SwapLeftWithRightRight;
hp:=left;
left:=taddnode(right).right;
taddnode(right).right:=hp;
right:=right.simplify(false);
result:=GetCopyAndTypeCheck;
end;
else else
; ;
end; end;
@ -893,13 +901,7 @@ implementation
andn, andn,
orn, orn,
muln: muln:
begin Result:=SwapLeftWithRightLeft;
hp:=left;
left:=taddnode(right).left;
taddnode(right).left:=hp;
right:=right.simplify(false);
result:=GetCopyAndTypeCheck;
end;
else else
; ;
end; end;

View File

@ -940,8 +940,11 @@ unit optdfa;
MaybeSearchIn(texitnode(node).left); MaybeSearchIn(texitnode(node).left);
{ exit uses the resultnode implicitly, so searching for a matching node is { 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 useless, if we reach the exit node and found the living node not in left, then
it can be only the resultnode } it can be only the resultnode
if not(Result) and not(is_void(current_procinfo.procdef.returndef)) and
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 not(assigned(texitnode(node).resultexpr)) and
{ don't warn about constructors } { don't warn about constructors }
not(current_procinfo.procdef.proctypeoption in [potype_class_constructor,potype_constructor]) then not(current_procinfo.procdef.proctypeoption in [potype_class_constructor,potype_constructor]) then

View File

@ -1,57 +1,289 @@
<?xml version="1.0"?> <?xml version="1.0" encoding="UTF-8"?>
<CONFIG> <CONFIG>
<ProjectOptions> <ProjectOptions>
<PathDelim Value="/"/> <Version Value="12"/>
<Version Value="5"/>
<General> <General>
<MainUnit Value="0"/> <Flags>
<IconPath Value="./"/> <MainUnitHasCreateFormStatements Value="False"/>
<TargetFileExt Value=""/> <MainUnitHasTitleStatement Value="False"/>
<ActiveEditorIndexAtStart Value="1"/> <MainUnitHasScaledStatement Value="False"/>
<LRSInOutputDirectory Value="False"/>
<CompatibilityMode Value="True"/>
</Flags>
</General> </General>
<VersionInfo> <VersionInfo>
<ProjectVersion Value=""/>
<Language Value=""/> <Language Value=""/>
<CharSet Value=""/> <CharSet Value=""/>
</VersionInfo> </VersionInfo>
<BuildModes Count="1">
<Item1 Name="default" Default="True"/>
</BuildModes>
<PublishOptions> <PublishOptions>
<Version Value="2"/> <Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions> </PublishOptions>
<RunParams> <RunParams>
<local> <local>
<FormatVersion Value="1"/> <CommandLineParams Value="extractindex D:/src/chm/chmlaptop500gb/testproject/5/chmtest.chm"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
<WorkingDirectory Value="D:/src/chm/chmlaptop500gb/testproject/5"/>
</local> </local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="extractindex D:/src/chm/chmlaptop500gb/testproject/5/chmtest.chm"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
<WorkingDirectory Value="D:/src/chm/chmlaptop500gb/testproject/5"/>
</local>
</Mode0>
</Modes>
</RunParams> </RunParams>
<Units Count="1"> <Units Count="14">
<Unit0> <Unit0>
<Filename Value="chmls.lpr"/> <Filename Value="chmls.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="chmls"/> <IsVisibleTab Value="True"/>
<CursorPos X="22" Y="66"/> <TopLine Value="45"/>
<TopLine Value="41"/> <CursorPos X="24" Y="104"/>
<EditorIndex Value="0"/> <UsageCount Value="192"/>
<UsageCount Value="29"/>
<Loaded Value="True"/> <Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit0> </Unit0>
<Unit1>
<Filename Value="chmreader.pas"/>
<EditorIndex Value="1"/>
<TopLine Value="1580"/>
<CursorPos X="91" Y="1669"/>
<UsageCount Value="91"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="chmsitemap.pas"/>
<EditorIndex Value="6"/>
<TopLine Value="464"/>
<CursorPos X="14" Y="509"/>
<UsageCount Value="91"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="../../../../lazarus/components/lazutils/utf8process.pp"/>
<UnitName Value="UTF8Process"/>
<EditorIndex Value="12"/>
<TopLine Value="170"/>
<CursorPos X="69" Y="209"/>
<UsageCount Value="87"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="htmlutil.pas"/>
<UnitName Value="HTMLUtil"/>
<EditorIndex Value="11"/>
<TopLine Value="175"/>
<CursorPos X="3" Y="175"/>
<UsageCount Value="84"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="../../rtl-generics/src/inc/generics.dictionariesh.inc"/>
<EditorIndex Value="10"/>
<TopLine Value="566"/>
<CursorPos X="44" Y="614"/>
<UsageCount Value="84"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="../../rtl-generics/src/generics.collections.pas"/>
<UnitName Value="Generics.Collections"/>
<EditorIndex Value="9"/>
<TopLine Value="400"/>
<CursorPos X="18" Y="470"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
<Filename Value="../../../rtl/win32/classes.pp"/>
<UnitName Value="Classes"/>
<EditorIndex Value="7"/>
<CursorPos X="15" Y="44"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
</Unit7>
<Unit8>
<Filename Value="../../../rtl/objpas/classes/classesh.inc"/>
<EditorIndex Value="8"/>
<TopLine Value="195"/>
<CursorPos X="8" Y="272"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
</Unit8>
<Unit9>
<Filename Value="chmwriter.pas"/>
<EditorIndex Value="4"/>
<TopLine Value="1179"/>
<CursorPos X="40" Y="1258"/>
<UsageCount Value="68"/>
<Loaded Value="True"/>
</Unit9>
<Unit10>
<Filename Value="../../../utils/fpdoc/dw_html.pp"/>
<EditorIndex Value="5"/>
<TopLine Value="161"/>
<CursorPos Y="198"/>
<UsageCount Value="66"/>
<Loaded Value="True"/>
</Unit10>
<Unit11>
<Filename Value="../../../utils/fpdoc/dw_htmlchm.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="177"/>
<CursorPos X="17" Y="219"/>
<UsageCount Value="66"/>
</Unit11>
<Unit12>
<Filename Value="chmtypes.pas"/>
<EditorIndex Value="3"/>
<UsageCount Value="59"/>
<Loaded Value="True"/>
</Unit12>
<Unit13>
<Filename Value="../../../rtl/objpas/classes/lists.inc"/>
<EditorIndex Value="2"/>
<TopLine Value="635"/>
<CursorPos Y="680"/>
<UsageCount Value="33"/>
<Loaded Value="True"/>
</Unit13>
</Units> </Units>
<JumpHistory Count="0"> <JumpHistory Count="30" HistoryIndex="29">
<Position1>
<Filename Value="chmreader.pas"/>
<Caret Line="1291" Column="34" TopLine="1211"/>
</Position1>
<Position2>
<Filename Value="chmreader.pas"/>
<Caret Line="1366" Column="12" TopLine="1314"/>
</Position2>
<Position3>
<Filename Value="chmreader.pas"/>
<Caret Line="1376" Column="50" TopLine="1314"/>
</Position3>
<Position4>
<Filename Value="chmreader.pas"/>
<Caret Line="1325" Column="5" TopLine="1280"/>
</Position4>
<Position5>
<Filename Value="chmreader.pas"/>
<Caret Line="91" Column="14" TopLine="46"/>
</Position5>
<Position6>
<Filename Value="chmreader.pas"/>
<Caret Line="933" Column="3" TopLine="926"/>
</Position6>
<Position7>
<Filename Value="chmreader.pas"/>
<Caret Line="937" Column="21" TopLine="926"/>
</Position7>
<Position8>
<Filename Value="chmreader.pas"/>
<Caret Line="1313" Column="17" TopLine="1266"/>
</Position8>
<Position9>
<Filename Value="chmreader.pas"/>
<Caret Line="91" Column="15" TopLine="46"/>
</Position9>
<Position10>
<Filename Value="chmreader.pas"/>
<Caret Line="934" Column="3" TopLine="926"/>
</Position10>
<Position11>
<Filename Value="chmreader.pas"/>
<Caret Line="1322" Column="17" TopLine="1273"/>
</Position11>
<Position12>
<Filename Value="chmreader.pas"/>
<Caret Line="1360" Column="28" TopLine="1312"/>
</Position12>
<Position13>
<Filename Value="chmreader.pas"/>
</Position13>
<Position14>
<Filename Value="chmreader.pas"/>
<Caret Line="53" Column="64"/>
</Position14>
<Position15>
<Filename Value="chmreader.pas"/>
<Caret Line="80" Column="38"/>
</Position15>
<Position16>
<Filename Value="chmreader.pas"/>
<Caret Line="81" Column="48"/>
</Position16>
<Position17>
<Filename Value="chmreader.pas"/>
<Caret Line="944" Column="83" TopLine="862"/>
</Position17>
<Position18>
<Filename Value="chmreader.pas"/>
<Caret Line="1503" Column="12" TopLine="1421"/>
</Position18>
<Position19>
<Filename Value="chmreader.pas"/>
<Caret Line="1554" Column="41" TopLine="1472"/>
</Position19>
<Position20>
<Filename Value="chmls.lpr"/>
<Caret Line="492" Column="38" TopLine="482"/>
</Position20>
<Position21>
<Filename Value="chmls.lpr"/>
</Position21>
<Position22>
<Filename Value="chmls.lpr"/>
<Caret Line="47" Column="58"/>
</Position22>
<Position23>
<Filename Value="chmls.lpr"/>
<Caret Line="189" Column="3" TopLine="186"/>
</Position23>
<Position24>
<Filename Value="chmls.lpr"/>
<Caret Line="1009" Column="33" TopLine="983"/>
</Position24>
<Position25>
<Filename Value="chmls.lpr"/>
<Caret Line="140" Column="21" TopLine="64"/>
</Position25>
<Position26>
<Filename Value="chmls.lpr"/>
<Caret Line="1011" Column="20" TopLine="989"/>
</Position26>
<Position27>
<Filename Value="chmls.lpr"/>
<Caret Line="199" Column="64" TopLine="173"/>
</Position27>
<Position28>
<Filename Value="chmls.lpr"/>
</Position28>
<Position29>
<Filename Value="chmls.lpr"/>
<Caret Line="197" Column="85" TopLine="146"/>
</Position29>
<Position30>
<Filename Value="chmls.lpr"/>
<Caret Line="462" TopLine="373"/>
</Position30>
</JumpHistory> </JumpHistory>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>
<Version Value="5"/> <Version Value="11"/>
<SearchPaths> <SearchPaths>
<OtherUnitFiles Value="/home/andrew/programming/lazarus/components/chmhelp/packages/chm/"/> <UnitOutputDirectory Value="../units/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
<CodeGeneration> <Parsing>
<Generate Value="Faster"/> <SyntaxOptions>
</CodeGeneration> <UseAnsiStrings Value="False"/>
<Other> </SyntaxOptions>
<CompilerPath Value="$(CompPath)"/> </Parsing>
</Other>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
<Exceptions Count="2"> <Exceptions Count="2">

View File

@ -61,7 +61,7 @@ Const
CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','PRINTIDXHDR','PRINTSYSTEM','PRINTWINDOWS','PRINTTOPICS',''); CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','PRINTIDXHDR','PRINTSYSTEM','PRINTWINDOWS','PRINTTOPICS','');
var var
theopts : array[1..4] of TOption; theopts : array[1..5] of TOption;
Procedure Usage; Procedure Usage;
@ -72,6 +72,7 @@ begin
writeln(stderr,'Switches : '); writeln(stderr,'Switches : ');
writeln(stderr,' -h, --help : this screen'); writeln(stderr,' -h, --help : this screen');
writeln(stderr,' -p, --no-page : do not page list output'); 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,' -n,--name-only : only show "name" column in list output');
writeln(stderr); writeln(stderr);
writeln(stderr,'Where command is one of the following or if omitted, equal to LIST.'); writeln(stderr,'Where command is one of the following or if omitted, equal to LIST.');
@ -136,6 +137,12 @@ begin
flag:=nil; flag:=nil;
end; end;
with theopts[4] do with theopts[4] do
begin
name:='no-offset';
has_arg:=0;
flag:=nil;
end;
with theopts[5] do
begin begin
name:=''; name:='';
has_arg:=0; has_arg:=0;
@ -183,20 +190,30 @@ begin
end; end;
var donotshowoffset : boolean=false;
procedure TListObject.OnFileEntry(Name: String; Offset, UncompressedSize, procedure TListObject.OnFileEntry(Name: String; Offset, UncompressedSize,
ASection: Integer); ASection: Integer);
begin begin
Inc(Count); Inc(Count);
if (Section > -1) and (ASection <> Section) then Exit; if (Section > -1) and (ASection <> Section) then Exit;
if (Count = 1) or ((Count mod 40 = 0) and not donotpage) then if (Count = 1) or ((Count mod 40 = 0) and not donotpage) then
WriteLn(StdErr, '<Section> <Offset> <UnCompSize> <Name>'); begin
Write(StdErr, '<Section> ');
if not donotshowoffset then
Write(StdErr, '<Offset> ');
Writeln(StdErr, '<UnCompSize> <Name>');
end;
if not nameonly then if not nameonly then
begin begin
Write(' '); Write(' ');
Write(ASection); Write(ASection);
Write(' '); Write(' ');
if not donotshowoffset then
begin
WriteStrAdj(IntToStr(Offset), 10); WriteStrAdj(IntToStr(Offset), 10);
Write(' '); Write(' ');
end;
WriteStrAdj(IntToStr(UncompressedSize), 11); WriteStrAdj(IntToStr(UncompressedSize), 11);
Write(' '); Write(' ');
end; end;
@ -1003,6 +1020,7 @@ begin
end; end;
1 : name_only:=true; 1 : name_only:=true;
2 : donotpage:=true; 2 : donotpage:=true;
3 : donotshowoffset:=true;
end; end;
end; end;

View File

@ -435,6 +435,7 @@ type
revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3] revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3]
revkExternal // TResEvalExternal: an external const revkExternal // TResEvalExternal: an external const
); );
TREVKinds = set of TREVKind;
const const
revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString]; revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString];
type type
@ -447,6 +448,7 @@ type
function Clone: TResEvalValue; virtual; function Clone: TResEvalValue; virtual;
function AsDebugString: string; virtual; function AsDebugString: string; virtual;
function AsString: string; virtual; function AsString: string; virtual;
function TypeAsString: string; virtual;
end; end;
TResEvalValueClass = class of TResEvalValue; TResEvalValueClass = class of TResEvalValue;
@ -459,6 +461,7 @@ type
constructor CreateValue(const aValue: boolean); constructor CreateValue(const aValue: boolean);
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
TResEvalTypedInt = ( TResEvalTypedInt = (
@ -520,6 +523,7 @@ type
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function AsDebugString: string; override; function AsDebugString: string; override;
function TypeAsString: string; override;
end; end;
{ TResEvalUInt } { TResEvalUInt }
@ -531,6 +535,7 @@ type
constructor CreateValue(const aValue: TMaxPrecUInt); constructor CreateValue(const aValue: TMaxPrecUInt);
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
{ TResEvalFloat } { TResEvalFloat }
@ -543,6 +548,7 @@ type
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function IsInt(out Int: TMaxPrecInt): boolean; function IsInt(out Int: TMaxPrecInt): boolean;
function TypeAsString: string; override;
end; end;
{ TResEvalCurrency } { TResEvalCurrency }
@ -556,6 +562,7 @@ type
function AsString: string; override; function AsString: string; override;
function IsInt(out Int: TMaxPrecInt): boolean; function IsInt(out Int: TMaxPrecInt): boolean;
function AsInt: TMaxPrecInt; // value * 10.000 function AsInt: TMaxPrecInt; // value * 10.000
function TypeAsString: string; override;
end; end;
{$ifdef FPC_HAS_CPSTRING} {$ifdef FPC_HAS_CPSTRING}
@ -569,6 +576,7 @@ type
constructor CreateValue(const aValue: RawByteString); constructor CreateValue(const aValue: RawByteString);
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
{$endif} {$endif}
@ -581,6 +589,7 @@ type
constructor CreateValue(const aValue: UnicodeString); constructor CreateValue(const aValue: UnicodeString);
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
{ TResEvalEnum - Kind=revkEnum, Value.Int } { TResEvalEnum - Kind=revkEnum, Value.Int }
@ -596,6 +605,7 @@ type
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsDebugString: string; override; function AsDebugString: string; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
TRESetElKind = ( TRESetElKind = (
@ -620,6 +630,7 @@ type
function AsString: string; override; function AsString: string; override;
function AsDebugString: string; override; function AsDebugString: string; override;
function ElementAsString(El: TMaxPrecInt): string; virtual; function ElementAsString(El: TMaxPrecInt): string; virtual;
function TypeAsString: string; override;
end; end;
{ TResEvalRangeUInt } { TResEvalRangeUInt }
@ -631,6 +642,7 @@ type
constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt); constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt);
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
{ TResEvalSet - Kind=revkSetOfInt } { TResEvalSet - Kind=revkSetOfInt }
@ -652,6 +664,7 @@ type
const aRangeStart, aRangeEnd: TMaxPrecInt); override; const aRangeStart, aRangeEnd: TMaxPrecInt); override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored
function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer; function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer;
function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range
@ -665,6 +678,7 @@ type
constructor Create; override; constructor Create; override;
function Clone: TResEvalValue; override; function Clone: TResEvalValue; override;
function AsString: string; override; function AsString: string; override;
function TypeAsString: string; override;
end; end;
TResEvalFlag = ( TResEvalFlag = (
@ -1188,6 +1202,11 @@ begin
Result:=inherited AsString; Result:=inherited AsString;
end; end;
function TResEvalExternal.TypeAsString: string;
begin
Result:='external value';
end;
{ TResEvalCurrency } { TResEvalCurrency }
constructor TResEvalCurrency.Create; constructor TResEvalCurrency.Create;
@ -1231,6 +1250,11 @@ begin
{$endif}; {$endif};
end; end;
function TResEvalCurrency.TypeAsString: string;
begin
Result:='currency';
end;
{ TResEvalBool } { TResEvalBool }
constructor TResEvalBool.Create; constructor TResEvalBool.Create;
@ -1259,6 +1283,11 @@ begin
Result:='false'; Result:='false';
end; end;
function TResEvalBool.TypeAsString: string;
begin
Result:='boolean';
end;
{ TResEvalRangeUInt } { TResEvalRangeUInt }
constructor TResEvalRangeUInt.Create; constructor TResEvalRangeUInt.Create;
@ -1287,6 +1316,11 @@ begin
Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd); Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd);
end; end;
function TResEvalRangeUInt.TypeAsString: string;
begin
Result:='unsigned integer range';
end;
{ TResExprEvaluator } { TResExprEvaluator }
procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType;
@ -5615,6 +5649,15 @@ begin
end; end;
end; end;
function TResEvalValue.TypeAsString: string;
begin
case Kind of
revkNil: Result:='nil';
else
Result:='';
end;
end;
{ TResEvalUInt } { TResEvalUInt }
constructor TResEvalUInt.Create; constructor TResEvalUInt.Create;
@ -5640,6 +5683,11 @@ begin
Result:=IntToStr(UInt); Result:=IntToStr(UInt);
end; end;
function TResEvalUInt.TypeAsString: string;
begin
Result:='unsigned int';
end;
{ TResEvalInt } { TResEvalInt }
constructor TResEvalInt.Create; constructor TResEvalInt.Create;
@ -5697,6 +5745,24 @@ begin
end; end;
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 } { TResEvalFloat }
constructor TResEvalFloat.Create; constructor TResEvalFloat.Create;
@ -5732,6 +5798,11 @@ begin
Result:=true; Result:=true;
end; end;
function TResEvalFloat.TypeAsString: string;
begin
Result:='float';
end;
{$ifdef FPC_HAS_CPSTRING} {$ifdef FPC_HAS_CPSTRING}
{ TResEvalString } { TResEvalString }
@ -5759,6 +5830,15 @@ function TResEvalString.AsString: string;
begin begin
Result:=RawStrToCaption(S,60); Result:=RawStrToCaption(S,60);
end; end;
function TResEvalString.TypeAsString: string;
begin
if OnlyASCII then
Result:='string'
else
Result:='ansistring';
end;
{$endif} {$endif}
{ TResEvalUTF16 } { TResEvalUTF16 }
@ -5786,6 +5866,11 @@ begin
Result:=String(UnicodeStrToCaption(S,60)); Result:=String(UnicodeStrToCaption(S,60));
end; end;
function TResEvalUTF16.TypeAsString: string;
begin
Result:='unicodestring';
end;
{ TResEvalEnum } { TResEvalEnum }
constructor TResEvalEnum.Create; constructor TResEvalEnum.Create;
@ -5849,6 +5934,13 @@ begin
Result:=ElType.Name+'('+IntToStr(Index)+')'; Result:=ElType.Name+'('+IntToStr(Index)+')';
end; end;
function TResEvalEnum.TypeAsString: string;
begin
Result:=ElType.Name;
if Result='' then
Result:='enum';
end;
{ TResEvalRangeInt } { TResEvalRangeInt }
constructor TResEvalRangeInt.Create; constructor TResEvalRangeInt.Create;
@ -5920,6 +6012,18 @@ begin
end; end;
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 } { TResEvalSet }
constructor TResEvalSet.Create; constructor TResEvalSet.Create;
@ -5980,6 +6084,11 @@ begin
Result:=Result+']'; Result:=Result+']';
end; end;
function TResEvalSet.TypeAsString: string;
begin
Result:='set';
end;
function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean;
{$IF FPC_FULLVERSION<30101} {$IF FPC_FULLVERSION<30101}

View File

@ -1698,6 +1698,7 @@ type
procedure FinishAncestors(aClass: TPasClassType); virtual; procedure FinishAncestors(aClass: TPasClassType); virtual;
procedure FinishMethodResolution(El: TPasMethodResolution); virtual; procedure FinishMethodResolution(El: TPasMethodResolution); virtual;
procedure FinishAttributes(El: TPasAttributes); virtual; procedure FinishAttributes(El: TPasAttributes); virtual;
procedure FinishExportSymbol(El: TPasExportSymbol); virtual;
procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual; procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual;
procedure FinishPropertyParamAccess(Params: TParamsExpr; procedure FinishPropertyParamAccess(Params: TParamsExpr;
Prop: TPasProperty); virtual; Prop: TPasProperty); virtual;
@ -5826,6 +5827,7 @@ begin
FinishSection(TPasLibrary(CurModule).LibrarySection); FinishSection(TPasLibrary(CurModule).LibrarySection);
// resolve begin..end block // resolve begin..end block
ResolveImplBlock(CurModule.InitializationSection); ResolveImplBlock(CurModule.InitializationSection);
ResolveImplBlock(CurModule.FinalizationSection);
end end
else if (CurModuleClass=TPasModule) then else if (CurModuleClass=TPasModule) then
begin begin
@ -7776,6 +7778,8 @@ begin
FinishMethodResolution(TPasMethodResolution(El)) FinishMethodResolution(TPasMethodResolution(El))
else if C=TPasAttributes then else if C=TPasAttributes then
FinishAttributes(TPasAttributes(El)) FinishAttributes(TPasAttributes(El))
else if C=TPasExportSymbol then
FinishExportSymbol(TPasExportSymbol(El))
else else
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
@ -9133,6 +9137,31 @@ begin
end; end;
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; procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType;
Params: TParamsExpr); Params: TParamsExpr);
var var
@ -20836,6 +20865,7 @@ begin
else if AClass.InheritsFrom(TPasImplBlock) then else if AClass.InheritsFrom(TPasImplBlock) then
// resolved when finished // resolved when finished
else if AClass=TPasAttributes then else if AClass=TPasAttributes then
else if AClass=TPasExportSymbol then
else if AClass=TPasUnresolvedUnitRef then else if AClass=TPasUnresolvedUnitRef then
RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El) RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
else else

View File

@ -447,6 +447,7 @@ type
PackageName: string; PackageName: string;
Filename : String; // the IN filename, only written when not empty. Filename : String; // the IN filename, only written when not empty.
end; end;
TPasModuleClass = class of TPasModule;
{ TPasUnitModule } { TPasUnitModule }

View File

@ -4360,6 +4360,7 @@ begin
end; end;
if not (CurToken in [tkComma,tkSemicolon]) then if not (CurToken in [tkComma,tkSemicolon]) then
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
Engine.FinishScope(stDeclaration,E);
until (CurToken=tkSemicolon); until (CurToken=tkSemicolon);
end; end;

View File

@ -142,7 +142,9 @@ type
Procedure TearDown; override; Procedure TearDown; override;
procedure CreateEngine(var TheEngine: TPasTreeContainer); override; procedure CreateEngine(var TheEngine: TPasTreeContainer); override;
procedure ParseModule; override; procedure ParseModule; override;
procedure ParseMain(ExpectedModuleClass: TPasModuleClass); virtual;
procedure ParseProgram; virtual; procedure ParseProgram; virtual;
procedure ParseLibrary; virtual;
procedure ParseUnit; virtual; procedure ParseUnit; virtual;
procedure CheckReferenceDirectives; virtual; procedure CheckReferenceDirectives; virtual;
procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer; procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer;
@ -172,6 +174,7 @@ type
ImplementationSrc: string): TTestEnginePasResolver; ImplementationSrc: string): TTestEnginePasResolver;
procedure AddSystemUnit(Parts: TSystemUnitParts = []); procedure AddSystemUnit(Parts: TSystemUnitParts = []);
procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []);
procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []);
procedure StartUnit(NeedSystemUnit: boolean); procedure StartUnit(NeedSystemUnit: boolean);
property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
property ModuleCount: integer read GetModuleCount; property ModuleCount: integer read GetModuleCount;
@ -975,6 +978,15 @@ type
Procedure TestAttributes_NonConstParam_Fail; Procedure TestAttributes_NonConstParam_Fail;
Procedure TestAttributes_UnknownAttrWarning; Procedure TestAttributes_UnknownAttrWarning;
Procedure TestAttributes_Members; 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; end;
function LinesToStr(Args: array of const): string; function LinesToStr(Args: array of const): string;
@ -1193,7 +1205,7 @@ begin
end; end;
end; end;
procedure TCustomTestResolver.ParseProgram; procedure TCustomTestResolver.ParseMain(ExpectedModuleClass: TPasModuleClass);
var var
aFilename: String; aFilename: String;
aRow, aCol: Integer; aRow, aCol: Integer;
@ -1208,7 +1220,7 @@ begin
aRow:=E.Row; aRow:=E.Row;
aCol:=E.Column; aCol:=E.Column;
WriteSources(aFilename,aRow,aCol); 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' ' Scanner at'
+' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')' +' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'
+' Line="'+Scanner.CurLine+'"'); +' Line="'+Scanner.CurLine+'"');
@ -1225,17 +1237,22 @@ begin
ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol); ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol);
end; end;
WriteSources(aFilename,aRow,aCol); 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)+')'); +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')');
Fail(E.Message); Fail(E.Message);
end; end;
on E: Exception do on E: Exception do
begin begin
writeln('ERROR: TTestResolver.ParseProgram Exception: '+E.ClassName+':'+E.Message); writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Exception: '+E.ClassName+':'+E.Message);
Fail(E.Message); Fail(E.Message);
end; end;
end; end;
TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine); TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine);
end;
procedure TCustomTestResolver.ParseProgram;
begin
ParseMain(TPasProgram);
AssertEquals('Has program',TPasProgram,Module.ClassType); AssertEquals('Has program',TPasProgram,Module.ClassType);
AssertNotNull('Has program section',PasProgram.ProgramSection); AssertNotNull('Has program section',PasProgram.ProgramSection);
AssertNotNull('Has initialization section',PasProgram.InitializationSection); AssertNotNull('Has initialization section',PasProgram.InitializationSection);
@ -1245,39 +1262,18 @@ begin
CheckReferenceDirectives; CheckReferenceDirectives;
end; 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; procedure TCustomTestResolver.ParseUnit;
begin begin
FFirstStatement:=nil; ParseMain(TPasModule);
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);
AssertEquals('Has unit',TPasModule,Module.ClassType); AssertEquals('Has unit',TPasModule,Module.ClassType);
AssertNotNull('Has interface section',Module.InterfaceSection); AssertNotNull('Has interface section',Module.InterfaceSection);
AssertNotNull('Has implementation section',Module.ImplementationSection); AssertNotNull('Has implementation section',Module.ImplementationSection);
@ -2333,6 +2329,16 @@ begin
Add('program '+ExtractFileUnitName(MainFilename)+';'); Add('program '+ExtractFileUnitName(MainFilename)+';');
end; 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); procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean);
begin begin
if NeedSystemUnit then if NeedSystemUnit then
@ -3623,7 +3629,7 @@ begin
' m=low(char)+high(char);', ' m=low(char)+high(char);',
' n = string(''A'');', ' n = string(''A'');',
' o = UnicodeString(''A'');', ' o = UnicodeString(''A'');',
//' p = ^C''bird'';', ' p = ^C''bird'';',
'begin']); 'begin']);
ParseProgram; ParseProgram;
CheckResolverUnexpectedHints; CheckResolverUnexpectedHints;
@ -18738,6 +18744,95 @@ begin
CheckAttributeMarkers; CheckAttributeMarkers;
end; 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 initialization
RegisterTests([TTestResolver]); RegisterTests([TTestResolver]);

View File

@ -1,16 +1,21 @@
{ %OPT=-O3 -Sew -vw }
{$mode objfpc} {$mode objfpc}
{$inline on} {$inline on}
procedure test; inline; procedure mymove(var src,dst; len: ptrint); inline;
begin begin
if len<=0 then
exit; exit;
end; end;
function f: longint;
function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
var
p : pchar;
begin begin
test; // tt.pp(11,3) Warning: Function result variable does not seem to be initialized getmem(p,length1+length2+1);
result:=4; mymove(p1[0],p[0],length1);
mymove(p2[0],p[length1],length2+1);
concatansistrings:=p;
end; end;
begin begin

43
tests/webtbs/tw38267a.pp Normal file
View File

@ -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.