paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 23:19:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46466 -
This commit is contained in:
nickysn 2020-08-16 23:43:13 +00:00
commit 78ad7b7dfa
39 changed files with 485 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -16596,6 +16596,7 @@ tests/webtbf/tw3740.pp svneol=native#text/plain
tests/webtbf/tw37460.pp svneol=native#text/pascal
tests/webtbf/tw37462.pp svneol=native#text/pascal
tests/webtbf/tw37475.pp svneol=native#text/pascal
tests/webtbf/tw37476.pp svneol=native#text/pascal
tests/webtbf/tw3790.pp svneol=native#text/plain
tests/webtbf/tw3812.pp svneol=native#text/plain
tests/webtbf/tw3930a.pp svneol=native#text/plain

40
compiler/aarch64/aoptcpu.pas
View File

@ -50,6 +50,7 @@ Interface
function RemoveSuperfluousFMov(const p: tai; movp: tai; const optimizer: string): boolean;
function OptPass1STP(var p: tai): boolean;
function OptPass1Mov(var p: tai): boolean;
function OptPass1FMov(var p: tai): Boolean;
End;
Implementation
@ -60,6 +61,16 @@ Implementation
cgutils,
verbose;
{$ifdef DEBUG_AOPTCPU}
const
SPeepholeOptimization: shortstring = 'Peephole Optimization: ';
{$else DEBUG_AOPTCPU}
{ Empty strings help the optimizer to remove string concatenations that won't
ever appear to the user on release builds. [Kit] }
const
SPeepholeOptimization = '';
{$endif DEBUG_AOPTCPU}
function CanBeCond(p : tai) : boolean;
begin
result:=(p.typ=ait_instruction) and (taicpu(p).condition=C_None);
@ -490,6 +501,31 @@ Implementation
end;
function TCpuAsmOptimizer.OptPass1FMov(var p: tai): Boolean;
var
hp1: tai;
begin
{
change
fmov reg0,reg1
fmov reg1,reg0
into
fmov reg0,reg1
}
Result := False;
while GetNextInstruction(p, hp1) and
MatchInstruction(hp1, A_FMOV, [taicpu(p).condition], [taicpu(p).oppostfix]) and
MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and
MatchOperand(taicpu(p).oper[1]^, taicpu(hp1).oper[0]^) do
begin
asml.Remove(hp1);
hp1.free;
DebugMsg(SPeepholeOptimization + 'FMovFMov2FMov done', p);
Result:=true;
end;
end;
function TCpuAsmOptimizer.OptPostCMP(var p : tai): boolean;
var
hp1,hp2: tai;
@ -580,7 +616,9 @@ Implementation
if GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousFMov(p, hp1, 'FOpFMov2FOp') then
Result:=true;
end
end;
A_FMOV:
Result:=OptPass1FMov(p);
else
;
end;

6
compiler/link.pas
View File

@ -882,7 +882,7 @@ Implementation
if (target_ar.id in [ar_gnu_ar_scripted,ar_sdcc_sdar_scripted]) then
writeln(script, 'CREATE ' + current_module.staticlibfilename)
else { wlib case }
writeln(script,'-q -fo -c -b '+
writeln(script,'-q -p=16 -fo -c -b '+
maybequoted(current_module.staticlibfilename));
current := TCmdStrListItem(SmartLinkOFiles.First);
while current <> nil do
@ -1743,8 +1743,8 @@ Implementation
ar_watcom_wlib_omf_info : tarinfo =
( id : ar_watcom_wlib_omf;
addfilecmd : '+';
arfirstcmd : 'wlib -q -fo -c -b -n -o=$OUTPUTLIB $LIB $FILES';
arcmd : 'wlib -q -fo -c -b -o=$OUTPUTLIB $LIB $FILES';
arfirstcmd : 'wlib -q -p=16 -fo -c -b -n -o=$OUTPUTLIB $LIB $FILES';
arcmd : 'wlib -q -p=16 -fo -c -b -o=$OUTPUTLIB $LIB $FILES';
arfinishcmd : ''
);

6
compiler/nadd.pas
View File

@ -1326,7 +1326,9 @@ implementation
(right.nodetype in [ltn,lten,gtn,gten]) and
(not might_have_sideeffects(left)) and
(not might_have_sideeffects(right)) and
is_range_test(taddnode(left),taddnode(right),vl,cl,cr) then
is_range_test(taddnode(left),taddnode(right),vl,cl,cr) and
{ avoid optimization being applied to (<string. var > charconst1) and (<string. var < charconst2) }
(vl.resultdef.typ in [orddef,enumdef]) then
begin
hdef:=get_unsigned_inttype(vl.resultdef);
vl:=ctypeconvnode.create_internal(vl.getcopy,hdef);
@ -3000,7 +3002,7 @@ implementation
end;
end;
if not codegenerror and
if (errorcount=0) and
not assigned(result) then
result:=simplify(false);
end;

12
compiler/ncgcal.pas
View File

@ -623,6 +623,18 @@ implementation
assigned(funcretnode) then
hlcg.gen_load_cgpara_loc(current_asmdata.CurrAsmList,realresdef,retloc,location,false);
if ((location.loc=LOC_REGISTER) and
not realresdef.is_intregable) or
((location.loc in [LOC_FPUREGISTER,LOC_MMREGISTER]) and
(not realresdef.is_fpuregable or
((location.loc=LOC_MMREGISTER)<>use_vectorfpu(realresdef)))) then
begin
hlcg.location_force_mem(current_asmdata.CurrAsmList,location,realresdef);
{ may have been record returned in a floating point register (-> location.size
will be the size of the fpuregister instead of the int size of the record) }
location.size:=def_cgsize(realresdef);
end;
{ copy value to the final location if this was already provided to the
callnode. This must be done after the call node, because the location can
also be used as parameter and may not be finalized yet }

2
compiler/ncgrtti.pas
View File

@ -623,7 +623,7 @@ implementation
begin
sym:=tsym(fields[i]);
write_rtti_reference(tcb,tfieldvarsym(sym).vardef,rt);
tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,ptruinttype);
tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,sizeuinttype);
end;
fields.free;
end;

