* synchronized with trunk

git-svn-id: branches/wasm@47032 -

compiler/nadd.pas

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

packages/fcl-passrc/src/pasresolver.pp

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

packages/fcl-passrc/tests/tcresolver.pas

@@ -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);

packages/fcl-passrc/tests/tcuseanalyzer.pas

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

rtl/inc/compproc.inc

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

rtl/inc/except.inc

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

rtl/inc/system.inc

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

rtl/inc/systemh.inc

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

rtl/nds/system.pp

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