paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 04:09:33 +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/tw36975.pp svneol=native#text/pascal
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/tw37303.pp -text svneol=native#text/pascal
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/tw38310b.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/tw38337.pp svneol=native#text/plain
tests/webtbs/tw38339.pp svneol=native#text/plain
tests/webtbs/tw3840.pp svneol=native#text/plain
tests/webtbs/tw3841.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;
firstRemovedWasAlloc := false;
{$ifdef allocregdebug}
hp := tai_comment.Create(strpnew('allocating '+std_regname(newreg(R_INTREGISTER,supreg,R_SUBWHOLE))+
' from here...'));
insertllitem(asml,p1.previous,p1,hp);
hp := tai_comment.Create(strpnew('allocated '+std_regname(newreg(R_INTREGISTER,supreg,R_SUBWHOLE))+
' till here...'));
insertllitem(asml,p2,p2.next,hp);
hp := tai_comment.Create(strpnew('allocating '+std_regname(reg)+' from here...'));
insertllitem(p1.previous,p1,hp);
hp := tai_comment.Create(strpnew('allocated '+std_regname(reg)+' till here...'));
insertllitem(p2,p2.next,hp);
{$endif allocregdebug}
{ do it the safe way: always allocate the full super register,
as we do no register re-allocation in the peephole optimizer,

25
compiler/fpcdefs.inc
View File

@ -31,6 +31,31 @@
{$define USEINLINE}
{$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}
{$ifdef VER3_0}

2
compiler/i386/aoptcpu.pas
View File

@ -137,6 +137,8 @@ unit aoptcpu;
if InsContainsSegRef(taicpu(p)) then
exit;
case taicpu(p).opcode Of
A_ADD:
Result:=OptPass1ADD(p);
A_AND:
Result:=OptPass1And(p);
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 current platform. This happens, for example, when a far pointer is
% 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
% solely to the implementation section of that unit.
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
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
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}
%

5
compiler/msgidx.inc
View File

@ -471,6 +471,7 @@ const
parser_e_location_size_too_large=03357;
parser_e_location_regpair_only_data=03358;
parser_e_location_regpair_only_consecutive=03359;
parser_e_constructurs_cannot_take_type_parameters=03360;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -1135,9 +1136,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 86847;
MsgTxtSize = 86927;
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
);

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) }
left:=ctemprefnode.create(paratemp);
end;
{ add the finish statements to the call cleanup block }
addstatement(finistat,ctempdeletenode.create(paratemp));
aktcallnode.add_done_statement(finiblock);
firstpass(fparainit);
firstpass(left);
end;

107
compiler/pdecsub.pas
View File