5
compiler/pdecsub.pas
View File

@ -3178,9 +3178,14 @@ const
result:=target_info.Cprefix+tprocdef(pd).procsym.realname
else
result:=pd.procsym.realname;
{$ifdef i8086}
{ Turbo Pascal expects names of external routines
to be all uppercase }
if (target_info.system=system_i8086_msdos) and
(m_tp7 in current_settings.modeswitches) and
(pd.proccalloption=pocall_pascal) then
result:=UpCase(result);
{$endif i8086}
end;
end;
end;

18
compiler/scanner.pas
View File

@ -460,6 +460,16 @@ implementation
end;
end;
end;
{$ifdef i8086}
{ enable cs_force_far_calls when m_nested_procvars is enabled }
if switch=m_nested_procvars then
begin
include(current_settings.localswitches,cs_force_far_calls);
if changeinit then
include(init_settings.localswitches,cs_force_far_calls);
end;
{$endif i8086}
end;
@ -605,12 +615,18 @@ implementation
end;
{$ifdef i8086}
{ Do not force far calls in the TP mode by default }
{ Do not force far calls in the TP mode by default, force it in other modes }
if (m_tp7 in current_settings.modeswitches) then
begin
exclude(current_settings.localswitches,cs_force_far_calls);
if changeinit then
exclude(init_settings.localswitches,cs_force_far_calls);
end
else
begin
include(current_settings.localswitches,cs_force_far_calls);
if changeinit then
include(init_settings.localswitches,cs_force_far_calls);
end;
{$endif i8086}

4
compiler/systems.pas
View File

@ -100,8 +100,8 @@ interface
tarinfo = record
id : tar;
addfilecmd : string[10];
arfirstcmd : string[50];
arcmd : string[50];
arfirstcmd : string[60];
arcmd : string[60];
arfinishcmd : string[11];
end;

8
compiler/x86/aoptx86.pas
View File

@ -1788,14 +1788,16 @@ unit aoptx86;
InternalError(2020072501);
{ do not mess with the stack point as adjusting it by lea is recommend, except if we optimize for size }
if (taicpu(p).oper[1]^.reg=NR_STACK_POINTER_REG) and
if (p.oper[1]^.reg=NR_STACK_POINTER_REG) and
not(cs_opt_size in current_settings.optimizerswitches) then
exit;
with p.oper[0]^.ref^ do
begin
if (base <> p.oper[1]^.reg) or (index <> NR_NO) then
Exit(False);
if (base <> p.oper[1]^.reg) or
(index <> NR_NO) or
assigned(symbol) then
exit;
l:=offset;
if (l=1) and UseIncDec then

64
compiler/xtensa/aoptcpu.pas
View File

