* Fix bug #30701: allow formatting arguments in str() and writeln()

git-svn-id: trunk@34687 -

packages/fcl-passrc/src/pastree.pp

@@ -168,7 +168,9 @@ type
   TPasExpr = class(TPasElement)
     Kind      : TPasExprKind;
     OpCode    : TExprOpCode;
+    format1,format2 : TPasExpr;
     constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TExprOpCode); virtual; overload;
+    destructor destroy; override;
   end;
 
   { TUnaryExpr }
@@ -4045,13 +4047,21 @@ end;
 
 { TPasExpr }
 
-constructor TPasExpr.Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TexprOpcode);
+constructor TPasExpr.Create(AParent: TPasElement; AKind: TPasExprKind;
+  AOpCode: TExprOpCode);
 begin
   inherited Create(ClassName, AParent);
   Kind:=AKind;
   OpCode:=AOpCode;
 end;
 
+destructor TPasExpr.destroy;
+begin
+  FreeAndNil(Format1);
+  FreeAndNil(Format2);
+  inherited destroy;
+end;
+
 { TPrimitiveExpr }
 
 function TPrimitiveExpr.GetDeclaration(Full : Boolean):AnsiString;

packages/fcl-passrc/src/pparser.pp

@@ -295,7 +295,7 @@ type
     Function TokenIsCallingConvention(S : String; out CC : TCallingConvention) : Boolean; virtual;
     Function TokenIsProcedureModifier(Parent : TPasElement; S : String; Out Pm : TProcedureModifier) : Boolean; virtual;
     Function CheckHint(Element : TPasElement; ExpectSemiColon : Boolean) : TPasMemberHints;
-    function ParseParams(AParent : TPasElement;paramskind: TPasExprKind): TParamsExpr;
+    function ParseParams(AParent : TPasElement;paramskind: TPasExprKind; AllowFormatting : Boolean = False): TParamsExpr;
     function ParseExpIdent(AParent : TPasElement): TPasExpr;
     procedure DoParseClassType(AType: TPasClassType);
     function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil): TPasExpr;
@@ -1389,11 +1389,13 @@ begin
   Result:=(CurToken in EndExprToken) or IsCurTokenHint;
 end;
 
-function TPasParser.ParseParams(AParent: TPasElement;paramskind: TPasExprKind): TParamsExpr;
+function TPasParser.ParseParams(AParent: TPasElement; paramskind: TPasExprKind;
+  AllowFormatting: Boolean = False): TParamsExpr;
 var
   params  : TParamsExpr;
   p       : TPasExpr;
   PClose  : TToken;
+
 begin
   Result:=nil;
   if paramskind in [pekArrayParams, pekSet] then begin
@@ -1413,7 +1415,19 @@ begin
         p:=DoParseExpression(params);
         if not Assigned(p) then Exit; // bad param syntax
         params.AddParam(p);
-
+        if (CurToken=tkColon) then
+          if Not AllowFormatting then
+            ParseExcSyntaxError
+          else
+            begin
+            NextToken;
+            p.format1:=DoParseExpression(p);
+            if (CurToken=tkColon) then
+              begin
+              NextToken;
+              p.format2:=DoParseExpression(p);
+              end;
+            end;
         if not (CurToken in [tkComma, PClose]) then begin
           Exit;
         end;
@@ -1470,12 +1484,27 @@ begin
 end;
  
 function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
+
+  Function IsWriteOrstr(P : TPasExpr) : boolean;
+
+  Var
+    N : String;
+  begin
+    Result:=P is TPrimitiveExpr;
+    if Result then
+      begin
+      N:=LowerCase(TPrimitiveExpr(P).Value);
+      // We should actually resolve this to system.NNN
+      Result:=(N='write') or (N='str') or (N='writeln');
+      end;
+  end;
 var
   Last    , Expr: TPasExpr;
   prm     : TParamsExpr;
   b       : TBinaryExpr;
   optk    : TToken;
   ok: Boolean;
+
 begin
   Result:=nil;
   case CurToken of
@@ -1578,7 +1607,7 @@ begin
           tkBraceOpen,tkSquaredBraceOpen:
             begin
             if CurToken=tkBraceOpen then
