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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48134 -
This commit is contained in:
nickysn 2021-01-11 07:01:01 +00:00
commit 8b4aceea50
26 changed files with 1245 additions and 809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -16740,6 +16740,7 @@ tests/webtbf/tw36720.pp svneol=native#text/pascal
tests/webtbf/tw3680.pp svneol=native#text/plain tests/webtbf/tw3680.pp svneol=native#text/plain
tests/webtbf/tw36975.pp svneol=native#text/pascal tests/webtbf/tw36975.pp svneol=native#text/pascal
tests/webtbf/tw3716.pp svneol=native#text/plain tests/webtbf/tw3716.pp svneol=native#text/plain
tests/webtbf/tw37217.pp svneol=native#text/pascal
tests/webtbf/tw37272b.pp svneol=native#text/pascal tests/webtbf/tw37272b.pp svneol=native#text/pascal
tests/webtbf/tw37303.pp -text svneol=native#text/pascal tests/webtbf/tw37303.pp -text svneol=native#text/pascal
tests/webtbf/tw3738.pp svneol=native#text/plain tests/webtbf/tw3738.pp svneol=native#text/plain
@ -18687,7 +18688,10 @@ tests/webtbs/tw38309.pp svneol=native#text/pascal
tests/webtbs/tw38310a.pp svneol=native#text/pascal tests/webtbs/tw38310a.pp svneol=native#text/pascal
tests/webtbs/tw38310b.pp svneol=native#text/pascal tests/webtbs/tw38310b.pp svneol=native#text/pascal
tests/webtbs/tw38310c.pp svneol=native#text/pascal tests/webtbs/tw38310c.pp svneol=native#text/pascal
tests/webtbs/tw38316.pp svneol=native#text/plain
tests/webtbs/tw3833.pp svneol=native#text/plain tests/webtbs/tw3833.pp svneol=native#text/plain
tests/webtbs/tw38337.pp svneol=native#text/plain
tests/webtbs/tw38339.pp svneol=native#text/plain
tests/webtbs/tw3840.pp svneol=native#text/plain tests/webtbs/tw3840.pp svneol=native#text/plain
tests/webtbs/tw3841.pp svneol=native#text/plain tests/webtbs/tw3841.pp svneol=native#text/plain
tests/webtbs/tw3863.pp svneol=native#text/plain tests/webtbs/tw3863.pp svneol=native#text/plain

10
compiler/aoptobj.pas
View File

@ -1382,12 +1382,10 @@ Unit AoptObj;
removedSomething := false; removedSomething := false;
firstRemovedWasAlloc := false; firstRemovedWasAlloc := false;
{$ifdef allocregdebug} {$ifdef allocregdebug}
hp := tai_comment.Create(strpnew('allocating '+std_regname(newreg(R_INTREGISTER,supreg,R_SUBWHOLE))+ hp := tai_comment.Create(strpnew('allocating '+std_regname(reg)+' from here...'));
' from here...')); insertllitem(p1.previous,p1,hp);
insertllitem(asml,p1.previous,p1,hp); hp := tai_comment.Create(strpnew('allocated '+std_regname(reg)+' till here...'));
hp := tai_comment.Create(strpnew('allocated '+std_regname(newreg(R_INTREGISTER,supreg,R_SUBWHOLE))+ insertllitem(p2,p2.next,hp);
' till here...'));
insertllitem(asml,p2,p2.next,hp);
{$endif allocregdebug} {$endif allocregdebug}
{ do it the safe way: always allocate the full super register, { do it the safe way: always allocate the full super register,
as we do no register re-allocation in the peephole optimizer, as we do no register re-allocation in the peephole optimizer,

25
compiler/fpcdefs.inc
View File

@ -31,6 +31,31 @@
{$define USEINLINE} {$define USEINLINE}
{$endif EXTDEBUG} {$endif EXTDEBUG}
{$ifdef DEBUG_ALL_OPT}
{ for aopt unit }
{$define DEBUG_OPTALLOC}
{$define DEBUG_INSTRUCTIONREGISTERDEPENDENCIES}
{for CPU/aoptcpu unit }
{$define DEBUG_AOPTCPU}
{$define DEBUG_PREREGSCHEDULER (arm specific) }
{ for aoptobj unit }
{$define DEBUG_AOPTOBJ}
{$define ALLOCREGDEBUG}
{ for optconstprop unit }
{$define DEBUG_CONSTPROP}
{ for optcse unit }
{$define CSEDEBUG}
{ for optdeadstore unit }
{$define DEBUG_DEADSTORE}
{ for optdfa unit }
{$define DEBUG_DFA}
{ for optloop unit }
{$define DEBUG_OPTFORLOOP}
{$define DEBUG_OPTSTRENGTH}
{ for optvirt unit }
{$define DEBUG_DEVIRT}
{$endif}
{$define USEEXCEPT} {$define USEEXCEPT}
{$ifdef VER3_0} {$ifdef VER3_0}

2
compiler/i386/aoptcpu.pas
View File

@ -137,6 +137,8 @@ unit aoptcpu;
if InsContainsSegRef(taicpu(p)) then if InsContainsSegRef(taicpu(p)) then
exit; exit;
case taicpu(p).opcode Of case taicpu(p).opcode Of
A_ADD:
Result:=OptPass1ADD(p);
A_AND: A_AND:
Result:=OptPass1And(p); Result:=OptPass1And(p);
A_IMUL: A_IMUL:

4
compiler/msg/errore.msg
View File

@ -1555,7 +1555,7 @@ parser_w_ptr_type_ignored=03338_W_Pointer type "$1" ignored
% The specified pointer type modifier is ignored, because it is not supported on % The specified pointer type modifier is ignored, because it is not supported on
% the current platform. This happens, for example, when a far pointer is % the current platform. This happens, for example, when a far pointer is
% declared on a non-x86 platform. % declared on a non-x86 platform.
parser_e_global_generic_references_static=03339_E_Global Generic template references static symtable parser_e_global_generic_references_static=03339_E_Generic template in interface section references symbol in implementation section
% A generic declared in the interface section of a unit must not reference symbols that belong % A generic declared in the interface section of a unit must not reference symbols that belong
% solely to the implementation section of that unit. % solely to the implementation section of that unit.
parser_u_already_compiled=03340_UL_Unit $1 has been already compiled meanwhile. parser_u_already_compiled=03340_UL_Unit $1 has been already compiled meanwhile.
@ -1622,6 +1622,8 @@ parser_e_location_regpair_only_data=03358_E_Only data registers are supported fo
% AmigaOS/MorphOS syscall specific: for 64bit register pairs, only data registers are supported % AmigaOS/MorphOS syscall specific: for 64bit register pairs, only data registers are supported
parser_e_location_regpair_only_consecutive=03359_E_Only consecutive registers are supported for explicit location register pairs parser_e_location_regpair_only_consecutive=03359_E_Only consecutive registers are supported for explicit location register pairs
% MorphOS syscall specific: only consecutive (f.e.: d1-d2) registers are supported for 64bit register pairs % MorphOS syscall specific: only consecutive (f.e.: d1-d2) registers are supported for 64bit register pairs
parser_e_constructurs_cannot_take_type_parameters=03360_E_Constructors cannot take type parameters
% The use of type parameters in constructors is not allowed.
% %
% \end{description} % \end{description}
% %

5
compiler/msgidx.inc
View File

@ -471,6 +471,7 @@ const
parser_e_location_size_too_large=03357; parser_e_location_size_too_large=03357;
parser_e_location_regpair_only_data=03358; parser_e_location_regpair_only_data=03358;
parser_e_location_regpair_only_consecutive=03359; parser_e_location_regpair_only_consecutive=03359;
parser_e_constructurs_cannot_take_type_parameters=03360;
type_e_mismatch=04000; type_e_mismatch=04000;
type_e_incompatible_types=04001; type_e_incompatible_types=04001;
type_e_not_equal_types=04002; type_e_not_equal_types=04002;
@ -1135,9 +1136,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 86847; MsgTxtSize = 86927;
MsgIdxMax : array[1..20] of longint=( MsgIdxMax : array[1..20] of longint=(
28,107,360,130,99,63,145,36,223,68, 28,107,361,130,99,63,145,36,223,68,
63,20,30,1,1,1,1,1,1,1 63,20,30,1,1,1,1,1,1,1
); );

1262
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

3
compiler/ncal.pas
View File

@ -928,7 +928,10 @@ implementation
reused above) } reused above) }
left:=ctemprefnode.create(paratemp); left:=ctemprefnode.create(paratemp);
end; end;
{ add the finish statements to the call cleanup block }
addstatement(finistat,ctempdeletenode.create(paratemp)); addstatement(finistat,ctempdeletenode.create(paratemp));
aktcallnode.add_done_statement(finiblock);
firstpass(fparainit); firstpass(fparainit);
firstpass(left); firstpass(left);
end; end;