@ -43,6 +43,8 @@ Interface
function InstructionLoadsFromReg(const reg: TRegister; const hp: tai): boolean;override;
function GetNextInstructionUsingReg(Current : tai; out Next : tai; reg : TRegister) : Boolean;
procedure DebugMsg(const s : string; p : tai);
function PeepHoleOptPass1Cpu(var p: tai): boolean; override;
private
function RemoveSuperfluousMove(const p: tai; movp: tai; const optimizer: string): boolean;
End;
@ -145,6 +147,24 @@ Implementation
Result := false;
if not ((assigned(hp)) and (hp.typ = ait_instruction)) then
exit;
if Result then
exit;
case p.opcode of
A_B,
A_SSI,A_SSIU,A_SSX,A_SSXU,
A_S16I,A_S32C1I,A_S32E,A_S32I,A_S32RI,A_S8I:
exit;
else
;
end;
case p.oper[0]^.typ of
top_reg:
Result := (p.oper[0]^.reg = reg) ;
else
;
end;
end;
@ -192,7 +212,6 @@ Implementation
begin
Result:=false;
if MatchInstruction(movp, A_MOV, [PF_None,PF_N]) and
(taicpu(p).ops>=3) and
{ We can't optimize if there is a shiftop }
(taicpu(movp).ops=2) and
MatchOperand(taicpu(movp).oper[1]^, taicpu(p).oper[0]^.reg) and
@ -200,10 +219,10 @@ Implementation
not(RegUsedBetween(taicpu(movp).oper[0]^.reg,p,movp)) and
{ Take care to only do this for instructions which REALLY load to the first register.
Otherwise
str reg0, [reg1]
s* reg0, [reg1]
mov reg2, reg0
will be optimized to
str reg2, [reg1]
s* reg2, [reg1]
}
RegLoadedWithNewValue(taicpu(p).oper[0]^.reg, p) then
begin
@ -239,25 +258,38 @@ Implementation
{ finally get rid of the mov }
taicpu(p).loadreg(0,taicpu(movp).oper[0]^.reg);
{ Remove preindexing and postindexing for LDR in some cases.
For example:
ldr reg2,[reg1, xxx]!
mov reg1,reg2
must be translated to:
ldr reg1,[reg1, xxx]
Preindexing must be removed there, since the same register is used as the base and as the target.
Such case is not allowed for ARM CPU and produces crash. }
//if (taicpu(p).opcode = A_LDR) and (taicpu(p).oper[1]^.typ = top_ref)
// and (taicpu(movp).oper[0]^.reg = taicpu(p).oper[1]^.ref^.base)
//then
// taicpu(p).oper[1]^.ref^.addressmode:=AM_OFFSET;
asml.remove(movp);
movp.free;
end;
end;
end;
function TCpuAsmOptimizer.PeepHoleOptPass1Cpu(var p: tai): boolean;
var
hp1: tai;
begin
result := false;
case p.typ of
ait_instruction:
begin
case taicpu(p).opcode of
A_L32I:
begin
if GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousMove(p, hp1, 'L32IMov2L32I') then
Result:=true;
end;
else
;
end;
end
else
;
end
end;
begin
casmoptimizer:=TCpuAsmOptimizer;
End.

9
packages/fcl-db/src/sql/fpsqlparser.pas
View File

@ -2880,7 +2880,10 @@ begin
Result:=TSQLAsteriskExpression(CreateElement(TSQLAsteriskExpression,APArent));
GetNextToken;
end;
tsqlIdentifier:
else
// some keywords (FirstKeyword..LastKeyWord) can also be functions/identifiers (LEFT, RIGHT)
// To-Do: remove some of them if necessary
if CurrentToken in [tsqlIdentifier, FirstKeyword..LastKeyWord] then
begin
N:=CurrentTokenString;
If (GetNextToken<>tsqlBraceOpen) then
@ -2941,10 +2944,10 @@ begin
TSQLFunctionCallExpression(Result).IDentifier:=N;
TSQLFunctionCallExpression(Result).Arguments:=L;
end;
end;
end
else
UnexpectedToken;
end;
end;
except
FreeAndNil(Result);
Raise;

26
packages/fcl-db/tests/tcparser.pas
View File

@ -450,6 +450,7 @@ type
procedure TestAggregateAvgDistinct;
procedure TestUpperConst;
procedure TestUpperError;
procedure TestLeft;
procedure TestGenID;
procedure TestGenIDError1;
procedure TestGenIDError2;
@ -4778,6 +4779,31 @@ begin
AssertAggregateExpression(H.Left,afCount,'C',aoNone);
end;
procedure TTestSelectParser.TestLeft;
Var
E : TSQLFunctionCallExpression;
L : TSQLLiteralExpression;
S : TSQLStringLiteral;
I : TSQLIntegerLiteral;
begin
TestSelect('SELECT LEFT(''abc'', 1) FROM A');
AssertEquals('One field',1,Select.Fields.Count);
AssertEquals('One table',1,Select.Tables.Count);
AssertTable(Select.Tables[0],'A');
CheckClass(Select.Fields[0],TSQLSelectField);
E:=TSQLFunctionCallExpression(CheckClass(TSQLSelectField(Select.Fields[0]).Expression,TSQLFunctionCallExpression));
AssertEquals('LEFT function name','LEFT',E.Identifier);
AssertEquals('Two function elements',2,E.Arguments.Count);
L:=TSQLLiteralExpression(CheckClass(E.Arguments[0],TSQLLiteralExpression));
S:=TSQLStringLiteral(CheckClass(L.Literal,TSQLStringLiteral));
AssertEquals('Correct string constant','abc',S.Value);
L:=TSQLLiteralExpression(CheckClass(E.Arguments[1],TSQLLiteralExpression));
I:=TSQLIntegerLiteral(CheckClass(L.Literal,TSQLIntegerLiteral));
AssertEquals('Correct integer constant',1,I.Value);
end;
procedure TTestSelectParser.TestNoTable;
Var

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

@ -1423,10 +1423,21 @@ type
//ToDo: proStaticArrayConcat, // concat works with static arrays, returning a dynamic array
proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested'
proMethodAddrAsPointer, // can assign @method to a pointer
proSafecallAllowsDefault // allow assigning a default calling convetnion to a SafeCall proc
proSafecallAllowsDefault // allow assigning a default calling convention to a SafeCall proc
);
TPasResolverOptions = set of TPasResolverOption;
{ TPasResolverHub }
TPasResolverHub = class
private
FOwner: TObject;
public
constructor Create(TheOwner: TObject);
property Owner: TObject read FOwner;
end;
TPasResolverHubClass = class of TPasResolverHub;
TPasResolverStep = (
prsInit,
prsParsing,
@ -1480,6 +1491,7 @@ type
FDefaultScope: TPasDefaultScope;
FDynArrayMaxIndex: TMaxPrecInt;
FDynArrayMinIndex: TMaxPrecInt;
FHub: TPasResolverHub;
FLastCreatedData: array[TResolveDataListKind] of TResolveData;
FLastElement: TPasElement;
FLastMsg: string;
@ -2363,10 +2375,12 @@ type
function FindLocalBuiltInSymbol(El: TPasElement): TPasElement; virtual;
function GetFirstSection(WithUnitImpl: boolean): TPasSection;
function GetLastSection: TPasSection;
function GetParentSection(El: TPasElement): TPasSection;
function FindUsedUnitInSection(aMod: TPasModule; Section: TPasSection): TPasUsesUnit;
function GetShiftAndMaskForLoHiFunc(BaseType: TResolverBaseType;
isLoFunc: Boolean; out Mask: LongWord): Integer;
public
property Hub: TPasResolverHub read FHub write FHub;
// options
property Options: TPasResolverOptions read FOptions write FOptions;
property AnonymousElTypePostfix: String read FAnonymousElTypePostfix
@ -2381,15 +2395,15 @@ type
property ExprEvaluator: TResExprEvaluator read fExprEvaluator;
property DynArrayMinIndex: TMaxPrecInt read FDynArrayMinIndex write FDynArrayMinIndex;
property DynArrayMaxIndex: TMaxPrecInt read FDynArrayMaxIndex write FDynArrayMaxIndex;
property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; {
If true Line and Column is mangled together in TPasElement.SourceLineNumber.
Use method UnmangleSourceLineNumber to extract. }
// parsed values
property DefaultNameSpace: String read FDefaultNameSpace;
property RootElement: TPasModule read FRootElement write SetRootElement;
property Step: TPasResolverStep read FStep;
property ActiveHelpers: TPRHelperEntryArray read FActiveHelpers;
// scopes
property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; {
If true Line and Column is mangled together in TPasElement.SourceLineNumber.
Use method UnmangleSourceLineNumber to extract. }
property Scopes[Index: integer]: TPasScope read GetScopes;
property ScopeCount: integer read FScopeCount;
property TopScope: TPasScope read FTopScope;
@ -3063,6 +3077,13 @@ begin
str(a,Result);
end;
{ TPasResolverHub }
constructor TPasResolverHub.Create(TheOwner: TObject);
begin
FOwner:=TheOwner;
end;
{ TPRSpecializedItem }
destructor TPRSpecializedItem.Destroy;
@ -11780,6 +11801,8 @@ var
C: TClass;
ModScope: TPasModuleScope;
begin
if Hub=nil then
RaiseNotYetImplemented(20200815182122,El);
if TopScope<>DefaultScope then
RaiseInvalidScopeForElement(20160922163504,El);
ModScope:=TPasModuleScope(PushScope(El,FScopeClass_Module));
@ -29229,6 +29252,16 @@ begin
Result:=Module.InterfaceSection;
end;
function TPasResolver.GetParentSection(El: TPasElement): TPasSection;
begin
while El<>nil do
begin
if El is TPasSection then exit(TPasSection(El));
El:=El.Parent;
end;
Result:=nil;
end;
function TPasResolver.FindUsedUnitInSection(aMod: TPasModule;
Section: TPasSection): TPasUsesUnit;
var

4
packages/fcl-passrc/src/pastree.pp
View File

@ -1750,7 +1750,7 @@ const
cPasMemberHint : Array[TPasMemberHint] of string =
( 'deprecated', 'library', 'platform', 'experimental', 'unimplemented' );
cCallingConventions : Array[TCallingConvention] of string =
( '', 'Register','Pascal','CDecl','StdCall','OldFPCCall','SafeCall','SysCall','MWPascal',
( '', 'Register','Pascal','cdecl','stdcall','OldFPCCall','safecall','SysCall','MWPascal',
'HardFloat','SysV_ABI_Default','SysV_ABI_CDecl',
'MS_ABI_Default','MS_ABI_CDecl',
'VectorCall');
@ -4208,7 +4208,7 @@ end;
function TPasClassOfType.GetDeclaration (full : boolean) : string;
begin
Result:='Class of '+DestType.SafeName;
Result:='class of '+DestType.SafeName;
If Full then
Result:=FixTypeDecl(Result);
end;

19
packages/fcl-passrc/src/paswrite.pp
View File

@ -43,6 +43,8 @@ type
);
TPasWriterOptions = Set of TPasWriterOption;
TOnUnitAlias = function(const UnitName : String) : String of Object;
TPasWriter = class
private
FCurrentLineNumber : Integer;
@ -51,6 +53,7 @@ type
FForwardClasses: TStrings;
FLineEnding: String;
FLineNumberWidth: Integer;
FOnUnitAlias: TOnUnitAlias;
FOPtions: TPasWriterOptions;
FStream: TStream;
FIndentSize : Integer;
@ -63,6 +66,7 @@ type
FInImplementation : Boolean;
procedure SetForwardClasses(AValue: TStrings);
procedure SetIndentSize(AValue: Integer);
function CheckUnitAlias(const AUnitName : String) : String;
protected
procedure DisableHintsWarnings;
procedure PrepareDeclSectionInStruct(const ADeclSection: string);
@ -132,6 +136,7 @@ type
procedure wrtln;overload; deprecated ;
property Stream: TStream read FStream;
Published
Property OnUnitAlias : TOnUnitAlias Read FOnUnitAlias Write FOnUnitAlias;
Property Options : TPasWriterOptions Read FOPtions Write FOptions;
Property IndentSize : Integer Read FIndentSize Write SetIndentSize;
Property LineEnding : String Read FLineEnding Write FLineEnding;
@ -478,7 +483,7 @@ end;
procedure TPasWriter.WriteUnit(aModule: TPasModule);
begin
AddLn('unit ' + AModule.SafeName + ';');
AddLn('unit ' + CheckUnitAlias(AModule.SafeName) + ';');
if Assigned(AModule.GlobalDirectivesSection) then
begin
AddLn;
@ -556,7 +561,7 @@ Var
Add(', ')
else
Add('uses ');
Add(AName);
Add(CheckUnitAlias(AName));
if (AUnitFile<>Nil) then
Add(' in '+GetExpr(AUnitFile));
Inc(c);
@ -848,9 +853,7 @@ end;
procedure TPasWriter.WriteRecordType(AType: TPasRecordType);
Var
I : Integer;
Temp : String;
el : TPasElement;
begin
Temp:='record';
@ -1490,6 +1493,14 @@ begin
FIndentStep:=StringOfChar(' ',aValue);
end;
function TPasWriter.CheckUnitAlias(const AUnitName: String): String;
begin
if Assigned(FOnUnitAlias) then
Result := FOnUnitAlias(AUnitName)
else
Result := AUnitName;
end;
function TPasWriter.HasOption(aOption: TPasWriterOption): Boolean;
begin
Result:=(aOption in FOptions)

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

@ -112,6 +112,7 @@ type
TCustomTestResolver = Class(TTestParser)
Private
FHub: TPasResolverHub;
{$IF defined(VerbosePasResolver) or defined(VerbosePasResolverMem)}
FStartElementRefCount: int64;
{$ENDIF}
@ -173,6 +174,7 @@ type
procedure StartUnit(NeedSystemUnit: boolean);
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
property ModuleCount: integer read GetModuleCount;
property Hub: TPasResolverHub read FHub;
property ResolverEngine: TTestEnginePasResolver read FResolverEngine;
property MsgCount: integer read GetMsgCount;
property Msgs[Index: integer]: TTestResolverMessage read GetMsgs;
@ -1060,6 +1062,7 @@ begin
FStartElementRefCount:=TPasElement.GlobalRefCount;
{$ENDIF}
FModules:=TObjectList.Create(true);
FHub:=TPasResolverHub.Create(Self);
inherited SetUp;
Parser.Options:=Parser.Options+[po_ResolveStandardTypes];
Scanner.OnDirective:=@OnScannerDirective;
@ -1096,6 +1099,7 @@ begin
FModules.OwnsObjects:=true;
FreeAndNil(FModules);// free all other modules
end;
FreeAndNil(FHub);
{$IFDEF VerbosePasResolverMem}
writeln('TTestResolver.TearDown inherited');
{$ENDIF}
@ -2171,6 +2175,7 @@ begin
Result.AddObjFPCBuiltInIdentifiers;
Result.OnFindUnit:=@OnPasResolverFindUnit;
Result.OnLog:=@OnPasResolverLog;
Result.Hub:=Hub;
FModules.Add(Result);
end;

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

@ -1369,6 +1369,11 @@ type
property TargetProcessor: TPasToJsProcessor read FTargetProcessor write FTargetProcessor;
end;
{ TPas2JSResolverHub }
TPas2JSResolverHub = class(TPasResolverHub)
end;
{ TPas2JSResolver }
TPas2JSResolver = class(TPasResolver)
@ -1473,6 +1478,7 @@ type
// generic/specialize
procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem);
override;
function SpecializeNeedsDelay(SpecializedItem: TPRSpecializedItem): TPasElement;
protected
const
cJSValueConversion = 2*cTypeConversion;
@ -4900,6 +4906,47 @@ begin
end;
end;
function TPas2JSResolver.SpecializeNeedsDelay(
SpecializedItem: TPRSpecializedItem): TPasElement;
// finds first specialize param defined later than the generic
// For example: generic in the unit interface, param in implementation
// or param in another unit, not used by the generic
var
Gen: TPasElement;
GenMod, ParamMod: TPasModule;
Params: TPasTypeArray;
Param: TPasType;
i: Integer;
GenSection, ParamSection: TPasSection;
begin
Result:=nil;
Gen:=SpecializedItem.GenericEl;
GenSection:=GetParentSection(Gen);
if not (GenSection is TInterfaceSection) then
exit; // generic in unit implementation/program/library -> params cannot be defined a later section
GenMod:=GenSection.GetModule;
Params:=SpecializedItem.Params;
for i:=0 to length(Params)-1 do
begin
Param:=ResolveAliasType(Params[i],false);
if Param.ClassType=TPasUnresolvedSymbolRef then
continue; // built-in type
ParamSection:=GetParentSection(Param);
if ParamSection=GenSection then continue;
// not in same section
ParamMod:=ParamSection.GetModule;
if ParamMod=GenMod then
exit(Param); // generic in unit interface, specialize in implementation
// param in another unit
if ParamSection is TImplementationSection then
exit(Param); // generic in unit interface, specialize in another(later) implementation
// param in another unit interface
//xxx
end;
end;
function TPas2JSResolver.AddJSBaseType(const aName: string; Typ: TPas2jsBaseType
): TResElDataPas2JSBaseType;
var