@ -1133,61 +1133,70 @@ implementation
if assigned(genericparams) then
begin
include(pd.defoptions,df_generic);
{ 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
if potype=potype_constructor then
begin
tsym(genericparams[i]).register_sym;
if tsym(genericparams[i]).typ=typesym then
tstoreddef(ttypesym(genericparams[i]).typedef).register_def;
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))
Message(parser_e_constructurs_cannot_take_type_parameters);
genericparams.free;
genericparams:=nil;
end
else
begin
dummysym:=tsym(symtablestack.top.find(spnongen));
if not assigned(dummysym) and
(symtablestack.top=current_module.localsymtable) and
assigned(current_module.globalsymtable) then
dummysym:=tsym(current_module.globalsymtable.find(spnongen));
end;
if not assigned(dummysym) then
begin
{ overloading generic routines with non-generic types is not
allowed, so we create a procsym as dummy }
dummysym:=cprocsym.create(orgspnongen);
include(pd.defoptions,df_generic);
{ 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
tsym(genericparams[i]).register_sym;
if tsym(genericparams[i]).typ=typesym then
tstoreddef(ttypesym(genericparams[i]).typedef).register_def;
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
astruct.symtable.insert(dummysym)
dummysym:=tsym(astruct.symtable.find(spnongen))
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);
begin
dummysym:=tsym(symtablestack.top.find(spnongen));
if not assigned(dummysym) and
(symtablestack.top=current_module.localsymtable) and
assigned(current_module.globalsymtable) then
dummysym:=tsym(current_module.globalsymtable.find(spnongen));
end;
if not assigned(dummysym) then
begin
{ overloading generic routines with non-generic types is not
allowed, so we create a procsym as dummy }
dummysym:=cprocsym.create(orgspnongen);
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;
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
else if assigned(genericdef) then
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 PrePeepholeOptIMUL(var p : tai) : boolean;
function OptPass1Add(var p: tai): boolean;
function OptPass1AND(var p : tai) : boolean;
function OptPass1_V_MOVAP(var p : tai) : boolean;
function OptPass1VOP(var p : tai) : boolean;
@ -3171,6 +3172,42 @@ unit aoptx86;
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;
var
hp1, hp2, hp3: tai;
@ -3350,7 +3387,11 @@ unit aoptx86;
) or
((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) 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)))
) and
not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
@ -4945,7 +4986,7 @@ unit aoptx86;
MinSize, MaxSize, TrySmaller, TargetSize: TOpSize;
TargetSubReg: TSubRegister;
hp1, hp2: tai;
RegInUse, p_removed: Boolean;
RegInUse, RegChanged, p_removed: Boolean;
{ Store list of found instructions so we don't have to call
GetNextInstructionUsingReg multiple times }
@ -4995,6 +5036,7 @@ unit aoptx86;
TrySmallerLimit := UpperLimit;
TrySmaller := S_NO;
SmallerOverflow := False;
RegChanged := False;
while GetNextInstructionUsingReg(hp1, hp1, ThisReg) and
(hp1.typ = ait_instruction) and
@ -5377,6 +5419,7 @@ unit aoptx86;
begin
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;
RegChanged := True;
TransferUsedRegs(TmpUsedRegs);
AllocRegBetween(ThisReg, p, hp1, TmpUsedRegs);
@ -5411,9 +5454,12 @@ unit aoptx86;
{ Now go through every instruction we found and change the
size. If TargetSize = MaxSize, then almost no changes are
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
for Index := 0 to InstrMax do
begin
@ -5647,6 +5693,7 @@ unit aoptx86;
symbol: TAsmSymbol;
reg: tsuperregister;
regavailable: Boolean;
tmpreg: TRegister;
begin
result:=false;
symbol:=nil;
@ -5750,17 +5797,16 @@ unit aoptx86;
((Taicpu(hp1).opcode=A_INC) or (Taicpu(hp1).opcode=A_DEC))
) then
begin
TransferUsedRegs(TmpUsedRegs);
UpdateUsedRegs(TmpUsedRegs, tai(p.next));
{ search for an available register which is volatile }
regavailable:=false;
for reg in tcpuregisterset do
begin
tmpreg:=newreg(R_INTREGISTER,reg,R_SUBL);
if (reg in paramanager.get_volatile_registers_int(current_procinfo.procdef.proccalloption)) and
not(reg in TmpUsedRegs[R_INTREGISTER].GetUsedRegs) and
not(RegInInstruction(newreg(R_INTREGISTER,reg,R_SUBL),hp1))
not(reg in UsedRegs[R_INTREGISTER].GetUsedRegs) and
not(RegInInstruction(tmpreg,hp1))
{$ifdef i386}
{ use only registers which can be accessed byte wise }
and (reg in [RS_EAX,RS_EBX,RS_ECX,RS_EDX])
{$endif i386}
then
@ -5772,23 +5818,24 @@ unit aoptx86;
if regavailable then
begin
TAsmLabel(symbol).decrefs;
Taicpu(p).clearop(0);
Taicpu(p).ops:=1;
Taicpu(p).is_jmp:=false;
Taicpu(p).opcode:=A_SETcc;
DebugMsg(SPeepholeOptimization+'JccAdd2SetccAdd',p);
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
begin
case getsubreg(Taicpu(hp1).oper[1]^.reg) of
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));
R_SUBD,
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));
else
Internalerror(2020030601);
@ -7476,7 +7523,8 @@ unit aoptx86;
(taicpu(hp1).opcode = A_TEST) and MatchOperand(taicpu(hp1).oper[0]^, taicpu(hp1).oper[1]^)
)
) 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
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:
begin
case taicpu(p).opcode of
A_ADD:
Result:=OptPass1ADD(p);
A_AND:
Result:=OptPass1AND(p);
A_IMUL:

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

