fcl-passrc: resolver: var modifier absolute

git-svn-id: trunk@37812 -

packages/fcl-passrc/src/pasresolver.pp

@@ -168,21 +168,20 @@ Works:
   - array var
   - function: enumerator
   - class
+- var modifier 'absolute'
 
 ToDo:
-- Add test:  test1 uses unit1, unit1 uses unit2, test1 references an identifier 'unit2' -> fail
 - for..in..do
    - operator
 - range checking:
   - indexedprop[param]
   - case-of unique
   - defaultvalue
+- scoped enum
 - $writableconst off $J-
 - fail to write a loop var inside the loop
 - warn: create class with abstract methods
-- classes - TPasClassType
-   - nested var, const
-   - nested types
+- nested classes
 - records - TPasRecordType,
    - const  TRecordValues
    - function default(record type): record
@@ -4306,6 +4305,9 @@ begin
 end;
 
 procedure TPasResolver.FinishVariable(El: TPasVariable);
+var
+  ResolvedAbs: TPasResolverResult;
+  C: TClass;
 begin
   if (El.Visibility=visPublished) then
     begin
@@ -4317,6 +4319,33 @@ begin
     ResolveExpr(El.Expr,rraRead);
     CheckAssignCompatibility(El,El.Expr,true);
     end;