9
packages/pastojs/src/pas2jscompiler.pp
View File

@ -500,6 +500,7 @@ type
FPostProcessorSupport: TPas2JSPostProcessorSupport;
FPrecompileGUID: TGUID;
FReadingModules: TFPList; // list of TPas2jsCompilerFile ordered by uses sections
FResolverHub: TPas2JSResolverHub;
FRTLVersionCheck: TP2jsRTLVersionCheck;
FSrcMapBaseDir: string;
FSrcMapSourceRoot: string;
@ -680,14 +681,15 @@ type
property DefaultNamespace: String read GetDefaultNamespace;
property Defines: TStrings read FDefines;
property FS: TPas2jsFS read FFS write SetFS;
property OwnsFS: boolean read FOwnsFS write FOwnsFS;
property OwnsFS: boolean read FOwnsFS write FOwnsFS; // true = auto free FS when compiler is freed
property FileCount: integer read GetFileCount;
property InterfaceType: TPasClassInterfaceType read FInterfaceType write FInterfaceType;
property InterfaceType: TPasClassInterfaceType read FInterfaceType write FInterfaceType; // default interface type
property Log: TPas2jsLogger read FLog;
property MainFile: TPas2jsCompilerFile read FMainFile;
property ModeSwitches: TModeSwitches read FModeSwitches write SetModeSwitches;
property Options: TP2jsCompilerOptions read FOptions write SetOptions;
property ConverterGlobals: TPasToJSConverterGlobals read FConverterGlobals write SetConverterGlobals;
property ResolverHub: TPas2JSResolverHub read FResolverHub;
property ParamMacros: TPas2jsMacroEngine read FParamMacros;
property PrecompileGUID: TGUID read FPrecompileGUID write FPrecompileGUID;
property RTLVersionCheck: TP2jsRTLVersionCheck read FRTLVersionCheck write FRTLVersionCheck;
@ -965,6 +967,7 @@ begin
FPasResolver.OnCheckSrcName:=@OnResolverCheckSrcName;
FPasResolver.OnLog:=@OnPasResolverLog;
FPasResolver.Log:=Log;
FPasResolver.Hub:=aCompiler.ResolverHub;
FPasResolver.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
FIsMainFile:=Compiler.FS.SameFileName(Compiler.MainSrcFile,PasFilename);
for ub in TUsedBySection do
@ -4191,6 +4194,7 @@ constructor TPas2jsCompiler.Create;
begin
FOptions:=DefaultP2jsCompilerOptions;
FConverterGlobals:=TPasToJSConverterGlobals.Create(Self);
FResolverHub:=TPas2JSResolverHub.Create(Self);
FNamespaces:=TStringList.Create;
FDefines:=TStringList.Create;
FInsertFilenames:=TStringList.Create;
@ -4232,6 +4236,7 @@ destructor TPas2jsCompiler.Destroy;
FreeAndNil(FPostProcessorSupport);
FreeAndNil(FConfigSupport);
ConverterGlobals:=nil;
FreeAndNil(FResolverHub);
ClearDefines;
FreeAndNil(FDefines);

