fcl-passrc: implemented @@ memory address operator in scanner, parser and resolver

git-svn-id: trunk@37108 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -141,6 +141,7 @@ const
   nOverflowInArithmeticOperation = 3068;
   nDivByZero = 3069;
   nRangeCheckInSetConstructor = 3070;
+  nIncompatibleTypesGotParametersExpected = 3071;
 
 // resourcestring patterns of messages
 resourcestring
@@ -214,6 +215,7 @@ resourcestring
   sOverflowInArithmeticOperation = 'Overflow in arithmetic operation';
   sDivByZero = 'Division by zero';
   sRangeCheckInSetConstructor = 'range check error in set constructor or duplicate set element';
+  sIncompatibleTypesGotParametersExpected = 'Incompatible types, got %s parameters, expected %s';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -150,13 +150,13 @@ Works:
   - a:=value
 
 ToDo:
+- @@
 - range checking:
   - arr[index]
   - indexedprop[param]
   - case-of unique
   - defaultvalue
   - stored
-- @@
 - fail to write a loop var inside the loop
 - warn: create class with abstract methods
 - classes - TPasClassType
@@ -10762,7 +10762,14 @@ begin
     end;
   ProcArgs1:=Proc1.Args;
   ProcArgs2:=Proc2.Args;
-  if ProcArgs1.Count<>ProcArgs2.Count then exit;
+  if ProcArgs1.Count<>ProcArgs2.Count then
+    begin
+    if RaiseOnIncompatible then
+      RaiseMsg(20170902142829,nIncompatibleTypesGotParametersExpected,
+        sIncompatibleTypesGotParametersExpected,
+        [IntToStr(ProcArgs1.Count),IntToStr(ProcArgs2.Count)],ErrorEl);
+    exit;
+    end;
   for i:=0 to ProcArgs1.Count-1 do
     begin
     {$IFDEF VerbosePasResolver}
@@ -11279,7 +11286,7 @@ begin
         // for example  ProcVar:=Proc
         if CheckProcTypeCompatibility(TPasProcedureType(LHS.TypeEl),
             TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then
-          Result:=cExact;
+          exit(cExact);
         end;
       end
     else if LBT=btPointer then
@@ -11413,7 +11420,7 @@ begin
   if RErrorEl=nil then RErrorEl:=LErrorEl;
   // check if the RHS is type compatible to LHS
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.CheckEqualCompatibility LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS));
+  writeln('TPasResolver.CheckEqualResCompatibility LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS));
   {$ENDIF}
   if not (rrfReadable in LHS.Flags) then
     begin
@@ -12880,7 +12887,7 @@ begin
     ComputeBinaryExpr(TBinaryExpr(El),ResolvedEl,Flags,StartEl)
   else if ElClass=TUnaryExpr then
     begin
-    if TUnaryExpr(El).OpCode=eopAddress then
+    if TUnaryExpr(El).OpCode in [eopAddress,eopMemAddress] then
       ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags+[rcNoImplicitProc],StartEl)
     else
       ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags,StartEl);
@@ -12906,6 +12913,13 @@ begin
           end
         else
           RaiseMsg(20170216152535,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
+      eopMemAddress:
+        begin
+        if (ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasProcedureType) then
+          exit
+        else
+          RaiseMsg(20170902145547,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
+        end;
     end;
     RaiseNotYetImplemented(20160926142426,El);
     end

packages/fcl-passrc/src/pastree.pp

@@ -175,7 +175,7 @@ type
                  eopEqual, eopNotEqual,  // Logical
                  eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual, // ordering
                  eopIn,eopIs,eopAs, eopSymmetricaldifference, // Specials
-                 eopAddress, eopDeref, // Pointers
+                 eopAddress, eopDeref, eopMemAddress, // Pointers
                  eopSubIdent); // SomeRec.A, A is subIdent of SomeRec
 
   { TPasExpr }
@@ -1481,7 +1481,7 @@ const
         '=','<>',
         '<','>','<=','>=',
         'in','is','as','><',
-        '@','^',
+        '@','^','@@',
         '.');
 
 
@@ -3582,8 +3582,6 @@ function TPasRecordType.GetDeclaration (full : boolean) : string;
 Var
   S : TStringList;
   temp : string;
-  i : integer;
-
 begin
   S:=TStringList.Create;
   Try

packages/fcl-passrc/src/pparser.pp

@@ -1877,6 +1877,7 @@ begin
     tkEqual                 : Result:=eopEqual;
     tkGreaterThan           : Result:=eopGreaterThan;
     tkAt                    : Result:=eopAddress;
+    tkAtAt                  : Result:=eopMemAddress;
     tkNotEqual              : Result:=eopNotEqual;
     tkLessEqualThan         : Result:=eopLessthanEqual;
     tkGreaterEqualThan      : Result:=eopGreaterThanEqual;
@@ -2046,18 +2047,6 @@ begin
       Last:=CreateSelfExpr(AParent);
       HandleSelf(Last);
       end;
-    tkAt:
-      begin
-      // is this still needed?
-      // P:=@function;
-      NextToken;
-      if (length(CurTokenText)=0) or not (CurTokenText[1] in ['A'..'_']) then
-        begin
-        UngetToken;
-        ParseExcExpectedIdentifier;
-        end;
-      Last:=CreatePrimitiveExpr(AParent,pekString, '@'+CurTokenText);
-      end;
     tkCaret:
       begin
       // is this still needed?
