fcl-passrc:

parser: ask resolver if TArrayValues is needed for () constant
  resolver: allow string constant as array of char init value

git-svn-id: trunk@35910 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1300,6 +1300,7 @@ type
       Ref: TResolvedReference); virtual;
     function GetVisibilityContext: TPasElement;
     procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
+    function NeedArrayValues(El: TPasElement): boolean; override;
     // built in types and functions
     procedure ClearBuiltInIdentifiers; virtual;
     procedure AddObjFPCBuiltInIdentifiers(
@@ -1437,6 +1438,7 @@ type
     function IsDynArray(TypeEl: TPasType): boolean;
     function IsOpenArray(TypeEl: TPasType): boolean;
     function IsDynOrOpenArray(TypeEl: TPasType): boolean;
+    function IsVarInit(Expr: TPasExpr): boolean;
     function IsEmptySet(const ResolvedEl: TPasResolverResult): boolean;
     function IsClassMethod(El: TPasElement): boolean;
     function IsExternalClassName(aClass: TPasClassType; const ExtName: string): boolean;
@@ -8515,6 +8517,26 @@ begin
   end;
 end;
 
+function TPasResolver.NeedArrayValues(El: TPasElement): boolean;
+// called by the parser when reading DoParseConstValueExpression
+var
+  C: TClass;
+  V: TPasVariable;
+  TypeEl: TPasType;
+begin
+  Result:=false;
+  if El=nil then exit;
+  C:=El.ClassType;
+  if (C=TPasConst) or (C=TPasVariable) then
+    begin
+    V:=TPasVariable(El);
+    if V.VarType=nil then exit;
+    TypeEl:=ResolveAliasType(V.VarType);
+    Result:=TypeEl.ClassType=TPasArrayType;
+    end;
+  //writeln('TPasResolver.NeedArrayValues ',GetObjName(El));
+end;
+
 class procedure TPasResolver.UnmangleSourceLineNumber(LineNumber: integer; out
   Line, Column: integer);
 begin
@@ -10561,10 +10583,17 @@ function TPasResolver.CheckAssignCompatibilityArrayType(const LHS,
           Count:=length(TArrayValues(Expr).Values)
         else if (Expr.ClassType=TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
           Count:=length(TParamsExpr(Expr).Params)
+        else if (Values.BaseType in btAllStringAndChars) and IsVarInit(Expr) then
+          begin
+          // const a: dynarray = string
+          ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
+          if ElTypeResolved.BaseType in btAllChars then
+            Result:=cExact;
+          exit;
+          end
         else
           begin
-          if RaiseOnIncompatible then
-            RaiseNotYetImplemented(20170420151703,Expr,'assign one value to a dynamic array');
+          // single value
           exit;
           end;
         end;
@@ -11775,19 +11804,36 @@ begin
       and (length(TPasArrayType(TypeEl).Ranges)=0);
 end;
 
+function TPasResolver.IsVarInit(Expr: TPasExpr): boolean;
+var
+  C: TClass;
+begin
+  Result:=false;
+  if Expr=nil then exit;
+  if Expr.Parent=nil then exit;
+  C:=Expr.Parent.ClassType;
+  if C.InheritsFrom(TPasVariable) then
+    Result:=(TPasVariable(Expr.Parent).Expr=Expr)
+  else if C=TPasArgument then
+    Result:=(TPasArgument(Expr.Parent).ValueExpr=Expr);
+end;
+
 function TPasResolver.IsEmptySet(const ResolvedEl: TPasResolverResult): boolean;
 begin
   Result:=(ResolvedEl.BaseType=btSet) and (ResolvedEl.SubType=btNone);
 end;
 
 function TPasResolver.IsClassMethod(El: TPasElement): boolean;
+var
+  C: TClass;
 begin
-  Result:=(El<>nil)
-     and ((El.ClassType=TPasClassConstructor)
-       or (El.ClassType=TPasClassDestructor)
-       or (El.ClassType=TPasClassProcedure)
-       or (El.ClassType=TPasClassFunction)
-       or (El.ClassType=TPasClassOperator));
+  if El=nil then exit(false);
+  C:=El.ClassType;;
+  Result:=(C=TPasClassConstructor)
+       or (C=TPasClassDestructor)
+       or (C=TPasClassProcedure)
+       or (C=TPasClassFunction)
+       or (C=TPasClassOperator);
 end;
 
 function TPasResolver.IsExternalClassName(aClass: TPasClassType;

packages/fcl-passrc/src/pparser.pp

@@ -182,6 +182,7 @@ type
     function FindElement(const AName: String): TPasElement; virtual; abstract;
     procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
     function FindModule(const AName: String): TPasModule; virtual;
+    function NeedArrayValues(El: TPasElement): boolean; virtual;
     property Package: TPasPackage read FPackage;
     property InterfaceOnly : Boolean Read FInterfaceOnly Write FInterFaceOnly;
     property ScannerLogEvents : TPScannerLogEvents Read FScannerLogEvents Write FScannerLogEvents;
@@ -731,6 +732,12 @@ begin
   Result := nil;
 end;
 
+function TPasTreeContainer.NeedArrayValues(El: TPasElement): boolean;
+begin
+  Result:=false;
+  if El=nil then ;
+end;
+
 { ---------------------------------------------------------------------
   EParserError
   ---------------------------------------------------------------------}
@@ -2085,11 +2092,6 @@ begin
 end;
 
 function TPasParser.DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
-var
-  x : TPasExpr;
-  n : AnsiString;
-  r : TRecordValues;
-  a : TArrayValues;
 
   function lastfield:boolean;
 
@@ -2105,76 +2107,95 @@ var
      end;
   end;
 
+  procedure ReadArrayValues(x : TPasExpr);
+  var
+    a: TArrayValues;
+  begin
+    Result:=nil;
+    a:=nil;
+    try
+      a:=CreateArrayValues(AParent);
+      if x<>nil then
+        begin
+        a.AddValues(x);
+        x:=nil;
+        end;
+      repeat
+        NextToken;
+        a.AddValues(DoParseConstValueExpression(AParent));
+      until CurToken<>tkComma;
+      Result:=a;
+    finally
+      if Result=nil then
+        begin
+        a.Free;
+        x.Free;
+        end;
+    end;
+  end;
+
+var
+  x : TPasExpr;
+  n : AnsiString;
+  r : TRecordValues;
 begin
   if CurToken <> tkBraceOpen then
     Result:=DoParseExpression(AParent)
   else begin
     Result:=nil;
-    NextToken;
-    x:=DoParseConstValueExpression(AParent);
-    case CurToken of
-      tkComma: // array of values (a,b,c);
-        try
-          a:=CreateArrayValues(AParent);
-          a.AddValues(x);
-          x:=nil;
-          repeat
-            NextToken;
-            x:=DoParseConstValueExpression(AParent);
-            a.AddValues(x);
-            x:=nil;
-          until CurToken<>tkComma;
-          Result:=a;
-        finally
-          if Result=nil then
-            begin
-            a.Free;
-            x.Free;
-            end;
-        end;
-
-      tkColon: // record field (a:xxx;b:yyy;c:zzz);
-        begin
-          r:=nil;
-          try
-            n:=GetExprIdent(x);
-            ReleaseAndNil(TPasElement(x));
-            r:=CreateRecordValues(AParent);
-            NextToken;
-            x:=DoParseConstValueExpression(AParent);
-            r.AddField(n, x);
-            x:=nil;
-            if not lastfield then
-              repeat
-                n:=ExpectIdentifier;
-                ExpectToken(tkColon);
-                NextToken;
-                x:=DoParseConstValueExpression(AParent);
-                r.AddField(n, x);
-                x:=nil;
-              until lastfield; // CurToken<>tkSemicolon;
-            Result:=r;
-          finally
-            if Result=nil then
-              begin
-              r.Free;
-              x.Free;
-              end;
-          end;
-        end;
+    if Engine.NeedArrayValues(AParent) then
+      ReadArrayValues(nil)
     else
-      // Binary expression!  ((128 div sizeof(longint)) - 3);
-      Result:=DoParseExpression(AParent,x);
-      if CurToken<>tkBraceClose then
-        begin
-        ReleaseAndNil(TPasElement(Result));
-        ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
-        end;
+      begin
       NextToken;
-      if CurToken <> tkSemicolon then // the continue of expression
-        Result:=DoParseExpression(AParent,Result);
-      Exit;
-    end;
+      x:=DoParseConstValueExpression(AParent);
+      case CurToken of
+        tkComma: // array of values (a,b,c);
+          ReadArrayValues(x);
+
+        tkColon: // record field (a:xxx;b:yyy;c:zzz);
+          begin
+            r:=nil;
+            try
+              n:=GetExprIdent(x);
+              ReleaseAndNil(TPasElement(x));
+              r:=CreateRecordValues(AParent);
+              NextToken;
+              x:=DoParseConstValueExpression(AParent);
+              r.AddField(n, x);
+              x:=nil;
+              if not lastfield then
+                repeat
+                  n:=ExpectIdentifier;
+                  ExpectToken(tkColon);
+                  NextToken;
+                  x:=DoParseConstValueExpression(AParent);
+                  r.AddField(n, x);
+                  x:=nil;
+                until lastfield; // CurToken<>tkSemicolon;
+              Result:=r;
+            finally
+              if Result=nil then
+                begin
+                r.Free;
+                x.Free;
+                end;
+            end;
+          end;
+      else
+        // Binary expression!  ((128 div sizeof(longint)) - 3);
+        Result:=DoParseExpression(AParent,x);
+        if CurToken<>tkBraceClose then
+          begin
+          ReleaseAndNil(TPasElement(Result));
+          ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
+          end;
+        NextToken;
+        if CurToken <> tkSemicolon then // the continue of expression
+          Result:=DoParseExpression(AParent,Result);
+        Exit;
+      end;
+      end;
     if CurToken<>tkBraceClose then
       begin
       ReleaseAndNil(TPasElement(Result));

packages/fcl-passrc/tests/tcresolver.pas

@@ -498,6 +498,7 @@ type
     Procedure TestArrayEnumTypeConstWrongTypeFail;
     Procedure TestArrayEnumTypeConstNonConstFail;
     Procedure TestArrayEnumTypeSetLengthFail;
+    Procedure TestArray_DynArrayConst;
     Procedure TestArray_AssignNilToStaticArrayFail1;
     Procedure TestArray_SetLengthProperty;
     Procedure TestArray_PassArrayElementToVarParam;
@@ -7895,6 +7896,26 @@ begin
     nIncompatibleTypeArgNo);
 end;
 
+procedure TTestResolver.TestArray_DynArrayConst;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  integer = longint;',
+  '  TArrInt = array of integer;',
+  '  TArrStr = array of string;',
+  'const',
+  '  Ints: TArrInt = (1,2,3);',
+  '  Names: array of string = (''a'',''foo'');',
+  '  Aliases: TarrStr = (''foo'',''b'');',
+  '  OneInt: TArrInt = (7);',
+  '  OneStr: array of integer = (7);',
+  '  Chars: array of char = ''aoc'';',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestArray_AssignNilToStaticArrayFail1;
 begin
   StartProgram(false);