107
compiler/pdecsub.pas
View File

@ -1133,61 +1133,70 @@ implementation
if assigned(genericparams) then if assigned(genericparams) then
begin begin
include(pd.defoptions,df_generic); if potype=potype_constructor then
{ push the parameter symtable so that constraint definitions are added
there and not in the owner symtable }
symtablestack.push(pd.parast);
{ register the parameters }
for i:=0 to genericparams.count-1 do
begin begin
tsym(genericparams[i]).register_sym; Message(parser_e_constructurs_cannot_take_type_parameters);
if tsym(genericparams[i]).typ=typesym then genericparams.free;
tstoreddef(ttypesym(genericparams[i]).typedef).register_def; genericparams:=nil;
end; end
insert_generic_parameter_types(pd,nil,genericparams);
{ the list is no longer required }
genericparams.free;
genericparams:=nil;
symtablestack.pop(pd.parast);
parse_generic:=true;
{ also generate a dummy symbol if none exists already }
if assigned(astruct) then
dummysym:=tsym(astruct.symtable.find(spnongen))
else else
begin begin
dummysym:=tsym(symtablestack.top.find(spnongen)); include(pd.defoptions,df_generic);
if not assigned(dummysym) and { push the parameter symtable so that constraint definitions are added
(symtablestack.top=current_module.localsymtable) and there and not in the owner symtable }
assigned(current_module.globalsymtable) then symtablestack.push(pd.parast);
dummysym:=tsym(current_module.globalsymtable.find(spnongen)); { register the parameters }
end; for i:=0 to genericparams.count-1 do
if not assigned(dummysym) then begin
begin tsym(genericparams[i]).register_sym;
{ overloading generic routines with non-generic types is not if tsym(genericparams[i]).typ=typesym then
allowed, so we create a procsym as dummy } tstoreddef(ttypesym(genericparams[i]).typedef).register_def;
dummysym:=cprocsym.create(orgspnongen); end;
insert_generic_parameter_types(pd,nil,genericparams);
{ the list is no longer required }
genericparams.free;
genericparams:=nil;
symtablestack.pop(pd.parast);
parse_generic:=true;
{ also generate a dummy symbol if none exists already }
if assigned(astruct) then if assigned(astruct) then
astruct.symtable.insert(dummysym) dummysym:=tsym(astruct.symtable.find(spnongen))
else else
symtablestack.top.insert(dummysym); begin
end dummysym:=tsym(symtablestack.top.find(spnongen));
else if (dummysym.typ<>procsym) and if not assigned(dummysym) and
( (symtablestack.top=current_module.localsymtable) and
{ show error only for the declaration, not also the implementation } assigned(current_module.globalsymtable) then
not assigned(astruct) or dummysym:=tsym(current_module.globalsymtable.find(spnongen));
(symtablestack.top.symtablelevel<>main_program_level) end;
) then if not assigned(dummysym) then
Message1(sym_e_duplicate_id,dummysym.realname); begin
if not (sp_generic_dummy in dummysym.symoptions) then { overloading generic routines with non-generic types is not
begin allowed, so we create a procsym as dummy }
include(dummysym.symoptions,sp_generic_dummy); dummysym:=cprocsym.create(orgspnongen);
add_generic_dummysym(dummysym); if assigned(astruct) then
astruct.symtable.insert(dummysym)
else
symtablestack.top.insert(dummysym);
end
else if (dummysym.typ<>procsym) and
(
{ show error only for the declaration, not also the implementation }
not assigned(astruct) or
(symtablestack.top.symtablelevel<>main_program_level)
) then
Message1(sym_e_duplicate_id,dummysym.realname);
if not (sp_generic_dummy in dummysym.symoptions) then
begin
include(dummysym.symoptions,sp_generic_dummy);
add_generic_dummysym(dummysym);
end;
if dummysym.typ=procsym then
tprocsym(dummysym).add_generic_overload(aprocsym);
{ start token recorder for the declaration }
pd.init_genericdecl;
current_scanner.startrecordtokens(pd.genericdecltokenbuf);
end; end;
if dummysym.typ=procsym then
tprocsym(dummysym).add_generic_overload(aprocsym);
{ start token recorder for the declaration }
pd.init_genericdecl;
current_scanner.startrecordtokens(pd.genericdecltokenbuf);
end end
else if assigned(genericdef) then else if assigned(genericdef) then
insert_generic_parameter_types(pd,tstoreddef(genericdef),generictypelist); insert_generic_parameter_types(pd,tstoreddef(genericdef),generictypelist);

74
compiler/x86/aoptx86.pas
View File