1
packages/pastojs/tests/tcgenerics.pas
View File

@ -67,6 +67,7 @@ type
procedure TestGenProc_TypeInfo;
procedure TestGenProc_Infer_Widen;
procedure TestGenProc_Infer_PassAsArg;
// ToDo: delay create: type TRec=record end; ... r:=GenProc<TRec>();
// ToDo: FuncName:= instead of Result:=
// generic methods

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

@ -111,6 +111,7 @@ type
FExpectedErrorNumber: integer;
FFilename: string;
FFileResolver: TStreamResolver;
FHub: TPas2JSResolverHub;
FJSImplementationSrc: TJSSourceElements;
FJSImplementationUses: TJSArrayLiteral;
FJSInitBody: TJSFunctionBody;
@ -216,6 +217,7 @@ type
public
constructor Create; override;
destructor Destroy; override;
property Hub: TPas2JSResolverHub read FHub;
property Source: TStringList read FSource;
property FileResolver: TStreamResolver read FFileResolver;
property Scanner: TPas2jsPasScanner read FScanner;
@ -1310,6 +1312,8 @@ begin
inherited SetUp;
FSkipTests:=false;
FSource:=TStringList.Create;
FHub:=TPas2JSResolverHub.Create(Self);
FModules:=TObjectList.Create(true);
FFilename:='test1.pp';
@ -1404,6 +1408,7 @@ begin
ReleaseAndNil(TPasElement(FModule){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
FEngine:=nil;
end;
FreeAndNil(FHub);
inherited TearDown;
{$IFDEF EnablePasTreeGlobalRefCount}
@ -1558,6 +1563,7 @@ begin
Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
Result.OnFindUnit:=@OnPasResolverFindUnit;
Result.OnLog:=@OnPasResolverLog;
Result.Hub:=Hub;
FModules.Add(Result);
end;

3
packages/regexpr/src/regexpr.pas
View File

@ -56,7 +56,8 @@ interface
{$BOOLEVAL OFF}
{$EXTENDEDSYNTAX ON}
{$LONGSTRINGS ON}
{$OPTIMIZATION ON}
{ use optimization settings passed via fpmake/make }
{OPTIMIZATION ON}
// ======== Define options for TRegExpr engine
{$DEFINE UseFirstCharSet} // Enable optimization, which finds possible first chars of input string

25
packages/winunits-base/src/comobj.pp
View File

@ -325,6 +325,7 @@ unit ComObj;
CoResumeClassObjects : TCoResumeClassObjectsProc = nil;
CoSuspendClassObjects : TCoSuspendClassObjectsProc = nil;
CoInitFlags : Longint = -1;
CoInitDisable : Boolean = False;
{$ifdef DEBUG_COM}
var printcom : boolean=true;
@ -1877,6 +1878,20 @@ const
Initialized : boolean = false;
var
Ole32Dll : HModule;
SaveInitProc : CodePointer;
procedure InitComObj;
begin
if SaveInitProc<>nil then
TProcedure(SaveInitProc)();
if not CoInitDisable then
{$ifndef wince}
if (CoInitFlags=-1) or not(assigned(ComObj.CoInitializeEx)) then
Initialized:=Succeeded(CoInitialize(nil))
else
{$endif wince}
Initialized:=Succeeded(ComObj.CoInitializeEx(nil, CoInitFlags));
end;
initialization
Uninitializing:=false;
@ -1893,12 +1908,10 @@ initialization
end;
if not(IsLibrary) then
{$ifndef wince}
if (CoInitFlags=-1) or not(assigned(comobj.CoInitializeEx)) then
Initialized:=Succeeded(CoInitialize(nil))
else
{$endif wince}
Initialized:=Succeeded(comobj.CoInitializeEx(nil, CoInitFlags));
begin
SaveInitProc:=InitProc;
InitProc:=@InitComObj;
end;
SafeCallErrorProc:=@SafeCallErrorHandler;
VarDispProc:=@ComObjDispatchInvoke;

2
rtl/freertos/consoleio.pp
View File

@ -169,7 +169,7 @@ finalization
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
{ to get a nice symify }
Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
dump_stack(pstdout^,ErrorBase);
dump_stack(pstdout^,ErrorBase,erroraddr);
Writeln(pstdout^,'');
End;
SysFlushStdIO;

2
rtl/freertos/system.pp
View File

@ -208,6 +208,7 @@ const calculated_cmdline:Pchar=nil;
{*****************************************************************************
Misc. System Dependent Functions
*****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_STACKTOP}
var
_stack_top: record end; external name '_stack_top';
@ -215,6 +216,7 @@ function StackTop: pointer;
begin
StackTop:=@_stack_top;
end;
{$endif FPC_SYSTEM_HAS_STACKTOP}
procedure haltproc;cdecl;external name '_haltproc';

3
rtl/linux/m68k/sighnd.inc
View File

@ -62,8 +62,7 @@ Procedure ResetFPU;
var
l_fpucw : longint;
begin
{$ifdef CPU68020}
{$if defined(FPU68881) or defined(FPUCOLDFIRE)}
asm
fmove.l fpcr,l_fpucw
end;

4
rtl/linux/m68k/sighndh.inc
View File

@ -23,8 +23,8 @@ type
pfpstate = ^tfpstate;
tfpstate = record
pcr,psr,fpiaddr : longint;
fpreg : array [0..7] of tfpreg;
pcr,psr,fpiaddr : longint;
fpreg : array [0..7] of tfpreg;
end;
{ as defined in asm_m68k/signal.h }

115
rtl/xtensa/xtensa.inc
View File

@ -31,27 +31,114 @@ begin
SysInitFPU;
end;
{$ifdef fpc_abi_windowed}
const
// Minimum call8 calls to force register spilling to stack for caller of forceSpilledRegs
spillcount = 6;
procedure forceSpilledRegs(n: uint32); assembler; public name 'forcespilledregs';
label
done, fin;
asm
beqz a2, done
addi a10, a2, -1
call8 forcespilledregs
done:
bnez a2, fin
movi a15, 0
fin:
end;
procedure fixCodeAddress(var addr: pointer);
begin
// Check if valid code address
if ptruint(addr) and $C0000000 >= $40000000 then
begin
// Replace windowed call prefix
addr:=codepointer((ptruint(addr)and$00FFFFFF) or $40000000);
// Rewind to call instruction address
dec(addr,3);
end
else
addr:=nil;
end;
{$endif fpc_abi_windowed}
{$IFNDEF INTERNAL_BACKTRACE}
{$define FPC_SYSTEM_HAS_GET_FRAME}
function get_frame:pointer;assembler;nostackframe;
asm
end;
{$define FPC_SYSTEM_HAS_GET_FRAME}
function get_frame:pointer;assembler;
label
done;
asm
{$ifdef fpc_abi_windowed}
// Force registers to spill onto stack
movi a10, spillcount
call8 forcespilledregs
// now get frame pointer of caller
addi a2, a1, -12
l32i a2, a2, 0
done:
{$else}
mov a2, a1
{$endif}
end;
{$ENDIF not INTERNAL_BACKTRACE}
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe;
asm
function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
begin
{$ifdef fpc_abi_windowed}
forceSpilledRegs(spillcount);
if (ptruint(framebp)>$3ff00000)and(ptruint(framebp)<$40000000) then
begin
get_caller_addr:=pointer((framebp-16)^);
fixCodeAddress(get_caller_addr);
end
else
get_caller_addr:=nil;
{$else}
get_caller_addr:=nil;
{$endif}
end;
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe;
asm
function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
begin
{$ifdef fpc_abi_windowed}
if (ptruint(framebp)>$3ff00000)and(ptruint(framebp)<$40000000) then
begin
forceSpilledRegs(spillcount);
get_caller_frame:=pointer((framebp-12)^);
end
else
get_caller_frame:=nil;
{$else}
get_caller_frame:=nil;
{$endif}
end;
{$ifdef fpc_abi_windowed}
{$define FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
procedure get_caller_stackinfo(var framebp : pointer; var addr : codepointer);
begin
if (ptruint(framebp)>$3ff00000)and(ptruint(framebp)<$40000000) then
begin
forceSpilledRegs(spillcount);
addr:=codepointer((framebp-16)^);
framebp := pointer((framebp-12)^);
fixCodeAddress(addr);
end
else
begin
addr:=nil;
framebp:=nil;
end;
end;
{$endif fpc_abi_windowed}
{$define FPC_SYSTEM_HAS_SPTR}
Function Sptr : pointer;assembler;
asm
@ -59,6 +146,16 @@ Function Sptr : pointer;assembler;
end;
{$define FPC_SYSTEM_HAS_STACKTOP}
// Interim fix for now, set to large address
// TODO: provide more realistic value, possibly by inspecting stack pointer
// when main or task is started
function StackTop: pointer;
begin
StackTop:=pointer($3fffffff);
end;
function InterLockedDecrement (var Target: longint) : longint;
var
temp_sreg : byte;

1
tests/tbs/tb0184.pp
View File

@ -2,6 +2,7 @@
{ in tp mode can't use the procvar in writeln OK 0.99.11 (PFV) }
{$ifdef fpc}{$mode tp}{$endif}
{$F+}
type tmpproc=function:longint;

1
tests/tbs/tb0218.pp
View File

@ -2,6 +2,7 @@
{ problem with procvars in tp mode OK 0.99.11 (PM) }
{$mode tp}
{$F+}
type proc = procedure(a : longint);
procedure test(b : longint);

1
tests/tbs/tb0251.pp
View File

@ -2,6 +2,7 @@
{ @procvar in tp mode bugss OK 0.99.13 (PFV) }
{$ifdef fpc}{$mode tp}{$endif}
{$F+}
function ReturnString: string;
begin

1
tests/tbs/tb0433.pp
View File

@ -4,6 +4,7 @@
type
codepointer = pointer;
{$endif fpc}
{$F+}
function times2(x : longint) : longint;

1
tests/test/cg/taddr2.pp
View File

@ -16,6 +16,7 @@ program taddr;
{$ifdef fpc}
{$mode tp}
{$endif}
{$F+}
procedure testprocvar;
begin

2
tests/test/tprocvar2.pp
View File

@ -1,7 +1,7 @@
{$F+}
{$ifdef fpc}
{$mode tp}
{$endif fpc}
{$F+}
type
tproc = procedure;

5
tests/webtbf/tw37476.pp Normal file
View File

@ -0,0 +1,5 @@
{ %fail }
var a : string = (a >= 'A') and (a <= 'F');
begin
end.

1
tests/webtbs/tw2059.pp
View File

@ -1,4 +1,5 @@
{$mode tp}
{$F+}
type ProcType = procedure(s:string);
GetProcType = function(s:string;var Proc:ProcType):boolean;

1
tests/webtbs/tw2268.pp
View File

@ -2,6 +2,7 @@
{ Submitted by "marco" on 2002-12-19 }
{ e-mail: marco@freepascal.org }
{$ifdef fpc}{$mode TP}{$endif}
{$F+}
function P1:longint; begin end;
function P2:longint; begin end;

15
utils/pas2js/libstub.pp
View File

@ -147,6 +147,17 @@ begin
Move(C[1],AErrorClass^,L);
end;
Procedure SetStubCreatorUnitAliasCallBack(P : PStubCreator; ACallBack : TUnitAliasCallBack; CallBackData : Pointer); stdcall;
begin
TStubCreator(P).OnUnitAlias:=ACallBack;
TStubCreator(P).OnUnitAliasData:=CallBackData;
end;
Procedure AddStubCreatorExtraUnit(P : PStubCreator; AUnitName : PAnsiChar); stdcall;
begin
TStubCreator(P).ExtraUnits:=AUnitName;
end;
exports
// Stub creator
GetStubCreator,
@ -160,7 +171,9 @@ exports
GetStubCreatorLastError,
AddStubCreatorDefine,
AddStubCreatorForwardClass,
ExecuteStubCreator;
AddStubCreatorExtraUnit,
ExecuteStubCreator,
SetStubCreatorUnitAliasCallBack;
end.

52
utils/pas2js/stubcreator.pp
View File

@ -19,9 +19,6 @@ interface
uses
Classes, SysUtils, strutils, inifiles, pscanner, pparser, pastree, iostream, paswrite;
Const
DTypesUnit = 'jsdelphisystem';
type
{ We have to override abstract TPasTreeContainer methods }
@ -36,6 +33,8 @@ type
TWriteCallBack = Procedure (Data : Pointer; AFileData : PAnsiChar; AFileDataLen: Int32); stdcall;
TWriteEvent = Procedure(AFileData : String) of object;
TUnitAliasCallBack = Function (Data: Pointer; AUnitName: PAnsiChar;
var AUnitNameMaxLen: Int32): boolean; {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF};
{ TStubCreator }
@ -45,6 +44,7 @@ type
FHeaderStream: TStream;
FIncludePaths: TStrings;
FInputFile: String;
FOnUnitAliasData: Pointer;
FOnWrite: TWriteEvent;
FOnWriteCallBack: TWriteCallBack;
FOutputFile: String;
@ -60,10 +60,12 @@ type
FCallBackData : Pointer;
FLastErrorClass : String;
FLastError : String;
FOnUnitAlias : TUnitAliasCallBack;
procedure SetDefines(AValue: TStrings);
procedure SetIncludePaths(AValue: TStrings);
procedure SetOnWrite(AValue: TWriteEvent);
procedure SetWriteCallback(AValue: TWriteCallBack);
function CheckUnitAlias(const AUnitName: String): String;
Protected
procedure DoExecute;virtual;
Procedure DoWriteEvent; virtual;
@ -81,9 +83,11 @@ type
// OutputStream can be used combined with write callbacks.
Property OutputStream : TStream Read FOutputStream Write FOutputStream;
Property HeaderStream : TStream Read FHeaderStream Write FHeaderStream;
Property OnUnitAlias: TUnitAliasCallBack read FOnUnitAlias Write FOnUnitAlias;
Property OnUnitAliasData : Pointer Read FOnUnitAliasData Write FOnUnitAliasData;
Property OnWriteCallBack : TWriteCallBack Read FOnWriteCallBack Write SetWriteCallback;
Property CallbackData : Pointer Read FCallBackData Write FCallBackData;
Property ExtraUnits : String Read FExtraUnits write FExtraUnits;
Published
Property Defines : TStrings Read FDefines Write SetDefines;
Property ConfigFileName : String Read FConfigFile Write FConfigFile;
@ -97,6 +101,8 @@ type
Implementation
uses Math;
ResourceString
SErrNoDestGiven = 'No destination file specified.';
SErrNoSourceParsed = 'Parsing produced no file.';
@ -131,6 +137,23 @@ begin
FWriteStream:=TStringStream.Create('');
end;
function TStubCreator.CheckUnitAlias(const AUnitName: String): String;
const
MAX_UNIT_NAME_LENGTH = 255;
var
UnitMaxLenthName: Integer;
begin
Result := AUnitName;
UnitMaxLenthName := Max(MAX_UNIT_NAME_LENGTH, Result.Length);
SetLength(Result, UnitMaxLenthName);
if FOnUnitAlias(OnUnitAliasData, @Result[1], UnitMaxLenthName) then
Result := LeftStr(PChar(Result), UnitMaxLenthName);
end;
procedure TStubCreator.DoWriteEvent;
Var
@ -279,7 +302,7 @@ end;
Function TStubCreator.GetModule : TPasModule;
function TStubCreator.GetModule: TPasModule;
Var
SE : TSimpleEngine;
@ -327,7 +350,8 @@ begin
end;
end;
function TStubCreator.MaybeGetFileStream(AStream: TStream; const AFileName: String; AfileMode : Word) : TStream;
function TStubCreator.MaybeGetFileStream(AStream: TStream;
const AFileName: String; aFileMode: Word): TStream;
begin
If Assigned(AStream) then
Result:=AStream
@ -359,12 +383,11 @@ begin
end;
procedure TStubCreator.WriteModule(M : TPAsModule);
procedure TStubCreator.WriteModule(M: TPasModule);
Var
F,H : TStream;
W : TPasWriter;
U : String;
begin
W:=Nil;
@ -385,14 +408,11 @@ begin
end;
W:=TPasWriter.Create(F);
W.Options:=FOptions;
U:=FExtraUnits;
if Pos(LowerCase(DTypesUnit),LowerCase(U)) = 0 then
begin
if (U<>'') then
U:=','+U;
U:=DTypesUnit+U;
end;
W.ExtraUnits:=U;
W.ExtraUnits:=FExtraUnits;
if Assigned(FOnUnitAlias) then
W.OnUnitAlias:=@CheckUnitAlias;
if FIndentSize<>-1 then
W.IndentSize:=FIndentSize;
if FLineNumberWidth>0 then