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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47032 -
This commit is contained in:
nickysn 2020-10-01 21:09:28 +00:00
commit 233cf7ab62
9 changed files with 197 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
compiler/nadd.pas
View File

@ -506,6 +506,7 @@ implementation
b : boolean;
cr, cl : Tconstexprint;
v2p, c2p, c1p, v1p: pnode;
p1,p2: TConstPtrUInt;
begin
result:=nil;
l1:=0;
@ -1330,6 +1331,33 @@ implementation
exit;
end;
if is_constpointernode(left) and is_constpointernode(right) then
begin
p1:=0;
p2:=0;
if left.nodetype=pointerconstn then
p1:=tpointerconstnode(left).value;
if right.nodetype=pointerconstn then
p2:=tpointerconstnode(right).value;
case nodetype of
equaln:
result:=cordconstnode.create(ord(p1=p2),bool8type,false);
unequaln:
result:=cordconstnode.create(ord(p1<>p2),bool8type,false);
gtn:
result:=cordconstnode.create(ord(p1>p2),bool8type,false);
ltn:
result:=cordconstnode.create(ord(p1<p2),bool8type,false);
gten:
result:=cordconstnode.create(ord(p1>=p2),bool8type,false);
lten:
result:=cordconstnode.create(ord(p1<=p2),bool8type,false);
else
Internalerror(2020100101);
end;
exit;
end;
{ slow simplifications }
if cs_opt_level2 in current_settings.optimizerswitches then
begin

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

@ -1635,7 +1635,7 @@ type
procedure ResolveStatementConditionExpr(El: TPasExpr); virtual;
procedure ResolveNameExpr(El: TPasExpr; const aName: string; Access: TResolvedRefAccess); virtual;
procedure ResolveInherited(El: TInheritedExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveInheritedCall(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveInheritedName(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveBinaryExpr(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveSubIdent(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
procedure ResolveParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
@ -10303,7 +10303,7 @@ begin
and (TBinaryExpr(El.Parent).OpCode=eopNone) then
begin
// e.g. 'inherited Proc;'
ResolveInheritedCall(TBinaryExpr(El.Parent),Access);
ResolveInheritedName(TBinaryExpr(El.Parent),Access);
exit;
end;
@ -10377,11 +10377,11 @@ begin
sAbstractMethodsCannotBeCalledDirectly,[],El);
end;
procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr;
procedure TPasResolver.ResolveInheritedName(El: TBinaryExpr;
Access: TResolvedRefAccess);
// El.OpCode=eopNone
// El.left is TInheritedExpr
// El.right is the identifier and parameters
// El.right is the identifier and/or paramexpr
var
SelfScope: TPasProcedureScope;
ClassRecScope: TPasClassOrRecordScope;
@ -10393,7 +10393,7 @@ var
InhScope: TPasInheritedScope;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El));
writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El),' Access=',Access);
{$ENDIF}
SelfScope:=GetCurrentSelfScope(El);
@ -10453,15 +10453,20 @@ begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.ResolveBinaryExpr left=',GetObjName(El.left),' right=',GetObjName(El.right),' opcode=',OpcodeStrings[El.OpCode]);
{$ENDIF}
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
case El.OpCode of
eopNone:
case El.Kind of
pekRange:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveExpr(El.right,rraRead);
end;
else
if El.left.ClassType=TInheritedExpr then
begin
ResolveExpr(El.left,Access);
end
else
begin
{$IFDEF VerbosePasResolver}
@ -10493,9 +10498,17 @@ begin
eopIs,
eopAs,
eopSymmetricaldifference:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveExpr(El.right,rraRead);
end;
eopSubIdent:
begin
ResolveExpr(El.left,rraRead);
if El.right=nil then exit;
ResolveSubIdent(El,Access);
end;
else
RaiseNotYetImplemented(20160922163459,El,OpcodeStrings[El.OpCode]);
end;

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