@ -122,6 +122,7 @@ unit aoptx86;
function PrePeepholeOptSxx(var p : tai) : boolean; function PrePeepholeOptSxx(var p : tai) : boolean;
function PrePeepholeOptIMUL(var p : tai) : boolean; function PrePeepholeOptIMUL(var p : tai) : boolean;
function OptPass1Add(var p: tai): boolean;
function OptPass1AND(var p : tai) : boolean; function OptPass1AND(var p : tai) : boolean;
function OptPass1_V_MOVAP(var p : tai) : boolean; function OptPass1_V_MOVAP(var p : tai) : boolean;
function OptPass1VOP(var p : tai) : boolean; function OptPass1VOP(var p : tai) : boolean;
@ -3171,6 +3172,42 @@ unit aoptx86;
end; end;
function TX86AsmOptimizer.OptPass1Add(var p : tai) : boolean;
var
hp1 : tai;
begin
result:=false;
{ replace
addX const,%reg1
leaX (%reg1,%reg1,Y),%reg2 // Base or index might not be equal to reg1
dealloc %reg1
by
leaX const+const*Y(%reg1,%reg1,Y),%reg2
}
if MatchOpType(taicpu(p),top_const,top_reg) and
GetNextInstruction(p,hp1) and
MatchInstruction(hp1,A_LEA,[taicpu(p).opsize]) and
((taicpu(p).oper[1]^.reg=taicpu(hp1).oper[0]^.ref^.base) or
(taicpu(p).oper[1]^.reg=taicpu(hp1).oper[0]^.ref^.index)) then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
begin
DebugMsg(SPeepholeOptimization + 'AddLea2Lea done',p);
if taicpu(p).oper[1]^.reg=taicpu(hp1).oper[0]^.ref^.base then
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.val);
if taicpu(p).oper[1]^.reg=taicpu(hp1).oper[0]^.ref^.index then
inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.val*max(taicpu(hp1).oper[0]^.ref^.scalefactor,1));
RemoveCurrentP(p);
result:=true;
end;
end;
end;
function TX86AsmOptimizer.OptPass1LEA(var p : tai) : boolean; function TX86AsmOptimizer.OptPass1LEA(var p : tai) : boolean;
var var
hp1, hp2, hp3: tai; hp1, hp2, hp3: tai;
@ -3350,7 +3387,11 @@ unit aoptx86;
) or ) or
((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and ((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
(taicpu(hp1).oper[0]^.ref^.scalefactor <= 1) and (taicpu(hp1).oper[0]^.ref^.scalefactor <= 1) and
(taicpu(p).oper[0]^.ref^.base=NR_NO) and ((taicpu(p).oper[0]^.ref^.base=NR_NO) or
((taicpu(p).oper[0]^.ref^.base=taicpu(p).oper[0]^.ref^.base) and
(taicpu(p).oper[0]^.ref^.index=NR_NO)
)
) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1))) not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1)))
) and ) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
@ -4945,7 +4986,7 @@ unit aoptx86;
MinSize, MaxSize, TrySmaller, TargetSize: TOpSize; MinSize, MaxSize, TrySmaller, TargetSize: TOpSize;
TargetSubReg: TSubRegister; TargetSubReg: TSubRegister;
hp1, hp2: tai; hp1, hp2: tai;
RegInUse, p_removed: Boolean; RegInUse, RegChanged, p_removed: Boolean;
{ Store list of found instructions so we don't have to call { Store list of found instructions so we don't have to call
GetNextInstructionUsingReg multiple times } GetNextInstructionUsingReg multiple times }
@ -4995,6 +5036,7 @@ unit aoptx86;
TrySmallerLimit := UpperLimit; TrySmallerLimit := UpperLimit;
TrySmaller := S_NO; TrySmaller := S_NO;
SmallerOverflow := False; SmallerOverflow := False;
RegChanged := False;
while GetNextInstructionUsingReg(hp1, hp1, ThisReg) and while GetNextInstructionUsingReg(hp1, hp1, ThisReg) and
(hp1.typ = ait_instruction) and (hp1.typ = ait_instruction) and
@ -5377,6 +5419,7 @@ unit aoptx86;
begin begin
DebugMsg(SPeepholeOptimization + 'Simplified register usage so ' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' = ' + debug_regname(taicpu(p).oper[1]^.reg), p); DebugMsg(SPeepholeOptimization + 'Simplified register usage so ' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' = ' + debug_regname(taicpu(p).oper[1]^.reg), p);
ThisReg := taicpu(hp1).oper[1]^.reg; ThisReg := taicpu(hp1).oper[1]^.reg;
RegChanged := True;
TransferUsedRegs(TmpUsedRegs); TransferUsedRegs(TmpUsedRegs);
AllocRegBetween(ThisReg, p, hp1, TmpUsedRegs); AllocRegBetween(ThisReg, p, hp1, TmpUsedRegs);
@ -5411,9 +5454,12 @@ unit aoptx86;
{ Now go through every instruction we found and change the { Now go through every instruction we found and change the
size. If TargetSize = MaxSize, then almost no changes are size. If TargetSize = MaxSize, then almost no changes are
needed and Result can remain False if it hasn't been set needed and Result can remain False if it hasn't been set
yet. } yet.
if (TargetSize <> MaxSize) and (InstrMax >= 0) then If RegChanged is True, then the register requires changing
and so the point about TargetSize = MaxSize doesn't apply. }
if ((TargetSize <> MaxSize) or RegChanged) and (InstrMax >= 0) then
begin begin
for Index := 0 to InstrMax do for Index := 0 to InstrMax do
begin begin
@ -5647,6 +5693,7 @@ unit aoptx86;
symbol: TAsmSymbol; symbol: TAsmSymbol;
reg: tsuperregister; reg: tsuperregister;
regavailable: Boolean; regavailable: Boolean;
tmpreg: TRegister;
begin begin
result:=false; result:=false;
symbol:=nil; symbol:=nil;
@ -5750,17 +5797,16 @@ unit aoptx86;
((Taicpu(hp1).opcode=A_INC) or (Taicpu(hp1).opcode=A_DEC)) ((Taicpu(hp1).opcode=A_INC) or (Taicpu(hp1).opcode=A_DEC))
) then ) then
begin begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
{ search for an available register which is volatile } { search for an available register which is volatile }
regavailable:=false; regavailable:=false;
for reg in tcpuregisterset do for reg in tcpuregisterset do
begin begin
tmpreg:=newreg(R_INTREGISTER,reg,R_SUBL);
if (reg in paramanager.get_volatile_registers_int(current_procinfo.procdef.proccalloption)) and if (reg in paramanager.get_volatile_registers_int(current_procinfo.procdef.proccalloption)) and
not(reg in TmpUsedRegs[R_INTREGISTER].GetUsedRegs) and not(reg in UsedRegs[R_INTREGISTER].GetUsedRegs) and
not(RegInInstruction(newreg(R_INTREGISTER,reg,R_SUBL),hp1)) not(RegInInstruction(tmpreg,hp1))
{$ifdef i386} {$ifdef i386}
{ use only registers which can be accessed byte wise }
and (reg in [RS_EAX,RS_EBX,RS_ECX,RS_EDX]) and (reg in [RS_EAX,RS_EBX,RS_ECX,RS_EDX])
{$endif i386} {$endif i386}
then then
@ -5772,23 +5818,24 @@ unit aoptx86;
if regavailable then if regavailable then
begin begin
TAsmLabel(symbol).decrefs;
Taicpu(p).clearop(0); Taicpu(p).clearop(0);
Taicpu(p).ops:=1; Taicpu(p).ops:=1;
Taicpu(p).is_jmp:=false; Taicpu(p).is_jmp:=false;
Taicpu(p).opcode:=A_SETcc; Taicpu(p).opcode:=A_SETcc;
DebugMsg(SPeepholeOptimization+'JccAdd2SetccAdd',p); DebugMsg(SPeepholeOptimization+'JccAdd2SetccAdd',p);
Taicpu(p).condition:=inverse_cond(Taicpu(p).condition); Taicpu(p).condition:=inverse_cond(Taicpu(p).condition);
Taicpu(p).loadreg(0,newreg(R_INTREGISTER,reg,R_SUBL)); Taicpu(p).loadreg(0,tmpreg);
if getsubreg(Taicpu(hp1).oper[1]^.reg)<>R_SUBL then if getsubreg(Taicpu(hp1).oper[1]^.reg)<>R_SUBL then
begin begin
case getsubreg(Taicpu(hp1).oper[1]^.reg) of case getsubreg(Taicpu(hp1).oper[1]^.reg) of
R_SUBW: R_SUBW:
hp2:=Taicpu.op_reg_reg(A_MOVZX,S_BW,newreg(R_INTREGISTER,reg,R_SUBL), hp2:=Taicpu.op_reg_reg(A_MOVZX,S_BW,tmpreg,
newreg(R_INTREGISTER,reg,R_SUBW)); newreg(R_INTREGISTER,reg,R_SUBW));
R_SUBD, R_SUBD,
R_SUBQ: R_SUBQ:
hp2:=Taicpu.op_reg_reg(A_MOVZX,S_BL,newreg(R_INTREGISTER,reg,R_SUBL), hp2:=Taicpu.op_reg_reg(A_MOVZX,S_BL,tmpreg,
newreg(R_INTREGISTER,reg,R_SUBD)); newreg(R_INTREGISTER,reg,R_SUBD));
else else
Internalerror(2020030601); Internalerror(2020030601);
@ -7476,7 +7523,8 @@ unit aoptx86;
(taicpu(hp1).opcode = A_TEST) and MatchOperand(taicpu(hp1).oper[0]^, taicpu(hp1).oper[1]^) (taicpu(hp1).opcode = A_TEST) and MatchOperand(taicpu(hp1).oper[0]^, taicpu(hp1).oper[1]^)
) )
) and ) and
(reg2opsize(taicpu(hp1).oper[1]^.reg) <= reg2opsize(taicpu(p).oper[1]^.reg)) then (reg2opsize(taicpu(hp1).oper[1]^.reg) <= reg2opsize(taicpu(p).oper[1]^.reg)) and
SuperRegistersEqual(taicpu(p).oper[1]^.reg, taicpu(hp1).oper[1]^.reg) then
begin begin
PreMessage := debug_op2str(taicpu(hp1).opcode) + debug_opsize2str(taicpu(hp1).opsize) + ' ' + debug_operstr(taicpu(hp1).oper[0]^) + ',' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' -> ' + debug_op2str(taicpu(hp1).opcode); PreMessage := debug_op2str(taicpu(hp1).opcode) + debug_opsize2str(taicpu(hp1).opsize) + ' ' + debug_operstr(taicpu(hp1).oper[0]^) + ',' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' -> ' + debug_op2str(taicpu(hp1).opcode);

2
compiler/x86_64/aoptcpu.pas
View File

@ -71,6 +71,8 @@ uses
ait_instruction: ait_instruction:
begin begin
case taicpu(p).opcode of case taicpu(p).opcode of
A_ADD:
Result:=OptPass1ADD(p);
A_AND: A_AND:
Result:=OptPass1AND(p); Result:=OptPass1AND(p);
A_IMUL: A_IMUL:

37
packages/fcl-passrc/src/pasresolver.pp
View File