+  if El.AbsoluteExpr<>nil then
+    begin
+    if El.VarType=nil then
+      RaiseMsg(20171225235125,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
+    if vmExternal in El.VarModifiers then
+      RaiseMsg(20171226104221,nXModifierMismatchY,sXModifierMismatchY,
+        ['absolute','external'],El.AbsoluteExpr);
+    {$IFDEF VerbosePasResolver}
+    writeln('TPasResolver.FinishVariable El=',GetObjName(El),' Absolute="',GetObjName(El.AbsoluteExpr),'"');
+    {$ENDIF}
+    ResolveExpr(El.AbsoluteExpr,rraRead);
+    ComputeElement(El.AbsoluteExpr,ResolvedAbs,[rcNoImplicitProc]);
+    if (not (rrfReadable in ResolvedAbs.Flags))
+        or (ResolvedAbs.IdentEl=nil) then
+      RaiseMsg(20171225234734,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
+    C:=ResolvedAbs.IdentEl.ClassType;
+    if (C=TPasVariable)
+        or (C=TPasArgument)
+        or ((C=TPasConst) and (TPasConst(ResolvedAbs.IdentEl).VarType<>nil)) then
+    else
+      RaiseMsg(20171225235203,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
+    if not (rrfReadable in ResolvedAbs.Flags) then
+      RaiseMsg(20171225235249,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
+    // check for cycles
+    if ResolvedAbs.IdentEl=El then
+      RaiseMsg(20171226000703,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
+    end;
   EmitTypeHints(El,El.VarType);
 end;
 

packages/fcl-passrc/src/pastree.pp

@@ -831,7 +831,8 @@ type
     LibraryName : TPasExpr; // libname of modifier external
     ExportName : TPasExpr; // symbol name of modifier external, export and public
     Modifiers : string;
-    AbsoluteLocation : String;
+    AbsoluteLocation : String deprecated; // deprecated in fpc 3.1.1
+    AbsoluteExpr: TPasExpr;
     Expr: TPasExpr;
     Function Value : String;
   end;

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -984,7 +984,7 @@ var
   Params: TPasExprArray;
   i: Integer;
   BuiltInProc: TResElDataBuiltInProc;
-  ParamResolved: TPasResolverResult;
+  ParamResolved, ResolvedAbs: TPasResolverResult;
   Decl: TPasElement;
 begin
   if El=nil then exit;
@@ -998,6 +998,13 @@ begin
     Decl:=Ref.Declaration;
     UseElement(Decl,Ref.Access,false);
 
+    if (Decl is TPasVariable) and (TPasVariable(Decl).AbsoluteExpr<>nil) then
+      begin
+      Resolver.ComputeElement(TPasVariable(Decl).AbsoluteExpr,ResolvedAbs,[rcNoImplicitProc]);
+      if ResolvedAbs.IdentEl is TPasVariable then
+        UseVariable(TPasVariable(ResolvedAbs.IdentEl),Ref.Access,false);
+      end;
+
     if Resolver.IsNameExpr(El) then
       begin
       if Ref.WithExprScope<>nil then
@@ -1050,6 +1057,7 @@ begin
       or (C=TSelfExpr)
       or (C=TBoolConstExpr)
       or (C=TNilExpr) then
+    // ok
   else if C=TBinaryExpr then
     begin
     UseExpr(TBinaryExpr(El).left);
@@ -1514,6 +1522,10 @@ begin
       // ToDo: Prop.ImplementsFunc
       // ToDo: Prop.DispIDExpr
       // see UsePublished: Prop.StoredAccessor, Prop.DefaultExpr
+      end;
+    if El.AbsoluteExpr<>nil then
+      begin
+
       end;
     end
   else

packages/fcl-passrc/src/pparser.pp

@@ -79,6 +79,7 @@ const
   nParserNoConstRangeAllowed = 2052;
   nErrRecordVariablesNotAllowed = 2053;
   nParserResourcestringsMustBeGlobal = 2054;
+  nParserOnlyOneVariableCanBeAbsolute = 2055;
 
 // resourcestring patterns of messages
 resourcestring
@@ -136,6 +137,7 @@ resourcestring
   SParserExpectedExternalClassName = 'Expected external class name';
   SParserNoConstRangeAllowed = 'Const ranges are not allowed';
   SParserResourcestringsMustBeGlobal = 'Resourcestrings can be only static or global';
+  SParserOnlyOneVariableCanBeAbsolute = 'Only one variable can be absolute';
 
 type
   TPasScopeType = (
@@ -263,7 +265,7 @@ type
     function GetCurrentModeSwitches: TModeSwitches;
     Procedure SetCurrentModeSwitches(AValue: TModeSwitches);
     function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr; ExternalClass : Boolean): string;
-    function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
+    function GetVariableValueAndLocation(Parent : TPasElement; Out Value: TPasExpr; Out AbsoluteExpr: TPasExpr; Out Location: String): Boolean;
     procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
     procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier);
     procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
@@ -3764,28 +3766,31 @@ begin
 end;
 
 function TPasParser.GetVariableValueAndLocation(Parent: TPasElement; out
-  Value: TPasExpr; out Location: String): Boolean;
+  Value: TPasExpr; out AbsoluteExpr: TPasExpr; out Location: String): Boolean;
 
 begin
   Value:=Nil;
+  AbsoluteExpr:=Nil;
+  Location:='';
   NextToken;
   Result:=CurToken=tkEqual;
   if Result then
     begin
     NextToken;
     Value := DoParseConstValueExpression(Parent);
-//    NextToken;
     end;
   if (CurToken=tkAbsolute) then
     begin
     Result:=True;
     ExpectIdentifier;
     Location:=CurTokenText;
+    AbsoluteExpr:=CreatePrimitiveExpr(Parent,pekIdent,CurTokenText);
     NextToken;
     While CurToken=tkDot do
       begin
       ExpectIdentifier;
       Location:=Location+'.'+CurTokenText;
+      AbsoluteExpr:=CreateBinaryExpr(Parent,AbsoluteExpr,CreatePrimitiveExpr(Parent,pekIdent,CurTokenText),eopSubIdent);
       NextToken;
       end;
     UnGetToken;
@@ -3866,18 +3871,20 @@ procedure TPasParser.ParseVarList(Parent: TPasElement; VarList: TFPList;
 
 var
   i, OldListCount: Integer;
-  Value , aLibName, aExpName: TPasExpr;
+  Value , aLibName, aExpName, AbsoluteExpr: TPasExpr;
   VarType: TPasType;
   VarEl: TPasVariable;
   H : TPasMemberHints;
   VarMods: TVariableModifiers;
-  D,Mods,Loc: string;
+  D,Mods,AbsoluteLocString: string;
   OldForceCaret,ok,ExternalClass: Boolean;
 
 begin
   Value:=Nil;
   aLibName:=nil;
   aExpName:=nil;
+  AbsoluteExpr:=nil;
+  AbsoluteLocString:='';
   OldListCount:=VarList.Count;
   ok:=false;
   try
@@ -3913,9 +3920,15 @@ begin
 
     H:=CheckHint(Nil,False);
     If Full then
-      GetVariableValueAndLocation(Parent,Value,Loc);
-    if (Value<>nil) and (VarList.Count>OldListCount+1) then
-      ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized);
+      GetVariableValueAndLocation(Parent,Value,AbsoluteExpr,AbsoluteLocString);
+    if (VarList.Count>OldListCount+1) then
+      begin
+      // multiple variables
+      if Value<>nil then
+        ParseExc(nParserOnlyOneVariableCanBeAbsolute,SParserOnlyOneVariableCanBeAbsolute);
+      if Value<>nil then
+        ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized);
+      end;
     TPasVariable(VarList[OldListCount]).Expr:=Value;
     Value:=nil;
 
@@ -3953,22 +3966,28 @@ begin
         VarEl.Hints:=H;
       VarEl.Modifiers:=Mods;
       VarEl.VarModifiers:=VarMods;
-      VarEl.AbsoluteLocation:=Loc;
+      VarEl.{%H-}AbsoluteLocation:=AbsoluteLocString;
+      if AbsoluteExpr<>nil then
+        begin
+        VarEl.AbsoluteExpr:=AbsoluteExpr;
+        AbsoluteExpr:=nil;
+        end;
       if aLibName<>nil then
         begin
         VarEl.LibraryName:=aLibName;
-        aLibName.AddRef;
+        aLibName:=nil;
         end;
       if aExpName<>nil then
         begin
         VarEl.ExportName:=aExpName;
-        aExpName.AddRef;
+        aExpName:=nil;
         end;
       end;
     ok:=true;
   finally
     if aLibName<>nil then aLibName.Release;
     if aExpName<>nil then aExpName.Release;
+    if AbsoluteExpr<>nil then AbsoluteExpr.Release;
     if not ok then
       begin
         if Value<>nil then Value.Release;

packages/fcl-passrc/tests/tcbaseparser.pas

@@ -67,11 +67,12 @@ Type
     Procedure CheckHint(AHint : TPasMemberHint);
     Function AssertExpression(Const Msg: String; AExpr : TPasExpr; aKind : TPasExprKind; AClass : TClass) : TPasExpr;
     Function AssertExpression(Const Msg: String; AExpr : TPasExpr; aKind : TPasExprKind; AValue : String) : TPrimitiveExpr;
+    Function AssertExpression(Const Msg: String; AExpr : TPasExpr; OpCode : TExprOpCode) : TBinaryExpr;
     Procedure AssertExportSymbol(Const Msg: String; AIndex : Integer; AName,AExportName : String; AExportIndex : Integer = -1);
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TPasExprKind); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TLoopType); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TPasObjKind); overload;
-    Procedure AssertEquals(Const Msg : String; AExpected, AActual: TexprOpcode); overload;
+    Procedure AssertEquals(Const Msg : String; AExpected, AActual: TExprOpCode); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TPasMemberHint); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TCallingConvention); overload;
     Procedure AssertEquals(Const Msg : String; AExpected, AActual: TArgumentAccess); overload;