@ -9049,7 +9049,7 @@ begin
CurEl:=nil;
if not SameText(RightStr(AttrName,length('Attribute')),'Attribute') then
begin
// first search AttrName+'Attibute'
// first search AttrName+'Attribute'
CurEl:=FindFirstEl(AttrName+'Attribute',Data,NameExpr);
end;
// then search the name
@ -9164,12 +9164,14 @@ var
FindData: TPRFindData;
Ref: TResolvedReference;
ResolvedEl: TPasResolverResult;
Section: TPasSection;
Scope: TPasIdentifierScope;
ScopeIdent: TPasIdentifier;
begin
Expr:=El.NameExpr;
if Expr<>nil then
begin
ResolveExpr(Expr,rraRead);
//ResolveGlobalSymbol(Expr);
ComputeElement(Expr,ResolvedEl,[rcConstant]);
DeclEl:=ResolvedEl.IdentEl;
if DeclEl=nil then
@ -9189,6 +9191,18 @@ begin
CheckFoundElement(FindData,Ref);
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
CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
CheckConstExpr(El.ExportName,[revkString,revkUnicodeString],'string');
@ -21318,7 +21332,7 @@ procedure TPasResolver.CheckFoundElement(
// Call this method after finding an element by searching the scopes.
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
// type TRecord = record
// a: word; // inherits const
@ -27564,6 +27578,21 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
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
DeclEl: TPasElement;
ElClass: TClass;
@ -27946,6 +27975,8 @@ begin
ComputeSpecializeType(TPasSpecializeType(El))
else if ElClass=TInlineSpecializeExpr then
ComputeElement(TInlineSpecializeExpr(El).NameExpr,ResolvedEl,Flags,StartEl)
else if ElClass=TPasExportSymbol then
ComputeExportSymbol(TPasExportSymbol(El))
else
RaiseNotYetImplemented(20160922163705,El);
{$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_ExportVar; // ToDo
Procedure TestLibrary_Initialization_Finalization;
Procedure TestLibrary_ExportFuncOverloadFail; // ToDo
// ToDo Procedure TestLibrary_UnitExports;
Procedure TestLibrary_ExportFuncOverloadFail;
Procedure TestLibrary_UnitExports;
end;
function LinesToStr(Args: array of const): string;
@ -18836,8 +18836,6 @@ end;
procedure TTestResolver.TestLibrary_ExportFuncOverloadFail;
begin
exit;
StartLibrary(false);
Add([
'procedure Run(w: word); overload;',
@ -18850,7 +18848,24 @@ begin
' Run,',
' afile.run;',
'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;
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);
BEGIN
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;
BEGIN

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

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

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

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

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

@ -45,7 +45,9 @@ var
procedure fpc_geteipasebxlocal; [external name 'fpc_geteipasebx'];
{$endif}
{$ifndef FPC_USE_LIBC}
procedure InitTLS; [external name 'FPC_INITTLS'];
{$endif}
procedure _FPC_proc_start; assembler; nostackframe; public name '_start';
asm
@ -95,9 +97,9 @@ asm
movl %esp,initialstkptr
{$endif FPC_PIC}
{$if FPC_FULLVERSION>30200}
{$if (FPC_FULLVERSION>30200) and not defined(FPC_USE_LIBC)}
call InitTLS
{$endif FPC_FULLVERSION>30200}
{$endif FPC_FULLVERSION>30200 and not FPC_USE_LIBC}
xorl %ebp,%ebp
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}
procedure SysEntry(constref info: TEntryInformation); external name 'FPC_SysEntry';
{$ifndef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation); external name 'FPC_SysEntry_InitTLS';
{$endif FPC_USE_LIBC}
var
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 initialization is not required if linking against libc }
{$if not defined(FPC_USE_LIBC)}
{$if defined(CPUARM)}
{$define INITTLS}
Function fpset_tls(p : pointer;size : SizeUInt):cint;
@ -185,6 +188,8 @@ begin
end;
{$endif defined(CPUX86_64)}
{$endif not FPC_USE_LIBC}
{$ifdef INITTLS}
{ This code initialized the TLS segment for single threaded and static programs.
@ -323,6 +328,8 @@ begin
info.PascalMain();
end;
{$ifndef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS'];
begin
SetupEntryInformation(info);
@ -334,6 +341,7 @@ begin
{$endif cpui386}
info.PascalMain();
end;
{$endif FPC_USE_LIBC}
{$else}
var
@ -361,6 +369,7 @@ begin
end;
{$ifdef FPC_USE_LIBC}
procedure SysEntry_InitTLS(constref info: TEntryInformation);[public,alias:'FPC_SysEntry_InitTLS'];
begin
initialstkptr := info.OS.stkptr;
@ -375,6 +384,7 @@ begin
{$endif cpui386}
info.PascalMain();
end;
{$endif FPC_USE_LIBC}
{$endif FPC_BOOTSTRAP_INDIRECT_ENTRY}

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

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

4
rtl/unix/oscdeclh.inc
View File

@ -180,4 +180,6 @@ const
{$endif}
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_compare2_with_previous = 7;
faction_compare2_with_next = 8;
faction_compare_both_with_previous = 9;
faction_compare_both_with_next = 10;
Function TestResultsTableName(const RunId : String) : string;
var
@ -347,6 +350,18 @@ begin
FCompareRunID:=FNext2RunID;
ShowRunComparison;
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}
98 :
begin
@ -402,6 +417,10 @@ begin
FAction:=faction_compare2_with_previous
else if S='Compare_right_to_next' then
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
FAction:=StrToIntDef(S,0);
S:=RequestVariables['limit'];
@ -1397,7 +1416,22 @@ begin
ParaGraphStart;
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
EmitSubmitButton('action','View_history');
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.