@ -725,6 +725,7 @@ type
Procedure TestPropertyArgs2;
Procedure TestPropertyArgsWithDefaultsFail;
Procedure TestPropertyArgs_StringConstDefault;
Procedure TestPropertyInherited;
Procedure TestClassProperty;
Procedure TestClassPropertyNonStaticFail;
Procedure TestClassPropertyNonStaticAllow;
@ -12997,6 +12998,62 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestPropertyInherited;
var
aMarker: PSrcMarker;
Elements: TFPList;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add(['type',
' TObject = class',
' FA: word;',
' property A: word read FA write FA;',
' end;',
' TBird = class(TObject)',
' FB: word;',
' procedure Run(Value: word);',
' property A read FB write FB;',
' end;',
'procedure TBird.Run(Value: word);',
'begin',
' inherited {#A}A:=Value;',
//' Value:=inherited {@A1}A;',
'end;',
'begin',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
writeln('TTestResolver.TestPropertyInherited ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestPropertyInherited ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' CustomData=',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProperty) then continue;
writeln('TTestResolver.TestPropertyInherited ',GetObjName(Ref.Declaration),' Ref.Access=',Ref.Access);
case aMarker^.Identifier of
'A': if Ref.Access<>rraAssign then
RaiseErrorAtSrcMarker('expected property write at "#'+aMarker^.Identifier+', but got "'+dbgs(Ref.Access),aMarker);
'B': if Ref.Access<>rraRead then
RaiseErrorAtSrcMarker('expected property read at "#'+aMarker^.Identifier+', but got "'+dbgs(Ref.Access),aMarker);
end;
break;
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestClassProperty;
begin
StartProgram(false);

84
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -80,6 +80,8 @@ type
procedure TestM_Class_Property;
procedure TestM_Class_PropertyProtected;
procedure TestM_Class_PropertyOverride;
procedure TestM_Class_PropertyOverride2;
procedure TestM_Class_PropertyInherited;
procedure TestM_Class_MethodOverride;
procedure TestM_Class_MethodOverride2;
procedure TestM_ClassInterface_Corba;
@ -1178,20 +1180,74 @@ end;
procedure TTestUseAnalyzer.TestM_Class_PropertyOverride;
begin
StartProgram(false);
Add('type');
Add(' {#integer_used}integer = longint;');
Add(' {tobject_used}TObject = class');
Add(' {#fa_used}FA: integer;');
Add(' {#fb_notused}FB: integer;');
Add(' property {#obj_a_notused}A: integer read FA write FB;');
Add(' end;');
Add(' {tmobile_used}TMobile = class(TObject)');
Add(' {#fc_used}FC: integer;');
Add(' property {#mob_a_used}A write FC;');
Add(' end;');
Add('var {#m_used}M: TMobile;');
Add('begin');
Add(' M.A:=M.A;');
Add(['type',
' {#integer_used}integer = longint;',
' {tobject_used}TObject = class',
' {#fa_used}FA: integer;',
' {#fb_notused}FB: integer;',
' property {#obj_a_notused}A: integer read FA write FB;',
' end;',
' {tmobile_used}TMobile = class(TObject)',
' {#fc_used}FC: integer;',
' property {#mob_a_used}A write FC;',
' end;',
'var {#m_used}M: TMobile;',
'begin',
' M.A:=M.A;']);
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_Class_PropertyOverride2;
begin
StartProgram(false);
Add(['type',
' {#integer_used}integer = longint;',
' {tobject_used}TObject = class',
' {#fa_used}FA: integer;',
' {#fb_used}FB: integer;',
' property {#obj_a_used}A: integer read FA write FB;',
' end;',
' {tmobile_used}TMobile = class(TObject)',
' {#fc_notused}FC: integer;',
' property {#mob_a_notused}A write FC;',
' end;',
'var',
' {#m_used}M: TMobile;',
' {#o_used}o: TObject;',
'begin',
' o:=m;',
' o.A:=o.A;',
'']);
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_Class_PropertyInherited;
begin
StartProgram(false);
Add(['type',
' {tobject_used}TObject = class',
' {#fa_used}FA: word;',
' {#fb_used}FB: word;',
' property {#obj_a_used}A: word write FA;',
' property {#obj_b_used}B: word read FB;',
' end;',
' {tbird_used}TBird = class(TObject)',
' {#fc_notused}FC: word;',
' {#fd_notused}FD: word;',
' procedure {#run_used}Run({#run_value_used}Value: word);',
' property {#bird_a_notused}A write FC;',
' property {#bird_b_notused}B write FD;',
' end;',
'procedure TBird.Run(Value: word);',
'begin',
' inherited A:=Value;',
' Value:=inherited B;',
'end;',
'var',
' {#b_used}b: TBird;',
'begin',
' b.Run(3);',
'']);
AnalyzeProgram;
end;

2
rtl/inc/compproc.inc
View File

@ -797,7 +797,7 @@ Procedure fpc_do_exit; compilerproc;
Procedure fpc_HandleErrorAddrFrame (Errno : longint;addr,frame : pointer); compilerproc;
}
Procedure fpc_lib_exit; compilerproc;
Procedure fpc_HandleError (Errno : longint); compilerproc;
Procedure fpc_HandleError (Errno : TExitCode); compilerproc;
procedure fpc_AbstractErrorIntern;compilerproc;
procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); compilerproc;

4
rtl/inc/except.inc
View File

@ -91,7 +91,7 @@ var
Newobj : PExceptObject;
_ExceptObjectStack : ^PExceptObject;
framebufsize,
framecount : longint;
framecount : PtrInt;
frames : PCodePointer;
prev_frame,
curr_frame : Pointer;
@ -113,8 +113,8 @@ begin
curr_frame:=AFrame;
curr_addr:=AnAddr;
frames:=nil;
framebufsize:=0;
framecount:=0;
framebufsize:=0;
{ The frame pointer of this procedure is used as initial stack bottom value. }
prev_frame:=get_frame;
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and

18
rtl/inc/system.inc
View File

@ -33,10 +33,10 @@ type
{$endif}
{$endif FPC_HAS_FEATURE_EXITCODE}
Procedure HandleError (Errno : Longint); external name 'FPC_HANDLEERROR';
Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
Procedure HandleError (Errno : TExitCode); external name 'FPC_HANDLEERROR';
Procedure HandleErrorFrame (Errno : TExitCode;frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : TExitCode;addr : CodePointer; frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : TExitCode;addr : CodePointer; frame : Pointer); forward;
{$ifdef FPC_HAS_FEATURE_TEXTIO}
type
@ -1268,7 +1268,7 @@ begin
end;
Procedure Halt(ErrNum: Longint);noreturn;
Procedure Halt(ErrNum: TExitCode);noreturn;
Begin
{$ifdef FPC_HAS_FEATURE_EXITCODE}
{$ifdef FPC_LIMITED_EXITCODE}
@ -1320,7 +1320,7 @@ end;
{$endif FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
Procedure HandleErrorAddrFrame (Errno : TExitCode;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
begin
If codepointer(ErrorProc)<>Nil then
ErrorProc(Errno,addr,frame);
@ -1337,13 +1337,13 @@ end;
{ This is used internally by system skip first level,
and generated the same output as before, when
HandleErrorFrame function was used internally. }
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
Procedure HandleErrorAddrFrameInd (Errno : TExitCode;addr : CodePointer; frame : Pointer);
begin
get_caller_stackinfo (frame, addr);
HandleErrorAddrFrame (Errno,addr,frame);
end;
Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
Procedure HandleErrorFrame (Errno : TExitCode;frame : Pointer);
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.
@ -1354,7 +1354,7 @@ begin
end;
procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
procedure fpc_handleerror (Errno : TExitCode); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.

8
rtl/inc/systemh.inc
View File

@ -403,6 +403,7 @@ Type
CodePointer = Pointer;
CodePtrInt = PtrInt;
CodePtrUInt = PtrUInt;
TExitCode = Longint;
{$endif CPU64}
{$ifdef CPU32}
@ -415,6 +416,7 @@ Type
CodePointer = Pointer;
CodePtrInt = PtrInt;
CodePtrUInt = PtrUInt;
TExitCode = Longint;
{$endif CPU32}
{$ifdef CPU16}
@ -446,6 +448,8 @@ Type
{$endif}
ValSInt = Integer;
ValUInt = Word;
{ this is TP compatible }
TExitCode = Word;
{$endif CPU16}
{$if defined(VER2) or defined(VER3_0)}
@ -774,7 +778,7 @@ const
ModuleIsCpp : Boolean = FALSE;
var
ExitCode : Longint; public name 'operatingsystem_result';
ExitCode : TExitCode; public name 'operatingsystem_result';
RandSeed : Cardinal;
{ Delphi compatibility }
@ -1604,7 +1608,7 @@ procedure DumpExceptionBacktrace(var f:text);
Procedure RunError(w:Word);noreturn;
Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif}noreturn;
Procedure Halt(errnum:Longint);noreturn;
Procedure Halt(errnum:TExitCode);noreturn;
{$ifdef FPC_HAS_FEATURE_HEAP}
Procedure AddExitProc(Proc:TProcedure);
{$endif FPC_HAS_FEATURE_HEAP}

5
rtl/nds/system.pp
View File

@ -26,7 +26,10 @@ interface
{$define FPC_HAS_FEATURE_THREADING}
{$define CPUARM_HAS_UMULL}
{$define CPUARM_HAS_CLZ}
{$ifdef FPC_HAS_INTERNAL_BSR}
{$define CPUARM_HAS_CLZ}
{$endif def FPC_HAS_INTERNAL_BSR}
{$i systemh.inc}
{$i ndsbiosh.inc}