@@ -711,6 +712,13 @@ begin
   AssertEquals(Msg+': Primitive expression value',AValue,TPrimitiveExpr(AExpr).Value);
 end;
 
+function TTestParser.AssertExpression(const Msg: String; AExpr: TPasExpr;
+  OpCode: TExprOpCode): TBinaryExpr;
+begin
+  Result:=AssertExpression(Msg,AExpr,pekBinary,TBinaryExpr) as TBinaryExpr;
+  AssertEquals(Msg+': Binary opcode',OpCode,TBinaryExpr(AExpr).OpCode);
+end;
+
 procedure TTestParser.AssertExportSymbol(const Msg: String; AIndex: Integer;
   AName, AExportName: String; AExportIndex: Integer);
 
@@ -765,7 +773,7 @@ begin
 end;
 
 procedure TTestParser.AssertEquals(const Msg: String; AExpected,
-  AActual: TexprOpcode);
+  AActual: TExprOpCode);
 begin
   AssertEquals(Msg,GetEnumName(TypeInfo(TexprOpcode),Ord(AExpected)),
                    GetEnumName(TypeInfo(TexprOpcode),Ord(AActual)));

packages/fcl-passrc/tests/tcresolver.pas

@@ -393,6 +393,7 @@ type
     Procedure TestProc_FunctionResult_DeclProc;
     Procedure TestProc_TypeCastFunctionResult;
     Procedure TestProc_ImplicitCalls;