-              prm:=ParseParams(AParent,pekFuncParams)
+              prm:=ParseParams(AParent,pekFuncParams,isWriteOrStr(Last))
             else
               prm:=ParseParams(AParent,pekArrayParams);
             if not Assigned(prm) then Exit;

packages/fcl-passrc/tests/tcstatements.pas

@@ -19,6 +19,8 @@ Type
   private
     FStatement: TPasImplBlock;
     FVariables : TStrings;
+    procedure DoTestCallOtherFormat;
+    procedure TestCallFormat(FN: String; Two: Boolean);
   Protected
     Procedure SetUp; override;
     Procedure TearDown; override;
@@ -48,6 +50,13 @@ Type
     Procedure TestCallQualified2;
     Procedure TestCallNoArgs;
     Procedure TestCallOneArg;
+    procedure TestCallWriteFormat1;
+    procedure TestCallWriteFormat2;
+    procedure TestCallWritelnFormat1;
+    procedure TestCallWritelnFormat2;
+    procedure TestCallStrFormat1;
+    procedure TestCallStrFormat2;
+    procedure TestCallOtherFormat;
     Procedure TestIf;
     Procedure TestIfBlock;
     Procedure TestIfAssignment;
@@ -413,6 +422,7 @@ begin
 end;
 
 procedure TTestStatementParser.TestCallOneArg;
+
 Var
   S : TPasImplSimple;
   P : TParamsExpr;
@@ -429,6 +439,76 @@ begin
   AssertExpression('Parameter is constant',P.Params[0],pekNumber,'1');
 end;
 
+procedure TTestStatementParser.TestCallFormat(FN : String; Two : Boolean);
+
+Var
+  S : TPasImplSimple;
+  P : TParamsExpr;
+  N : String;
+begin
+  N:=fn+'(a:3';
+  if Two then
+    N:=N+':2';
+  N:=N+');';
+  TestStatement(N);
+  AssertEquals('1 statement',1,PasProgram.InitializationSection.Elements.Count);
+  AssertEquals('Simple statement',TPasImplSimple,Statement.ClassType);
+  S:=Statement as TPasImplSimple;
+  AssertExpression('Doit call',S.Expr,pekFuncParams,TParamsExpr);
+  P:=S.Expr as TParamsExpr;
+  AssertExpression('Correct function call name',P.Value,pekIdent,FN);
+  AssertEquals('One param',1,Length(P.Params));
+  AssertExpression('Parameter is identifier',P.Params[0],pekIdent,'a');
+  AssertExpression('Parameter has formatting constant 1' ,P.Params[0].format1,pekNumber,'3');
+  if Two then
+    AssertExpression('Parameter has formatting constant 2',P.Params[0].format2,pekNumber,'2');
+end;
+
+procedure TTestStatementParser.TestCallWriteFormat1;
+
+begin
+  TestCalLFormat('write',False);
+end;
+
+procedure TTestStatementParser.TestCallWriteFormat2;
+
+begin
+  TestCalLFormat('write',True);
+end;
+
+procedure TTestStatementParser.TestCallWritelnFormat1;
+begin
+  TestCalLFormat('writeln',False);
+
+end;
+
+procedure TTestStatementParser.TestCallWritelnFormat2;
+begin
+  TestCalLFormat('writeln',True);
+end;
+
+procedure TTestStatementParser.TestCallStrFormat1;
+begin
+  TestCalLFormat('str',False);
+end;
+
+procedure TTestStatementParser.TestCallStrFormat2;
+begin
+  TestCalLFormat('str',True);
+end;
+
+procedure TTestStatementParser.DoTestCallOtherFormat;
+
+begin
+  TestCalLFormat('nono',False);
+end;
+
+procedure TTestStatementParser.TestCallOtherFormat;
+
+begin
+  AssertException('Only Write(ln) and str allow format',EParserError,@DoTestCallOtherFormat);
+end;
+
 procedure TTestStatementParser.TestIf;
 
 Var

packages/fcl-passrc/tests/tctypeparser.pas

@@ -3099,8 +3099,6 @@ end;
 procedure TTestTypeParser.TestRangeLowHigh;
 
 begin
-   TShortCut = Low(Word)..High(Word);
-
   DoParseRangeSet('low(TRange)..high(TRange)','');
 end;