@ -9049,7 +9049,7 @@ begin
CurEl:=nil; CurEl:=nil;
if not SameText(RightStr(AttrName,length('Attribute')),'Attribute') then if not SameText(RightStr(AttrName,length('Attribute')),'Attribute') then
begin begin
// first search AttrName+'Attibute' // first search AttrName+'Attribute'
CurEl:=FindFirstEl(AttrName+'Attribute',Data,NameExpr); CurEl:=FindFirstEl(AttrName+'Attribute',Data,NameExpr);
end; end;
// then search the name // then search the name
@ -9164,12 +9164,14 @@ var
FindData: TPRFindData; FindData: TPRFindData;
Ref: TResolvedReference; Ref: TResolvedReference;
ResolvedEl: TPasResolverResult; ResolvedEl: TPasResolverResult;
Section: TPasSection;
Scope: TPasIdentifierScope;
ScopeIdent: TPasIdentifier;
begin begin
Expr:=El.NameExpr; Expr:=El.NameExpr;
if Expr<>nil then if Expr<>nil then
begin begin
ResolveExpr(Expr,rraRead); ResolveExpr(Expr,rraRead);
//ResolveGlobalSymbol(Expr);
ComputeElement(Expr,ResolvedEl,[rcConstant]); ComputeElement(Expr,ResolvedEl,[rcConstant]);
DeclEl:=ResolvedEl.IdentEl; DeclEl:=ResolvedEl.IdentEl;
if DeclEl=nil then if DeclEl=nil then
@ -9189,6 +9191,18 @@ begin
CheckFoundElement(FindData,Ref); CheckFoundElement(FindData,Ref);
end; end;
if DeclEl is TPasProcedure then
begin
Section:=DeclEl.Parent as TPasSection;
Scope:=Section.CustomData as TPasIdentifierScope;
ScopeIdent:=Scope.FindLocalIdentifier(DeclEl.Name);
if (ScopeIdent=nil) then
RaiseNotYetImplemented(20210106103001,El,GetObjPath(DeclEl));
if ScopeIdent.NextSameIdentifier<>nil then
RaiseMsg(20210106103320,nCantDetermineWhichOverloadedFunctionToCall,
sCantDetermineWhichOverloadedFunctionToCall,[],El);
end;
// check index and name // check index and name
CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer'); CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
CheckConstExpr(El.ExportName,[revkString,revkUnicodeString],'string'); CheckConstExpr(El.ExportName,[revkString,revkUnicodeString],'string');
@ -21318,7 +21332,7 @@ procedure TPasResolver.CheckFoundElement(
// Call this method after finding an element by searching the scopes. // Call this method after finding an element by searching the scopes.
function IsFieldInheritingConst(aRef: TResolvedReference): boolean; function IsFieldInheritingConst(aRef: TResolvedReference): boolean;
// returns true of aRef is a TPasVariable that inherits its const from parent. // returns true if aRef is a TPasVariable that inherits its const from parent.
// For example // For example
// type TRecord = record // type TRecord = record
// a: word; // inherits const // a: word; // inherits const
@ -27564,6 +27578,21 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
end; end;
end; end;
procedure ComputeExportSymbol(ExpSymbol: TPasExportSymbol);
var
Ref: TResolvedReference;
begin
if ExpSymbol.CustomData is TResolvedReference then
begin
Ref:=TResolvedReference(El.CustomData);
ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
end
else if ExpSymbol.NameExpr<>nil then
ComputeElement(ExpSymbol.NameExpr,ResolvedEl,Flags,StartEl)
else
RaiseNotYetImplemented(20210106225512,ExpSymbol);
end;
var var
DeclEl: TPasElement; DeclEl: TPasElement;
ElClass: TClass; ElClass: TClass;
@ -27946,6 +27975,8 @@ begin
ComputeSpecializeType(TPasSpecializeType(El)) ComputeSpecializeType(TPasSpecializeType(El))
else if ElClass=TInlineSpecializeExpr then else if ElClass=TInlineSpecializeExpr then
ComputeElement(TInlineSpecializeExpr(El).NameExpr,ResolvedEl,Flags,StartEl) ComputeElement(TInlineSpecializeExpr(El).NameExpr,ResolvedEl,Flags,StartEl)
else if ElClass=TPasExportSymbol then
ComputeExportSymbol(TPasExportSymbol(El))
else else
RaiseNotYetImplemented(20160922163705,El); RaiseNotYetImplemented(20160922163705,El);
{$IF defined(nodejs) and defined(VerbosePasResolver)} {$IF defined(nodejs) and defined(VerbosePasResolver)}

25
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -986,8 +986,8 @@ type
Procedure TestLibrary_ExportFunc_IndexStringFail; Procedure TestLibrary_ExportFunc_IndexStringFail;
Procedure TestLibrary_ExportVar; // ToDo Procedure TestLibrary_ExportVar; // ToDo
Procedure TestLibrary_Initialization_Finalization; Procedure TestLibrary_Initialization_Finalization;
Procedure TestLibrary_ExportFuncOverloadFail; // ToDo Procedure TestLibrary_ExportFuncOverloadFail;
// ToDo Procedure TestLibrary_UnitExports; Procedure TestLibrary_UnitExports;
end; end;
function LinesToStr(Args: array of const): string; function LinesToStr(Args: array of const): string;
@ -18836,8 +18836,6 @@ end;
procedure TTestResolver.TestLibrary_ExportFuncOverloadFail; procedure TTestResolver.TestLibrary_ExportFuncOverloadFail;
begin begin
exit;
StartLibrary(false); StartLibrary(false);
Add([ Add([
'procedure Run(w: word); overload;', 'procedure Run(w: word); overload;',
@ -18850,7 +18848,24 @@ begin
' Run,', ' Run,',
' afile.run;', ' afile.run;',
'begin']); 'begin']);
CheckResolverException('The symbol cannot be exported from a library',123); CheckResolverException(sCantDetermineWhichOverloadedFunctionToCall,
nCantDetermineWhichOverloadedFunctionToCall);
end;
procedure TTestResolver.TestLibrary_UnitExports;
begin
StartUnit(false);
Add([
'interface' ,
'procedure Run;',
'implementation',
'procedure Run;',
'begin',
'end;',
'exports',
' Run;',
'']);
ParseUnit;
end; end;
initialization initialization

3
packages/fv/src/views.pas
View File

@ -1905,7 +1905,8 @@ VAR S, D: Sw_Integer; Min, Max: TPoint;
PROCEDURE GrowI (Var I: Sw_Integer); PROCEDURE GrowI (Var I: Sw_Integer);
BEGIN BEGIN
If (GrowMode AND gfGrowRel = 0) Then Inc(I, D) If (GrowMode AND gfGrowRel = 0) Then Inc(I, D)
Else I := (I * S + (S - D) SHR 1) DIV (S - D); { Calc grow value } Else If S = D then I := 1
Else I := (I * S + (S - D) SHR 1) DIV (S - D); { Calc grow value }
END; END;
BEGIN BEGIN

240
packages/pastojs/src/fppas2js.pp
View File

@ -506,6 +506,7 @@ const
nDuplicateMessageIdXAtY = 4029; nDuplicateMessageIdXAtY = 4029;
nDispatchRequiresX = 4030; nDispatchRequiresX = 4030;
nConstRefNotForXAsConst = 4031; nConstRefNotForXAsConst = 4031;
nSymbolCannotBeExportedFromALibrary = 4032;
// resourcestring patterns of messages // resourcestring patterns of messages
resourcestring resourcestring
sPasElementNotSupported = 'Pascal element not supported: %s'; sPasElementNotSupported = 'Pascal element not supported: %s';
@ -539,6 +540,7 @@ resourcestring
sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s'; sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
sDispatchRequiresX = 'Dispatch requires %s'; sDispatchRequiresX = 'Dispatch requires %s';
sConstRefNotForXAsConst = 'ConstRef not yet implemented for %s. Treating as Const'; sConstRefNotForXAsConst = 'ConstRef not yet implemented for %s. Treating as Const';
sSymbolCannotBeExportedFromALibrary = 'The symbol cannot be exported from a library';
const const
ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@ -606,6 +608,7 @@ type
pbifnValEnum, pbifnValEnum,
pbifnFreeLocalVar, pbifnFreeLocalVar,
pbifnFreeVar, pbifnFreeVar,
pbifnLibraryMain,
pbifnOverflowCheckInt, pbifnOverflowCheckInt,
pbifnProcType_Create, pbifnProcType_Create,
pbifnProcType_CreateSafe, pbifnProcType_CreateSafe,
@ -671,6 +674,7 @@ type
pbivnImplCode, pbivnImplCode,
pbivnMessageInt, pbivnMessageInt,
pbivnMessageStr, pbivnMessageStr,
pbivnLibrary, // library
pbivnLocalModuleRef, pbivnLocalModuleRef,
pbivnLocalProcRef, pbivnLocalProcRef,
pbivnLocalTypeRef, pbivnLocalTypeRef,
@ -682,6 +686,7 @@ type
pbivnPtrClass, pbivnPtrClass,
pbivnPtrRecord, pbivnPtrRecord,
pbivnProcOk, pbivnProcOk,
pbivnProgram, // program
pbivnResourceStrings, pbivnResourceStrings,
pbivnResourceStringOrig, pbivnResourceStringOrig,
pbivnRTL, pbivnRTL,
@ -791,6 +796,7 @@ const
'valEnum', // pbifnValEnum rtl.valEnum 'valEnum', // pbifnValEnum rtl.valEnum
'freeLoc', // pbifnFreeLocalVar rtl.freeLoc 'freeLoc', // pbifnFreeLocalVar rtl.freeLoc
'free', // pbifnFreeVar rtl.free 'free', // pbifnFreeVar rtl.free
'$main', // pbifnLibraryMain
'oc', // pbifnOverflowCheckInt rtl.oc 'oc', // pbifnOverflowCheckInt rtl.oc
'createCallback', // pbifnProcType_Create rtl.createCallback 'createCallback', // pbifnProcType_Create rtl.createCallback
'createSafeCallback', // pbifnProcType_CreateSafe rtl.createSafeCallback 'createSafeCallback', // pbifnProcType_CreateSafe rtl.createSafeCallback
@ -855,6 +861,7 @@ const
'$implcode', // pbivnImplCode '$implcode', // pbivnImplCode
'$msgint', // pbivnMessageInt '$msgint', // pbivnMessageInt
'$msgstr', // pbivnMessageStr '$msgstr', // pbivnMessageStr
'library', // pbivnLibrary pas.library
'$lm', // pbivnLocalModuleRef '$lm', // pbivnLocalModuleRef
'$lp', // pbivnLocalProcRef '$lp', // pbivnLocalProcRef
'$lt', // pbivnLocalTypeRef '$lt', // pbivnLocalTypeRef
@ -866,6 +873,7 @@ const
'$class', // pbivnPtrClass, ClassType '$class', // pbivnPtrClass, ClassType
'$record', // pbivnPtrRecord, hidden recordtype '$record', // pbivnPtrRecord, hidden recordtype
'$ok', // pbivnProcOk '$ok', // pbivnProcOk
'program', // pbivnProgram pas.program
'$resourcestrings', // pbivnResourceStrings '$resourcestrings', // pbivnResourceStrings
'org', // pbivnResourceStringOrig 'org', // pbivnResourceStringOrig
'rtl', // pbivnRTL 'rtl', // pbivnRTL
@ -1538,6 +1546,7 @@ type
Params: TParamsExpr); override; Params: TParamsExpr); override;
procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty
); override; ); override;
procedure FinishExportSymbol(El: TPasExportSymbol); override;
procedure FindCreatorArrayOfConst(Args: TFPList; ErrorEl: TPasElement); procedure FindCreatorArrayOfConst(Args: TFPList; ErrorEl: TPasElement);
function FindProc_ArrLitToArrayOfConst(ErrorEl: TPasElement): TPasFunction; virtual; function FindProc_ArrLitToArrayOfConst(ErrorEl: TPasElement): TPasFunction; virtual;
function FindSystemExternalClassType(const aClassName, JSName: string; function FindSystemExternalClassType(const aClassName, JSName: string;
@ -2071,7 +2080,7 @@ type
Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual; Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual;
Procedure AddHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual; Procedure AddHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
Procedure AddImplHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual; Procedure AddImplHeaderStatement(JS: TJSElement; PosEl: TPasElement; aContext: TConvertContext); virtual;
Procedure AddDelayedInits(El: TPasProgram; Src: TJSSourceElements; AContext: TConvertContext); virtual; Procedure AddDelayedInits(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); virtual;
Procedure AddDelaySpecializeInit(El: TPasGenericType; Src: TJSSourceElements; AContext: TConvertContext); virtual; Procedure AddDelaySpecializeInit(El: TPasGenericType; Src: TJSSourceElements; AContext: TConvertContext); virtual;
// enum and sets // enum and sets
Function CreateReferencedSet(El: TPasElement; SetExpr: TJSElement): TJSElement; virtual; Function CreateReferencedSet(El: TPasElement; SetExpr: TJSElement): TJSElement; virtual;
@ -4880,6 +4889,41 @@ begin
FindCreatorArrayOfConst(Args,Params); FindCreatorArrayOfConst(Args,Params);
end; end;
procedure TPas2JSResolver.FinishExportSymbol(El: TPasExportSymbol);
var
ResolvedEl: TPasResolverResult;
DeclEl: TPasElement;
Proc: TPasProcedure;
begin
if El.Parent is TLibrarySection then
// ok
else
// everywhere else: not supported
RaiseMsg(20210106224720,nNotSupportedX,sNotSupportedX,['non library export'],El.ExportIndex);
if El.ExportIndex<>nil then
RaiseMsg(20210106223403,nNotSupportedX,sNotSupportedX,['export index'],El.ExportIndex);
inherited FinishExportSymbol(El);
ComputeElement(El,ResolvedEl,[]);
DeclEl:=ResolvedEl.IdentEl;
if DeclEl=nil then
RaiseMsg(20210106223620,nSymbolCannotBeExportedFromALibrary,
sSymbolCannotBeExportedFromALibrary,[],El)
else if DeclEl is TPasProcedure then
begin
Proc:=TPasProcedure(DeclEl);
if Proc.Parent is TPasSection then
// ok
else
RaiseMsg(20210106224436,nSymbolCannotBeExportedFromALibrary,
sSymbolCannotBeExportedFromALibrary,[],El);
end
else
RaiseMsg(20210106223621,nSymbolCannotBeExportedFromALibrary,
sSymbolCannotBeExportedFromALibrary,[],El);
end;
procedure TPas2JSResolver.FindCreatorArrayOfConst(Args: TFPList; procedure TPas2JSResolver.FindCreatorArrayOfConst(Args: TFPList;
ErrorEl: TPasElement); ErrorEl: TPasElement);
var var
@ -8083,6 +8127,18 @@ Program:
}; };
}); });
Library:
rtl.module('library',
[<uses1>,<uses2>, ...],
function(){
var $mod = this;
<librarysection>
this.$main=function(){
<initialization>
};
});
export1 = pas.unit1.func1;
Unit without implementation: Unit without implementation:
rtl.module('<unitname>', rtl.module('<unitname>',
[<interface uses1>,<uses2>, ...], [<interface uses1>,<uses2>, ...],
@ -8136,6 +8192,7 @@ begin
ModScope:=nil; ModScope:=nil;
OuterSrc:=TJSSourceElements(CreateElement(TJSSourceElements, El)); OuterSrc:=TJSSourceElements(CreateElement(TJSSourceElements, El));
Result:=OuterSrc; Result:=OuterSrc;
IntfContext:=nil;
ok:=false; ok:=false;
try try
// create 'rtl.module(...)' // create 'rtl.module(...)'
@ -8145,7 +8202,7 @@ begin
ArgArray := RegModuleCall.Args; ArgArray := RegModuleCall.Args;
RegModuleCall.Args:=ArgArray; RegModuleCall.Args:=ArgArray;
// add unitname parameter: unitname // add module name parameter
ModuleName:=TransformModuleName(El,false,AContext); ModuleName:=TransformModuleName(El,false,AContext);
ArgArray.Elements.AddElement.Expr:=CreateLiteralString(El,ModuleName); ArgArray.Elements.AddElement.Expr:=CreateLiteralString(El,ModuleName);
@ -8183,95 +8240,88 @@ begin
IntfContext:=TInterfaceSectionContext.Create(El,Src,AContext) IntfContext:=TInterfaceSectionContext.Create(El,Src,AContext)
else else
IntfContext:=TSectionContext.Create(El,Src,AContext); IntfContext:=TSectionContext.Create(El,Src,AContext);
try // add "var $mod = this;"
// add "var $mod = this;" IntfContext.ThisVar.Element:=El;
IntfContext.ThisVar.Element:=El; IntfContext.ThisVar.Kind:=cvkGlobal;
IntfContext.ThisVar.Kind:=cvkGlobal; if El.CustomData is TPasModuleScope then
if El.CustomData is TPasModuleScope then IntfContext.ScannerBoolSwitches:=TPasModuleScope(El.CustomData).BoolSwitches;
IntfContext.ScannerBoolSwitches:=TPasModuleScope(El.CustomData).BoolSwitches; ModVarName:=GetBIName(pbivnModule);
ModVarName:=GetBIName(pbivnModule); IntfContext.AddLocalVar(ModVarName,El,cvkGlobal,false);
IntfContext.AddLocalVar(ModVarName,El,cvkGlobal,false); AddToSourceElements(Src,CreateVarStatement(ModVarName,
AddToSourceElements(Src,CreateVarStatement(ModVarName, CreatePrimitiveDotExpr('this',El),El));
CreatePrimitiveDotExpr('this',El),El));
if (ModScope<>nil) then if (ModScope<>nil) then
RestoreImplJSLocals(ModScope,IntfContext); RestoreImplJSLocals(ModScope,IntfContext);
if (El is TPasProgram) then if (El is TPasProgram) then
begin // program begin // program
Prg:=TPasProgram(El); Prg:=TPasProgram(El);
if Assigned(Prg.ProgramSection) then if Assigned(Prg.ProgramSection) then
AddToSourceElements(Src,ConvertDeclarations(Prg.ProgramSection,IntfContext)); AddToSourceElements(Src,ConvertDeclarations(Prg.ProgramSection,IntfContext));
AddDelayedInits(Prg,Src,IntfContext); AddDelayedInits(Prg,Src,IntfContext);
CreateInitSection(Prg,Src,IntfContext); CreateInitSection(Prg,Src,IntfContext);
end end
else if El is TPasLibrary then else if El is TPasLibrary then
begin // library begin // library
Lib:=TPasLibrary(El); Lib:=TPasLibrary(El);
if Assigned(Lib.LibrarySection) then if Assigned(Lib.LibrarySection) then
AddToSourceElements(Src,ConvertDeclarations(Lib.LibrarySection,IntfContext)); AddToSourceElements(Src,ConvertDeclarations(Lib.LibrarySection,IntfContext));
// ToDo AddDelayedInits(Lib,Src,IntfContext); AddDelayedInits(Lib,Src,IntfContext);
CreateInitSection(Lib,Src,IntfContext); CreateInitSection(Lib,Src,IntfContext);
// ToDo: append exports
end
else
begin // unit
IntfSecCtx:=TInterfaceSectionContext(IntfContext);
if Assigned(El.ImplementationSection) then
begin
// add var $impl = $mod.$impl
ImplVarSt:=CreateVarStatement(GetBIName(pbivnImplementation),
CreateMemberExpression([ModVarName,GetBIName(pbivnImplementation)]),El);
AddToSourceElements(Src,ImplVarSt);
// register local var $impl
IntfSecCtx.AddLocalVar(GetBIName(pbivnImplementation),El.ImplementationSection,cvkGlobal,false);
end;
if Assigned(El.InterfaceSection) then
AddToSourceElements(Src,ConvertDeclarations(El.InterfaceSection,IntfSecCtx));
ImplFunc:=CreateImplementationSection(El,IntfSecCtx);
// add $mod.$implcode = ImplFunc;
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AssignSt.LHS:=CreateMemberExpression([ModVarName,GetBIName(pbivnImplCode)]);
AssignSt.Expr:=ImplFunc;
AddToSourceElements(Src,AssignSt);
// append initialization section
CreateInitSection(El,Src,IntfSecCtx);
if TJSSourceElements(ImplFunc.AFunction.Body.A).Statements.Count=0 then
begin
// empty implementation
// remove unneeded $impl from interface
RemoveFromSourceElements(Src,ImplVarSt);
// remove unneeded $mod.$implcode = function(){}
RemoveFromSourceElements(Src,AssignSt);
HasImplUsesClause:=(El.ImplementationSection<>nil)
and (length(El.ImplementationSection.UsesClause)>0);
end end
else else
begin // unit begin
IntfSecCtx:=TInterfaceSectionContext(IntfContext); HasImplUsesClause:=true;
if Assigned(El.ImplementationSection) then
begin
// add var $impl = $mod.$impl
ImplVarSt:=CreateVarStatement(GetBIName(pbivnImplementation),
CreateMemberExpression([ModVarName,GetBIName(pbivnImplementation)]),El);
AddToSourceElements(Src,ImplVarSt);
// register local var $impl
IntfSecCtx.AddLocalVar(GetBIName(pbivnImplementation),El.ImplementationSection,cvkGlobal,false);
end;
if Assigned(El.InterfaceSection) then
AddToSourceElements(Src,ConvertDeclarations(El.InterfaceSection,IntfSecCtx));
ImplFunc:=CreateImplementationSection(El,IntfSecCtx);
// add $mod.$implcode = ImplFunc;
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
AssignSt.LHS:=CreateMemberExpression([ModVarName,GetBIName(pbivnImplCode)]);
AssignSt.Expr:=ImplFunc;
AddToSourceElements(Src,AssignSt);
// append initialization section
CreateInitSection(El,Src,IntfSecCtx);
if TJSSourceElements(ImplFunc.AFunction.Body.A).Statements.Count=0 then
begin
// empty implementation
// remove unneeded $impl from interface
RemoveFromSourceElements(Src,ImplVarSt);
// remove unneeded $mod.$implcode = function(){}
RemoveFromSourceElements(Src,AssignSt);
HasImplUsesClause:=(El.ImplementationSection<>nil)
and (length(El.ImplementationSection.UsesClause)>0);
end
else
begin
HasImplUsesClause:=true;
end;
if HasImplUsesClause then
// add implementation uses list: [<implementation uses1>,<uses2>, ...]
ArgArray.AddElement(CreateUsesList(El.ImplementationSection,AContext));
end; end;
if (ModScope<>nil) and (coStoreImplJS in Options) then if HasImplUsesClause then
StoreImplJSLocals(ModScope,IntfContext); // add implementation uses list: [<implementation uses1>,<uses2>, ...]
finally ArgArray.AddElement(CreateUsesList(El.ImplementationSection,AContext));
IntfContext.Free;
end;
// add implementation function end; // end unit
if ImplVarSt<>nil then
begin if (ModScope<>nil) and (coStoreImplJS in Options) then
end; StoreImplJSLocals(ModScope,IntfContext);
ok:=true; ok:=true;
finally finally
IntfContext.Free;
if not ok then if not ok then
FreeAndNil(Result); FreeAndNil(Result);
end; end;
@ -15397,6 +15447,8 @@ begin
end end
else if C=TPasAttributes then else if C=TPasAttributes then
continue continue
else if C=TPasExportSymbol then
continue
else else
RaiseNotSupported(P as TPasElement,AContext,20161024191434); RaiseNotSupported(P as TPasElement,AContext,20161024191434);
Add(E,P); Add(E,P);
@ -17148,11 +17200,21 @@ begin
Scope:=nil; Scope:=nil;
end; end;
IsMain:=(El is TPasProgram); if El.ClassType=TPasProgram then
if IsMain then begin
IsMain:=true;
FunName:=GetBIName(pbifnProgramMain) FunName:=GetBIName(pbifnProgramMain)
end
else if El.ClassType=TPasLibrary then
begin
IsMain:=true;
FunName:=GetBIName(pbifnLibraryMain)
end
else else
begin
IsMain:=false;
FunName:=GetBIName(pbifnUnitInit); FunName:=GetBIName(pbifnUnitInit);
end;
NeedRTLCheckVersion:=IsMain and (coRTLVersionCheckMain in Options); NeedRTLCheckVersion:=IsMain and (coRTLVersionCheckMain in Options);
RootContext:=AContext.GetRootContext as TRootContext; RootContext:=AContext.GetRootContext as TRootContext;
@ -17680,7 +17742,7 @@ begin
IntfSec.AddImplHeaderStatement(JS); IntfSec.AddImplHeaderStatement(JS);
end; end;
procedure TPasToJSConverter.AddDelayedInits(El: TPasProgram; procedure TPasToJSConverter.AddDelayedInits(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext); Src: TJSSourceElements; AContext: TConvertContext);
var var
aResolver: TPas2JSResolver; aResolver: TPas2JSResolver;
@ -26402,7 +26464,7 @@ begin
if (C=TPasConstructor) if (C=TPasConstructor)
or ((aResolver<>nil) and aResolver.IsClassMethod(P) or ((aResolver<>nil) and aResolver.IsClassMethod(P)
and not aResolver.MethodIsStatic(TPasProcedure(P))) then and not aResolver.MethodIsStatic(TPasProcedure(P))) then
IsComplex:=true; // needs $record ; //IsComplex:=true; // needs $record
end; end;
end end
else if C=TPasAttributes then else if C=TPasAttributes then
@ -26617,8 +26679,10 @@ begin
if Result<>'' then if Result<>'' then
exit; exit;
end; end;
if El is TPasProgram then if El.ClassType=TPasProgram then
Result:='program' Result:=GetBIName(pbivnProgram)
else if El.ClassType=TPasLibrary then
Result:=GetBIName(pbivnLibrary)
else else
begin begin
Result:=''; Result:='';

107
packages/pastojs/tests/tcmodules.pas
View File

@ -125,6 +125,7 @@ type
FModules: TObjectList;// list of TTestEnginePasResolver FModules: TObjectList;// list of TTestEnginePasResolver
FParser: TTestPasParser; FParser: TTestPasParser;
FPasProgram: TPasProgram; FPasProgram: TPasProgram;
FPasLibrary: TPasLibrary;
FHintMsgs: TObjectList; // list of TTestHintMessage FHintMsgs: TObjectList; // list of TTestHintMessage
FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected
FJSRegModuleCall: TJSCallExpression; FJSRegModuleCall: TJSCallExpression;
@ -157,6 +158,7 @@ type
procedure ParseModuleQueue; virtual; procedure ParseModuleQueue; virtual;
procedure ParseModule; virtual; procedure ParseModule; virtual;
procedure ParseProgram; virtual; procedure ParseProgram; virtual;
procedure ParseLibrary; virtual;
procedure ParseUnit; virtual; procedure ParseUnit; virtual;
protected protected
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual; function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
@ -166,9 +168,11 @@ type
ImplementationSrc: string): TTestEnginePasResolver; virtual; ImplementationSrc: string): TTestEnginePasResolver; virtual;
procedure AddSystemUnit(Parts: TSystemUnitParts = []); virtual; procedure AddSystemUnit(Parts: TSystemUnitParts = []); virtual;
procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual; procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual; procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); virtual;
procedure ConvertModule; virtual; procedure ConvertModule; virtual;
procedure ConvertProgram; virtual; procedure ConvertProgram; virtual;
procedure ConvertLibrary; virtual;
procedure ConvertUnit; virtual; procedure ConvertUnit; virtual;
function ConvertJSModuleToString(El: TJSElement): string; virtual; function ConvertJSModuleToString(El: TJSElement): string; virtual;
procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string); procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
@ -196,6 +200,7 @@ type
function GetResolver(const Filename: string): TTestEnginePasResolver; function GetResolver(const Filename: string): TTestEnginePasResolver;
function GetDefaultNamespace: string; function GetDefaultNamespace: string;
property PasProgram: TPasProgram Read FPasProgram; property PasProgram: TPasProgram Read FPasProgram;
property PasLibrary: TPasLibrary Read FPasLibrary;
property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers; property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
property ResolverCount: integer read GetResolverCount; property ResolverCount: integer read GetResolverCount;
property Engine: TTestEnginePasResolver read FEngine; property Engine: TTestEnginePasResolver read FEngine;
@ -894,6 +899,12 @@ type
Procedure TestAsync_Inherited; Procedure TestAsync_Inherited;
Procedure TestAsync_ClassInterface; Procedure TestAsync_ClassInterface;
Procedure TestAsync_ClassInterface_AsyncMissmatchFail; Procedure TestAsync_ClassInterface_AsyncMissmatchFail;
// Library
Procedure TestLibrary_Empty;
Procedure TestLibrary_ExportFunc; // ToDo
// ToDo: test delayed specialization init
// ToDO: analyzer
end; end;
function LinesToStr(Args: array of const): string; function LinesToStr(Args: array of const): string;
@ -1587,6 +1598,22 @@ begin
FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]); FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
end; end;
procedure TCustomTestModule.ParseLibrary;
var
Init: TInitializationSection;
begin
if SkipTests then exit;
ParseModule;
if SkipTests then exit;
AssertEquals('Has library',TPasLibrary,Module.ClassType);
FPasLibrary:=TPasLibrary(Module);
AssertNotNull('Has library section',PasLibrary.LibrarySection);
Init:=PasLibrary.InitializationSection;
if (Init<>nil) and (Init.Elements.Count>0) then
if TObject(Init.Elements[0]) is TPasImplBlock then
FFirstPasStatement:=TPasImplBlock(PasLibrary.InitializationSection.Elements[0]);
end;
procedure TCustomTestModule.ParseUnit; procedure TCustomTestModule.ParseUnit;
begin begin
if SkipTests then exit; if SkipTests then exit;
@ -1869,6 +1896,17 @@ begin
Add(''); Add('');
end; end;
procedure TCustomTestModule.StartLibrary(NeedSystemUnit: boolean;
SystemUnitParts: TSystemUnitParts);
begin
if NeedSystemUnit then
AddSystemUnit(SystemUnitParts)
else
Parser.ImplicitUses.Clear;
Add('library '+ExtractFileUnitName(Filename)+';');
Add('');
end;
procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean; procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean;
SystemUnitParts: TSystemUnitParts); SystemUnitParts: TSystemUnitParts);
begin begin
@ -1974,6 +2012,8 @@ begin
AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType)); AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
if Module is TPasProgram then if Module is TPasProgram then
AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString)) AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
else if Module is TPasLibrary then
AssertEquals('module name','library',String(ModuleNameExpr.Value.AsString))
else else
AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString)); AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
@ -1990,7 +2030,7 @@ begin
CheckFunctionParam('module intf-function',Arg,FJSModuleSrc); CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
// search for $mod.$init or $mod.$main - the last statement // search for $mod.$init or $mod.$main - the last statement
if Module is TPasProgram then if (Module is TPasProgram) or (Module is TPasLibrary) then
begin begin
InitName:='$main'; InitName:='$main';
AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0); AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
@ -2009,7 +2049,7 @@ begin
InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement; InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody; FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
end end
else if Module is TPasProgram then else if (Module is TPasProgram) or (Module is TPasLibrary) then
CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName); CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
end; end;
end; end;
@ -2028,6 +2068,13 @@ begin
ConvertModule; ConvertModule;
end; end;
procedure TCustomTestModule.ConvertLibrary;
begin
Add('end.');
ParseLibrary;
ConvertModule;
end;
procedure TCustomTestModule.ConvertUnit; procedure TCustomTestModule.ConvertUnit;
begin begin
Add('end.'); Add('end.');
@ -2089,7 +2136,7 @@ begin
// program main or unit initialization // program main or unit initialization
if (Module is TPasProgram) or (Trim(InitStatements)<>'') then if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
begin begin
if Module is TPasProgram then if (Module is TPasProgram) or (Module is TPasLibrary) then
InitName:='$main' InitName:='$main'
else else
InitName:='$init'; InitName:='$init';
@ -12292,12 +12339,20 @@ begin
'type', 'type',
' TPoint = record', ' TPoint = record',
' x,y: longint;', ' x,y: longint;',
' class procedure Run(w: longint = 13); static;',
' constructor Create(ax: longint; ay: longint = -1);', ' constructor Create(ax: longint; ay: longint = -1);',
' end;', ' end;',
'class procedure tpoint.run(w: longint);',
'begin',
' run;',
' run();',
'end;',
'constructor tpoint.create(ax,ay: longint);', 'constructor tpoint.create(ax,ay: longint);',
'begin', 'begin',
' x:=ax;', ' x:=ax;',
' self.y:=ay;', ' self.y:=ay;',
' run;',
' run(ax);',
'end;', 'end;',
'var r: TPoint;', 'var r: TPoint;',
'begin', 'begin',
@ -12320,12 +12375,18 @@ begin
' this.y = s.y;', ' this.y = s.y;',
' return this;', ' return this;',
' };', ' };',
' this.Run = function (w) {',
' $mod.TPoint.Run(13);',
' $mod.TPoint.Run(13);',
' };',
' this.Create = function (ax, ay) {', ' this.Create = function (ax, ay) {',
' this.x = ax;', ' this.x = ax;',
' this.y = ay;', ' this.y = ay;',
' this.Run(13);',
' this.Run(ax);',
' return this;', ' return this;',
' };', ' };',
'}, true);', '});',
'this.r = this.TPoint.$new();', 'this.r = this.TPoint.$new();',
'']), '']),
LinesToStr([ // $mod.$main LinesToStr([ // $mod.$main
@ -23241,7 +23302,7 @@ begin
' $mod.THelper.$new("NewHlp", [3]);', ' $mod.THelper.$new("NewHlp", [3]);',
' return this;', ' return this;',
' };', ' };',
'}, true);', '});',
'rtl.createHelper(this, "THelper", null, function () {', 'rtl.createHelper(this, "THelper", null, function () {',
' this.NewHlp = function (w) {', ' this.NewHlp = function (w) {',
' this.Create(2);', ' this.Create(2);',
@ -33110,6 +33171,42 @@ begin
ConvertProgram; ConvertProgram;
end; end;
procedure TTestModule.TestLibrary_Empty;
begin
StartLibrary(false);
Add([
'']);
ConvertLibrary;
CheckSource('TestLibrary_Empty',
LinesToStr([ // statements
'']),
LinesToStr([
'']));
CheckResolverUnexpectedHints();
end;
procedure TTestModule.TestLibrary_ExportFunc;
begin
exit;
StartLibrary(false);
Add([
'procedure Run(w: word);',
'begin',
'end;',
'exports',
' Run,',
' run name ''Foo'';',
'']);
ConvertLibrary;
CheckSource('TestLibrary_ExportFunc',
LinesToStr([ // statements
'']),
LinesToStr([
'']));
CheckResolverUnexpectedHints();
end;
Initialization Initialization
RegisterTests([TTestModule]); RegisterTests([TTestModule]);
end. end.

6
rtl/linux/i386/si_prc.inc
View File

@ -45,7 +45,9 @@ var
procedure fpc_geteipasebxlocal; [external name 'fpc_geteipasebx']; procedure fpc_geteipasebxlocal; [external name 'fpc_geteipasebx'];
{$endif} {$endif}
{$ifndef FPC_USE_LIBC}
procedure InitTLS; [external name 'FPC_INITTLS']; procedure InitTLS; [external name 'FPC_INITTLS'];
{$endif}
procedure _FPC_proc_start; assembler; nostackframe; public name '_start'; procedure _FPC_proc_start; assembler; nostackframe; public name '_start';
asm asm
@ -95,9 +97,9 @@ asm
movl %esp,initialstkptr movl %esp,initialstkptr
{$endif FPC_PIC} {$endif FPC_PIC}
{$if FPC_FULLVERSION>30200} {$if (FPC_FULLVERSION>30200) and not defined(FPC_USE_LIBC)}
call InitTLS call InitTLS
{$endif FPC_FULLVERSION>30200} {$endif FPC_FULLVERSION>30200 and not FPC_USE_LIBC}
xorl %ebp,%ebp xorl %ebp,%ebp
call PASCALMAIN call PASCALMAIN

2
rtl/linux/si_impl.inc
View File

@ -16,7 +16,9 @@ procedure PascalMain; external name 'PASCALMAIN';
{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
procedure SysEntry(constref info: TEntryInformation); external name 'FPC_SysEntry'; procedure SysEntry(constref info: TEntryInformation); external name 'FPC_SysEntry';
{$ifndef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation); external name 'FPC_SysEntry_InitTLS'; procedure SysEntry_InitTLS(constref info: TEntryInformation); external name 'FPC_SysEntry_InitTLS';
{$endif FPC_USE_LIBC}
var var
InitFinalTable : record end; external name 'INITFINAL'; InitFinalTable : record end; external name 'INITFINAL';

10
rtl/linux/system.pp
View File

@ -125,6 +125,9 @@ procedure OsSetupEntryInformation(constref info: TEntryInformation); forward;
TLS handling TLS handling
*****************************************************************************} *****************************************************************************}
{ TLS initialization is not required if linking against libc }
{$if not defined(FPC_USE_LIBC)}
{$if defined(CPUARM)} {$if defined(CPUARM)}
{$define INITTLS} {$define INITTLS}
Function fpset_tls(p : pointer;size : SizeUInt):cint; Function fpset_tls(p : pointer;size : SizeUInt):cint;
@ -185,6 +188,8 @@ begin
end; end;
{$endif defined(CPUX86_64)} {$endif defined(CPUX86_64)}
{$endif not FPC_USE_LIBC}
{$ifdef INITTLS} {$ifdef INITTLS}
{ This code initialized the TLS segment for single threaded and static programs. { This code initialized the TLS segment for single threaded and static programs.
@ -323,6 +328,8 @@ begin
info.PascalMain(); info.PascalMain();
end; end;
{$ifndef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS']; procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS'];
begin begin
SetupEntryInformation(info); SetupEntryInformation(info);
@ -334,6 +341,7 @@ begin
{$endif cpui386} {$endif cpui386}
info.PascalMain(); info.PascalMain();
end; end;
{$endif FPC_USE_LIBC}
{$else} {$else}
var var
@ -361,6 +369,7 @@ begin
end; end;
{$ifdef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS']; procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS'];
begin begin
initialstkptr := info.OS.stkptr; initialstkptr := info.OS.stkptr;
@ -375,6 +384,7 @@ begin
{$endif cpui386} {$endif cpui386}
info.PascalMain(); info.PascalMain();
end; end;
{$endif FPC_USE_LIBC}
{$endif FPC_BOOTSTRAP_INDIRECT_ENTRY} {$endif FPC_BOOTSTRAP_INDIRECT_ENTRY}

10
rtl/linux/x86_64/si_prc.inc
View File

@ -35,7 +35,9 @@
{$L abitag.o} {$L abitag.o}
{$ifndef FPC_USE_LIBC}
procedure InitTLS; [external name 'FPC_INITTLS']; procedure InitTLS; [external name 'FPC_INITTLS'];
{$endif}
{****************************************************************************** {******************************************************************************
Process start/halt Process start/halt
@ -73,7 +75,11 @@ procedure _FPC_proc_start; assembler; nostackframe; public name '_start';
movq %r10,%rdi movq %r10,%rdi
xorq %rbp, %rbp xorq %rbp, %rbp
{$ifdef FPC_USE_LIBC}
call SysEntry
{$else}
call SysEntry_InitTLS call SysEntry_InitTLS
{$endif}
{$else FPC_HAS_INDIRECT_ENTRY_INFORMATION} {$else FPC_HAS_INDIRECT_ENTRY_INFORMATION}
popq %rsi { Pop the argument count. } popq %rsi { Pop the argument count. }
movq operatingsystem_parameter_argc@GOTPCREL(%rip),%rax movq operatingsystem_parameter_argc@GOTPCREL(%rip),%rax
@ -90,9 +96,9 @@ procedure _FPC_proc_start; assembler; nostackframe; public name '_start';
movq initialstkptr@GOTPCREL(%rip),%rax movq initialstkptr@GOTPCREL(%rip),%rax
movq %rsp,(%rax) movq %rsp,(%rax)
{$if FPC_FULLVERSION>30200} {$if (FPC_FULLVERSION>30200) and not defined(FPC_USE_LIBC)}
call InitTLS call InitTLS
{$endif FPC_FULLVERSION>30200} {$endif FPC_FULLVERSION>30200 and not FPC_USE_LIBC}
xorq %rbp, %rbp xorq %rbp, %rbp
call PASCALMAIN call PASCALMAIN

4
rtl/unix/oscdeclh.inc
View File

@ -180,4 +180,6 @@ const
{$endif} {$endif}
function FpTime (tloc:ptime_t): time_t; cdecl; external clib name 'time'; function FpTime (tloc:ptime_t): time_t; cdecl; external clib name 'time';
{$if defined(linux)}
function FpSchedGetAffinity(pid : pid_t;cpusetsize : size_t;mask : pcpu_set_t) : cint; cdecl; external clib name 'sched_getaffinity';
{$endif}

36
tests/utils/testsuite/utests.pp
View File

@ -153,6 +153,9 @@ const
faction_compare_with_next = 6; faction_compare_with_next = 6;
faction_compare2_with_previous = 7; faction_compare2_with_previous = 7;
faction_compare2_with_next = 8; faction_compare2_with_next = 8;
faction_compare_both_with_previous = 9;
faction_compare_both_with_next = 10;
Function TestResultsTableName(const RunId : String) : string; Function TestResultsTableName(const RunId : String) : string;
var var
@ -347,6 +350,18 @@ begin
FCompareRunID:=FNext2RunID; FCompareRunID:=FNext2RunID;
ShowRunComparison; ShowRunComparison;
end; end;
faction_compare_both_with_previous :
begin
FRunID:=FPreviousRunID;
FCompareRunID:=FPrevious2RunID;
ShowRunComparison;
end;
faction_compare_both_with_next :
begin
FRunID:=FNextRunID;
FCompareRunID:=FNext2RunID;
ShowRunComparison;
end;
{$ifdef TEST} {$ifdef TEST}
98 : 98 :
begin begin
@ -402,6 +417,10 @@ begin
FAction:=faction_compare2_with_previous FAction:=faction_compare2_with_previous
else if S='Compare_right_to_next' then else if S='Compare_right_to_next' then
FAction:=faction_compare2_with_next FAction:=faction_compare2_with_next
else if S='Compare_both_to_previous' then
FAction:=faction_compare_both_with_previous
else if S='Compare_both_to_next' then
FAction:=faction_compare_both_with_next
else else
FAction:=StrToIntDef(S,0); FAction:=StrToIntDef(S,0);
S:=RequestVariables['limit']; S:=RequestVariables['limit'];
@ -1397,7 +1416,22 @@ begin
ParaGraphStart; ParaGraphStart;
end; end;
EmitSubmitButton('action','Show/Compare'); if (FPrevious2RunID<>'') and (FPreviousRunId<>'') then
begin
EmitSubmitButton('action','Compare_both_to_previous');
AddNewPar:=true;
end;
if (FNext2RunID<>'') and (FNextRunId<>'') then
begin
EmitSubmitButton('action','Compare_both_to_next');
AddNewPar:=true;
end;
if AddNewPar then
begin
ParagraphEnd;
ParaGraphStart;
end;
EmitSubmitButton('action','Show/Compare');
if FTestFileID<>'' then if FTestFileID<>'' then
EmitSubmitButton('action','View_history'); EmitSubmitButton('action','View_history');
EmitResetButton('','Reset form'); EmitResetButton('','Reset form');

12
tests/webtbf/tw37217.pp Normal file
View File

@ -0,0 +1,12 @@
{ %fail }
{$mode delphi}
type
TEagle = class
constructor Create<Y>();
end;
constructor TEagle.Create<Y>();
begin
end;
begin
end.

21
tests/webtbs/tw38316.pp Normal file
View File

@ -0,0 +1,21 @@
{ %opt=-gh }
program project1;
procedure P1(A: array of Integer);
begin
end;
procedure P2(A: array of Integer);
begin
P1(A);
end;
var
A: array [0..2] of Integer;
i: Integer;
begin
HaltOnNotReleased := true;
for i := 0 to 10 do
P2(A);
end.

20
tests/webtbs/tw38337.pp Normal file
View File

@ -0,0 +1,20 @@
program fs;
{$mode objfpc}{$H+}
function UTF8Length(const s: string): PtrInt; inline;
begin
Result:=9;
end;
var
v1: string;
s: shortstring;
i: Integer;
begin
v1 := '123456789';
s := v1;
for i := 1 to UTF8Length(s)-8 do begin
end;
end.

23
tests/webtbs/tw38339.pp Normal file
View File

@ -0,0 +1,23 @@
{%OPT=-O3 }
program test48086;
{$mode objfpc}{$H+}
function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean;
var MinusCnt, p: integer;
begin
MinusCnt:=0;
for p:=1 to length(LongFontName) do
if LongFontName[p]='-' then inc(MinusCnt);
Result:=(MinusCnt=14);
end;
var
myfont:string;
begin
myfont:='Myfont--------------';
if IsFontNameXLogicalFontDesc(myfont) then
writeln('NO ERROR')
else
begin
writeln('Error in count');
halt(1);
end;
end.