+    Procedure TestProc_Absolute;
     // ToDo: fail builtin functions in constant with non const param
 
     // record
@@ -5964,6 +5965,19 @@ begin
     end;
 end;
 
+procedure TTestResolver.TestProc_Absolute;
+begin
+  StartProgram(false);
+  Add([
+  'procedure DoIt(p: Pointer);',
+  'var',
+  '  s: string absolute p;',
+  '  t: array of char absolute s;',
+  'begin',
+  'end;',
+  'begin']);
+end;
+
 procedure TTestResolver.TestRecord;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -109,6 +109,7 @@ type
     procedure TestM_Hint_FunctionResultDoesNotSeemToBeSet_Abstract;
     procedure TestM_Hint_FunctionResultRecord;
     procedure TestM_Hint_FunctionResultPassRecordElement;
+    procedure TestM_Hint_AbsoluteVar;
 
     // whole program optimization
     procedure TestWP_LocalVar;
@@ -249,7 +250,6 @@ begin
       end;
     aMarker:=aMarker^.Next;
     end;
-
 end;
 
 procedure TCustomTestUseAnalyzer.CheckUseAnalyzerHint(MsgType: TMessageType;
@@ -1550,6 +1550,22 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_Hint_AbsoluteVar;
+begin
+  StartProgram(false);
+  Add([
+  'procedure {#DoIt_used}DoIt({#p_used}p: pointer);',
+  'var',
+  '  {#i_used}i: longint absolute p;',
+  '  {#j_used}j: longint absolute i;',
+  'begin',
+  '  if j=3 then ;',
+  'end;',
+  'begin',
+  '  DoIt(nil);']);
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestWP_LocalVar;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcvarparser.pas

@@ -189,21 +189,31 @@ procedure TTestVarParser.TestSimpleVarAbsolute;
 begin
   ParseVar('q absolute v','');
   AssertVariableType('q');
-  AssertEquals('correct absolute location','v',TheVar.AbsoluteLocation);
+  AssertExpression('correct absolute location',TheVar.AbsoluteExpr,pekIdent,'v');
 end;
 
 procedure TTestVarParser.TestSimpleVarAbsoluteDot;
+var
+  B: TBinaryExpr;
 begin
   ParseVar('q absolute v.w','');
   AssertVariableType('q');
-  AssertEquals('correct absolute location','v.w',TheVar.AbsoluteLocation);
+  B:=AssertExpression('binary',TheVar.AbsoluteExpr,eopSubIdent);
+  AssertExpression('correct absolute expr v',B.left,pekIdent,'v');
+  AssertExpression('correct absolute expr w',B.right,pekIdent,'w');
 end;
 
 procedure TTestVarParser.TestSimpleVarAbsolute2Dots;
+var
+  B: TBinaryExpr;
 begin
   ParseVar('q absolute v.w.x','');
   AssertVariableType('q');
-  AssertEquals('correct absolute location','v.w.x',TheVar.AbsoluteLocation);
+  B:=AssertExpression('binary',TheVar.AbsoluteExpr,eopSubIdent);
+  AssertExpression('correct absolute expr x',B.right,pekIdent,'x');
+  B:=AssertExpression('binary',B.left,eopSubIdent);
+  AssertExpression('correct absolute expr w',B.right,pekIdent,'w');
+  AssertExpression('correct absolute expr v',B.left,pekIdent,'v');
 end;
 
 procedure TTestVarParser.TestVarProcedure;