@@ -2155,7 +2144,7 @@ begin
   case t of
   //  tkDot:
   //    Result:=5;
-    tknot,tkAt:
+    tknot,tkAt,tkAtAt:
       Result:=4;
     tkMul, tkDivision, tkdiv, tkmod, tkand, tkShl,tkShr, tkas, tkPower :
       Result:=3;
@@ -2180,7 +2169,7 @@ var
   NotBinary : Boolean;
 
 const
-  PrefixSym = [tkPlus, tkMinus, tknot, tkAt]; // + - not @
+  PrefixSym = [tkPlus, tkMinus, tknot, tkAt, tkAtAt]; // + - not @
   BinaryOP  = [tkMul, tkDivision, tkdiv, tkmod,  tkDotDot,
                tkand, tkShl,tkShr, tkas, tkPower,
                tkPlus, tkMinus, tkor, tkxor, tkSymmetricalDifference,
@@ -4659,7 +4648,7 @@ Var
   Function atEndOfAsm : Boolean;
 
   begin
-    Result:=(CurToken=tkEnd) and (LastToken<>tkAt);
+    Result:=(CurToken=tkEnd) and not (LastToken in [tkAt,tkAtAt]);
   end;
 
 begin
@@ -5137,11 +5126,12 @@ begin
       end;
     tkEOF:
       CheckToken(tkend);
-    tkAt,tkBraceOpen,tkIdentifier,tkNumber,tkSquaredBraceOpen,tkMinus,tkPlus,tkinherited:
+    tkAt,tkAtAt,tkBraceOpen,tkIdentifier,tkNumber,tkSquaredBraceOpen,tkMinus,tkPlus,tkinherited:
       begin
-// This should in fact not be checked here.
-//      if (CurToken=tkAt) and not (msDelphi in CurrentModeswitches) then
-//        ParseExc;
+      // Do not check this here:
+      //      if (CurToken=tkAt) and not (msDelphi in CurrentModeswitches) then
+      //        ParseExc;
+
       // On is usable as an identifier
       if lowerCase(CurTokenText)='on' then
         begin

packages/fcl-passrc/src/pscanner.pp

@@ -138,6 +138,7 @@ type
     tkAssignMinus,           // -=
     tkAssignMul,             // *=
     tkAssignDivision,        // /=
+    tkAtAt,                  // @@
     // Reserved words
     tkabsolute,
     tkand,
@@ -685,6 +686,7 @@ const
     '-=',
     '*=',
     '/=',
+    '@@',
     // Reserved words
     'absolute',
     'and',
@@ -3268,6 +3270,11 @@ begin
       begin
         Inc(TokenStr);
         Result := tkAt;
+        if TokenStr^='@' then
+          begin
+          Inc(TokenStr);
+          Result:=tkAtAt;
+          end;
       end;
     '[':
       begin

packages/fcl-passrc/tests/tcresolver.pas

@@ -565,6 +565,7 @@ type
     Procedure TestProcTypeCall;
     Procedure TestProcType_FunctionFPC;
     Procedure TestProcType_FunctionDelphi;
+    Procedure TestProcType_ProcedureDelphi;
     Procedure TestProcType_MethodFPC;
     Procedure TestProcType_MethodDelphi;
     Procedure TestAssignProcToMethodFail;
@@ -9202,6 +9203,7 @@ begin
   Add('var');
   Add('  b: boolean;');
   Add('  vP, vQ: tfuncint;');
+  Add('  ');
   Add('begin');
   Add('  vp:=nil;');
   Add('  vp:=vp;');
@@ -9231,6 +9233,55 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestProcType_ProcedureDelphi;
+begin
+  StartProgram(false);
+  Add('{$mode Delphi}');
+  Add('type');
+  Add('  TProc = procedure;');
+  Add('procedure Doit;');
+  Add('begin end;');
+  Add('var');
+  Add('  b: boolean;');
+  Add('  vP, vQ: tproc;');
+  Add('begin');
+  Add('  vp:=nil;');
+  Add('  vp:=vp;');
+  Add('  vp:=vq;');
+  Add('  vp:=@doit;'); // ok in fpc and delphi, Note that in Delphi type of @F is Pointer, while in FPC it is the proc type
+  Add('  vp:=doit;'); // illegal in fpc, ok in delphi
+  //Add('  vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
+  Add('  vp;'); // ok in fpc and delphi
+  Add('  vp();');
+
+  // equal
+  //Add('  b:=vp=nil;'); // ok in fpc, illegal in delphi
+  Add('  b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
+  //Add('  b:=nil=vp;'); // ok in fpc, illegal in delphi
+  Add('  b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
+  Add('  b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
+  //Add('  b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
+  //Add('  b:=vp=@doit;'); // ok in fpc, illegal in delphi
+  Add('  b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
+  //Add('  b:=@doit=vp;'); // ok in fpc, illegal in delphi
+  Add('  b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
+
+  // unequal
+  //Add('  b:=vp<>nil;'); // ok in fpc, illegal in delphi
+  Add('  b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
+  //Add('  b:=nil<>vp;'); // ok in fpc, illegal in delphi
+  Add('  b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
+  //Add('  b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
+  Add('  b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
+  //Add('  b:=vp<>@doit;'); // ok in fpc, illegal in delphi
+  Add('  b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
+  //Add('  b:=@doit<>vp;'); // ok in fpc, illegal in delphi
+  Add('  b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
+
+  Add('  b:=Assigned(vp);');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestProcType_MethodFPC;
 begin
   StartProgram(false);